This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Re: [BUG] string loses its utf8 flag on die
[perl5.git] / lib / Cwd.pm
CommitLineData
a0d0e21e 1package Cwd;
3b825e41 2use 5.006;
a0d0e21e 3
f06db76b
AD
4=head1 NAME
5
902bacac 6Cwd - get pathname of current working directory
f06db76b
AD
7
8=head1 SYNOPSIS
9
4633a7c4 10 use Cwd;
04929354 11 my $dir = getcwd;
4633a7c4 12
04929354
MS
13 use Cwd 'abs_path';
14 my $abs_path = abs_path($file);
f06db76b 15
04929354 16=head1 DESCRIPTION
902bacac 17
04929354
MS
18This module provides functions for determining the pathname of the
19current working directory. It is recommended that getcwd (or another
20*cwd() function) be used in I<all> code to ensure portability.
f06db76b 21
04929354
MS
22By default, it exports the functions cwd(), getcwd(), fastcwd(), and
23fastgetcwd() into the caller's namespace.
f06db76b 24
20408e3c 25
04929354 26=head2 getcwd and friends
20408e3c 27
04929354
MS
28Each of these functions are called without arguments and return the
29absolute path of the current working directory.
f06db76b 30
04929354
MS
31=over 4
32
33=item getcwd
34
35 my $cwd = getcwd();
36
37Returns the current working directory.
38
39Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
40
41=item cwd
42
43 my $cwd = cwd();
44
45The cwd() is the most natural form for the current architecture. For
46most systems it is identical to `pwd` (but without the trailing line
47terminator).
48
04929354
MS
49=item fastcwd
50
51 my $cwd = fastcwd();
52
53A more dangerous version of getcwd(), but potentially faster.
54
55It might conceivably chdir() you out of a directory that it can't
56chdir() you back into. If fastcwd encounters a problem it will return
57undef but will probably leave you in a different directory. For a
58measure of extra security, if everything appears to have worked, the
59fastcwd() function will check that it leaves you in the same directory
60that it started in. If it has changed it will C<die> with the message
61"Unstable directory path, current directory changed
62unexpectedly". That should never happen.
63
64=item fastgetcwd
65
66 my $cwd = fastgetcwd();
f06db76b 67
902bacac 68The fastgetcwd() function is provided as a synonym for cwd().
fb73857a 69
04929354
MS
70=back
71
902bacac 72
04929354
MS
73=head2 abs_path and friends
74
75These functions are exported only on request. They each take a single
3ee63918
MS
76argument and return the absolute pathname for it. If no argument is
77given they'll use the current working directory.
04929354
MS
78
79=over 4
80
81=item abs_path
82
83 my $abs_path = abs_path($file);
84
85Uses the same algorithm as getcwd(). Symbolic links and relative-path
86components ("." and "..") are resolved to return the canonical
87pathname, just like realpath(3).
88
89=item realpath
90
91 my $abs_path = realpath($file);
92
93A synonym for abs_path().
94
95=item fast_abs_path
96
510179aa 97 my $abs_path = fast_abs_path($file);
04929354
MS
98
99A more dangerous, but potentially faster version of abs_path.
100
101=back
102
103=head2 $ENV{PWD}
104
105If you ask to override your chdir() built-in function,
106
107 use Cwd qw(chdir);
108
109then your PWD environment variable will be kept up to date. Note that
110it will only be kept up to date if all packages which use chdir import
111it from Cwd.
4633a7c4 112
4633a7c4 113
4d6b4052
JH
114=head1 NOTES
115
116=over 4
117
118=item *
119
04929354
MS
120Since the path seperators are different on some operating systems ('/'
121on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
122modules wherever portability is a concern.
123
04929354 124=item *
4d6b4052
JH
125
126Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
127functions are all aliases for the C<cwd()> function, which, on Mac OS,
128calls `pwd`. Likewise, the C<abs_path()> function is an alias for
129C<fast_abs_path()>.
130
131=back
132
04929354
MS
133=head1 SEE ALSO
134
135L<File::chdir>
136
f06db76b
AD
137=cut
138
b060a406 139use strict;
96e4d5b1 140
3ee63918 141our $VERSION = '2.08';
96e4d5b1 142
b060a406
TJ
143use base qw/ Exporter /;
144our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
145our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
a0d0e21e 146
f5f423e4
IZ
147# sys_cwd may keep the builtin command
148
149# All the functionality of this module may provided by builtins,
150# there is no sense to process the rest of the file.
151# The best choice may be to have this in BEGIN, but how to return from BEGIN?
152
153if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) {
154 local $^W = 0;
155 *cwd = \&sys_cwd;
156 *getcwd = \&cwd;
157 *fastgetcwd = \&cwd;
158 *fastcwd = \&cwd;
159 *abs_path = \&sys_abspath;
160 *fast_abs_path = \&abs_path;
161 *realpath = \&abs_path;
162 *fast_realpath = \&abs_path;
163 return 1;
164}
165
f22d8e4b
DM
166eval {
167 require XSLoader;
46ba3155 168 local $^W = 0;
f22d8e4b
DM
169 XSLoader::load('Cwd');
170};
4633a7c4 171
96e4d5b1 172
3547aa9a
MS
173# Find the pwd command in the expected locations. We assume these
174# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
175# so everything works under taint mode.
176my $pwd_cmd;
177foreach my $try (qw(/bin/pwd /usr/bin/pwd)) {
178 if( -x $try ) {
179 $pwd_cmd = $try;
180 last;
181 }
182}
522b859a
JH
183unless ($pwd_cmd) {
184 if (-x '/QOpenSys/bin/pwd') { # OS/400 PASE.
185 $pwd_cmd = '/QOpenSys/bin/pwd' ;
186 } else {
187 # Isn't this wrong? _backtick_pwd() will fail if somenone has
188 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
189 # See [perl #16774]. --jhi
190 $pwd_cmd = 'pwd';
191 }
192}
3547aa9a
MS
193
194# The 'natural and safe form' for UNIX (pwd may be setuid root)
8b88ae92 195sub _backtick_pwd {
db281859 196 local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
3547aa9a 197 my $cwd = `$pwd_cmd`;
ac3b20cb 198 # Belt-and-suspenders in case someone said "undef $/".
5cf6da5f 199 local $/ = "\n";
ac3b20cb 200 # `pwd` may fail e.g. if the disk is full
7e03f963 201 chomp($cwd) if defined $cwd;
4633a7c4 202 $cwd;
8b88ae92 203}
4633a7c4
LW
204
205# Since some ports may predefine cwd internally (e.g., NT)
206# we take care not to override an existing definition for cwd().
207
ea54c8bd
EC
208unless(defined &cwd) {
209 # The pwd command is not available in some chroot(2)'ed environments
73b801a6
MS
210 if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
211 grep { -x "$_/pwd" } split(':', $ENV{PATH})) )
212 {
ea54c8bd
EC
213 *cwd = \&_backtick_pwd;
214 }
215 else {
216 *cwd = \&getcwd;
217 }
218}
a0d0e21e 219
1f4f94f5
RS
220# set a reasonable (and very safe) default for fastgetcwd, in case it
221# isn't redefined later (20001212 rspier)
222*fastgetcwd = \&cwd;
748a9306 223
a0d0e21e
LW
224# By Brandon S. Allbery
225#
226# Usage: $cwd = getcwd();
227
228sub getcwd
229{
07569ed3 230 abs_path('.');
a0d0e21e
LW
231}
232
a0c9c202
JH
233
234# By John Bazik
235#
236# Usage: $cwd = &fastcwd;
237#
238# This is a faster version of getcwd. It's also more dangerous because
239# you might chdir out of a directory that you can't chdir back into.
240
241sub fastcwd {
242 my($odev, $oino, $cdev, $cino, $tdev, $tino);
243 my(@path, $path);
244 local(*DIR);
245
246 my($orig_cdev, $orig_cino) = stat('.');
247 ($cdev, $cino) = ($orig_cdev, $orig_cino);
248 for (;;) {
249 my $direntry;
250 ($odev, $oino) = ($cdev, $cino);
251 CORE::chdir('..') || return undef;
252 ($cdev, $cino) = stat('.');
253 last if $odev == $cdev && $oino == $cino;
254 opendir(DIR, '.') || return undef;
255 for (;;) {
256 $direntry = readdir(DIR);
257 last unless defined $direntry;
258 next if $direntry eq '.';
259 next if $direntry eq '..';
260
261 ($tdev, $tino) = lstat($direntry);
262 last unless $tdev != $odev || $tino != $oino;
263 }
264 closedir(DIR);
265 return undef unless defined $direntry; # should never happen
266 unshift(@path, $direntry);
267 }
268 $path = '/' . join('/', @path);
269 if ($^O eq 'apollo') { $path = "/".$path; }
270 # At this point $path may be tainted (if tainting) and chdir would fail.
248785eb
RGS
271 # Untaint it then check that we landed where we started.
272 $path =~ /^(.*)\z/s # untaint
273 && CORE::chdir($1) or return undef;
a0c9c202
JH
274 ($cdev, $cino) = stat('.');
275 die "Unstable directory path, current directory changed unexpectedly"
276 if $cdev != $orig_cdev || $cino != $orig_cino;
277 $path;
278}
279
280
4633a7c4 281# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
282# Usage:
283# use Cwd 'chdir';
284# chdir $newdir;
285
4633a7c4 286my $chdir_init = 0;
a0d0e21e 287
4633a7c4 288sub chdir_init {
3b8e3443 289 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
290 my($dd,$di) = stat('.');
291 my($pd,$pi) = stat($ENV{'PWD'});
292 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 293 $ENV{'PWD'} = cwd();
a0d0e21e
LW
294 }
295 }
296 else {
3b8e3443
GS
297 my $wd = cwd();
298 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
299 $ENV{'PWD'} = $wd;
a0d0e21e 300 }
4633a7c4 301 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 302 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
303 my($pd,$pi) = stat($2);
304 my($dd,$di) = stat($1);
305 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
306 $ENV{'PWD'}="$2$3";
307 }
308 }
309 $chdir_init = 1;
310}
311
312sub chdir {
22978713 313 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 314 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 315 chdir_init() unless $chdir_init;
4ffa1610
JH
316 my $newpwd;
317 if ($^O eq 'MSWin32') {
318 # get the full path name *before* the chdir()
319 $newpwd = Win32::GetFullPathName($newdir);
320 }
321
4633a7c4 322 return 0 unless CORE::chdir $newdir;
4ffa1610 323
3b8e3443
GS
324 if ($^O eq 'VMS') {
325 return $ENV{'PWD'} = $ENV{'DEFAULT'}
326 }
4aecb5b5
JH
327 elsif ($^O eq 'MacOS') {
328 return $ENV{'PWD'} = cwd();
329 }
3b8e3443 330 elsif ($^O eq 'MSWin32') {
4ffa1610 331 $ENV{'PWD'} = $newpwd;
3b8e3443
GS
332 return 1;
333 }
748a9306 334
392d8ab8 335 if ($newdir =~ m#^/#s) {
a0d0e21e 336 $ENV{'PWD'} = $newdir;
4633a7c4
LW
337 } else {
338 my @curdir = split(m#/#,$ENV{'PWD'});
339 @curdir = ('') unless @curdir;
340 my $component;
a0d0e21e
LW
341 foreach $component (split(m#/#, $newdir)) {
342 next if $component eq '.';
343 pop(@curdir),next if $component eq '..';
344 push(@curdir,$component);
345 }
346 $ENV{'PWD'} = join('/',@curdir) || '/';
347 }
4633a7c4 348 1;
a0d0e21e
LW
349}
350
a0c9c202
JH
351
352# In case the XS version doesn't load.
353*abs_path = \&_perl_abs_path unless defined &abs_path;
354sub _perl_abs_path
355{
356 my $start = @_ ? shift : '.';
357 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
358
359 unless (@cst = stat( $start ))
360 {
e2ba406b
T
361 require Carp;
362 Carp::carp ("stat($start): $!");
a0c9c202
JH
363 return '';
364 }
365 $cwd = '';
366 $dotdots = $start;
367 do
368 {
369 $dotdots .= '/..';
370 @pst = @cst;
a25ef67d 371 local *PARENT;
a0c9c202
JH
372 unless (opendir(PARENT, $dotdots))
373 {
e2ba406b
T
374 require Carp;
375 Carp::carp ("opendir($dotdots): $!");
a0c9c202
JH
376 return '';
377 }
378 unless (@cst = stat($dotdots))
379 {
e2ba406b
T
380 require Carp;
381 Carp::carp ("stat($dotdots): $!");
a0c9c202
JH
382 closedir(PARENT);
383 return '';
384 }
385 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
386 {
387 $dir = undef;
388 }
389 else
390 {
391 do
392 {
393 unless (defined ($dir = readdir(PARENT)))
394 {
e2ba406b
T
395 require Carp;
396 Carp::carp ("readdir($dotdots): $!");
a0c9c202
JH
397 closedir(PARENT);
398 return '';
399 }
400 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
401 }
402 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
403 $tst[1] != $pst[1]);
404 }
405 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
406 closedir(PARENT);
407 } while (defined $dir);
408 chop($cwd) unless $cwd eq '/'; # drop the trailing /
409 $cwd;
410}
411
412
e4c51978
GS
413# added function alias for those of us more
414# used to the libc function. --tchrist 27-Jan-00
415*realpath = \&abs_path;
416
3ee63918 417my $Curdir;
96e4d5b1
PP
418sub fast_abs_path {
419 my $cwd = getcwd();
4d6b4052 420 require File::Spec;
3ee63918
MS
421 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
422
423 # Detaint else we'll explode in taint mode. This is safe because
424 # we're not doing anything dangerous with it.
425 ($path) = $path =~ /(.*)/;
426 ($cwd) = $cwd =~ /(.*)/;
427
e2ba406b
T
428 if (!CORE::chdir($path)) {
429 require Carp;
430 Carp::croak ("Cannot chdir to $path: $!");
431 }
96e4d5b1 432 my $realpath = getcwd();
e2ba406b
T
433 if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
434 require Carp;
435 Carp::croak ("Cannot chdir back to $cwd: $!");
436 }
96e4d5b1 437 $realpath;
8b88ae92
NIS
438}
439
e4c51978
GS
440# added function alias to follow principle of least surprise
441# based on previous aliasing. --tchrist 27-Jan-00
442*fast_realpath = \&fast_abs_path;
443
4633a7c4
LW
444
445# --- PORTING SECTION ---
446
447# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 448# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 449# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
450# in the process logical name table as the default device and directory
451# seen by Perl. This may not be the same as the default device
4633a7c4
LW
452# and directory seen by DCL after Perl exits, since the effects
453# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
454
455sub _vms_cwd {
96e4d5b1
PP
456 return $ENV{'DEFAULT'};
457}
458
459sub _vms_abs_path {
460 return $ENV{'DEFAULT'} unless @_;
461 my $path = VMS::Filespec::pathify($_[0]);
e2ba406b
T
462 if (! defined $path)
463 {
464 require Carp;
465 Carp::croak("Invalid path name $_[0]")
466 }
96e4d5b1 467 return VMS::Filespec::rmsexpand($path);
4633a7c4 468}
68dc0745 469
4633a7c4
LW
470sub _os2_cwd {
471 $ENV{'PWD'} = `cmd /c cd`;
472 chop $ENV{'PWD'};
aa6b7957 473 $ENV{'PWD'} =~ s:\\:/:g ;
4633a7c4
LW
474 return $ENV{'PWD'};
475}
476
96e4d5b1 477sub _win32_cwd {
2d7a9237 478 $ENV{'PWD'} = Win32::GetCwd();
aa6b7957 479 $ENV{'PWD'} =~ s:\\:/:g ;
96e4d5b1
PP
480 return $ENV{'PWD'};
481}
482
483*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237 484 defined &Win32::GetCwd);
96e4d5b1
PP
485
486*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745 487
39e571d4
ML
488sub _dos_cwd {
489 if (!defined &Dos::GetCwd) {
490 $ENV{'PWD'} = `command /c cd`;
491 chop $ENV{'PWD'};
aa6b7957 492 $ENV{'PWD'} =~ s:\\:/:g ;
39e571d4
ML
493 } else {
494 $ENV{'PWD'} = Dos::GetCwd();
495 }
55497cff
PP
496 return $ENV{'PWD'};
497}
498
7fbf1995 499sub _qnx_cwd {
35b807ef
NA
500 local $ENV{PATH} = '';
501 local $ENV{CDPATH} = '';
502 local $ENV{ENV} = '';
7fbf1995
NA
503 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
504 chop $ENV{'PWD'};
505 return $ENV{'PWD'};
506}
507
508sub _qnx_abs_path {
35b807ef
NA
509 local $ENV{PATH} = '';
510 local $ENV{CDPATH} = '';
511 local $ENV{ENV} = '';
fa921dc6 512 my $path = @_ ? shift : '.';
7fbf1995
NA
513 my $realpath=`/usr/bin/fullpath -t $path`;
514 chop $realpath;
515 return $realpath;
516}
517
ed79a026
OF
518sub _epoc_cwd {
519 $ENV{'PWD'} = EPOC::getcwd();
520 return $ENV{'PWD'};
521}
522
ac1ad7f0 523{
db376a24 524 no warnings; # assignments trigger 'subroutine redefined' warning
4633a7c4 525
ac1ad7f0 526 if ($^O eq 'VMS') {
96e4d5b1
PP
527 *cwd = \&_vms_cwd;
528 *getcwd = \&_vms_cwd;
529 *fastcwd = \&_vms_cwd;
530 *fastgetcwd = \&_vms_cwd;
531 *abs_path = \&_vms_abs_path;
532 *fast_abs_path = \&_vms_abs_path;
ac1ad7f0
PM
533 }
534 elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
535 # We assume that &_NT_cwd is defined as an XSUB or in the core.
96e4d5b1
PP
536 *cwd = \&_NT_cwd;
537 *getcwd = \&_NT_cwd;
538 *fastcwd = \&_NT_cwd;
539 *fastgetcwd = \&_NT_cwd;
540 *abs_path = \&fast_abs_path;
cade0c02 541 *realpath = \&fast_abs_path;
ac1ad7f0
PM
542 }
543 elsif ($^O eq 'os2') {
544 # sys_cwd may keep the builtin command
96e4d5b1
PP
545 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
546 *getcwd = \&cwd;
547 *fastgetcwd = \&cwd;
548 *fastcwd = \&cwd;
549 *abs_path = \&fast_abs_path;
ac1ad7f0 550 }
39e571d4
ML
551 elsif ($^O eq 'dos') {
552 *cwd = \&_dos_cwd;
553 *getcwd = \&_dos_cwd;
554 *fastgetcwd = \&_dos_cwd;
555 *fastcwd = \&_dos_cwd;
96e4d5b1 556 *abs_path = \&fast_abs_path;
ac1ad7f0 557 }
7438b6ad 558 elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
7fbf1995
NA
559 *cwd = \&_qnx_cwd;
560 *getcwd = \&_qnx_cwd;
561 *fastgetcwd = \&_qnx_cwd;
562 *fastcwd = \&_qnx_cwd;
563 *abs_path = \&_qnx_abs_path;
564 *fast_abs_path = \&_qnx_abs_path;
565 }
4fabb596 566 elsif ($^O eq 'cygwin') {
1cab015a
FE
567 *getcwd = \&cwd;
568 *fastgetcwd = \&cwd;
569 *fastcwd = \&cwd;
570 *abs_path = \&fast_abs_path;
571 }
ed79a026 572 elsif ($^O eq 'epoc') {
fa6a1c44
OF
573 *cwd = \&_epoc_cwd;
574 *getcwd = \&_epoc_cwd;
ed79a026
OF
575 *fastgetcwd = \&_epoc_cwd;
576 *fastcwd = \&_epoc_cwd;
577 *abs_path = \&fast_abs_path;
578 }
4aecb5b5
JH
579 elsif ($^O eq 'MacOS') {
580 *getcwd = \&cwd;
581 *fastgetcwd = \&cwd;
582 *fastcwd = \&cwd;
583 *abs_path = \&fast_abs_path;
584 }
55497cff 585}
4633a7c4 586
4633a7c4 587
a0d0e21e 5881;