This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't skip too much of the locale error message if no environ array,
[perl5.git] / lib / Cwd.pm
CommitLineData
a0d0e21e
LW
1package Cwd;
2require 5.000;
a0d0e21e 3
f06db76b
AD
4=head1 NAME
5
6getcwd - get pathname of current working directory
7
8=head1 SYNOPSIS
9
4633a7c4
LW
10 use Cwd;
11 $dir = cwd;
12
13 use Cwd;
14 $dir = getcwd;
f06db76b
AD
15
16 use Cwd;
4633a7c4 17 $dir = fastgetcwd;
f06db76b
AD
18
19 use Cwd 'chdir';
20 chdir "/tmp";
21 print $ENV{'PWD'};
22
e4c51978 23 use Cwd 'abs_path'; # aka realpath()
20408e3c
GS
24 print abs_path($ENV{'PWD'});
25
26 use Cwd 'fast_abs_path';
27 print fast_abs_path($ENV{'PWD'});
28
f06db76b
AD
29=head1 DESCRIPTION
30
31The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
4633a7c4 32in Perl.
f06db76b 33
20408e3c 34The abs_path() function takes a single argument and returns the
e4c51978
GS
35absolute pathname for that argument. It uses the same algorithm
36as getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links
37and relative-path components ("." and "..") are resolved to return
38the canonical pathname, just like realpath(3). Also callable as
39realpath().
20408e3c 40
cb1a09d0 41The fastcwd() function looks the same as getcwd(), but runs faster.
fb73857a
PP
42It's also more dangerous because it might conceivably chdir() you out
43of a directory that it can't chdir() you back into. If fastcwd
44encounters a problem it will return undef but will probably leave you
45in a different directory. For a measure of extra security, if
46everything appears to have worked, the fastcwd() function will check
47that it leaves you in the same directory that it started in. If it has
48changed it will C<die> with the message "Unstable directory path,
49current directory changed unexpectedly". That should never happen.
f06db76b 50
20408e3c
GS
51The fast_abs_path() function looks the same as abs_path(), but runs faster.
52And like fastcwd() is more dangerous.
53
4633a7c4
LW
54The cwd() function looks the same as getcwd and fastgetcwd but is
55implemented using the most natural and safe form for the current
56architecture. For most systems it is identical to `pwd` (but without
fb73857a
PP
57the trailing line terminator).
58
59It is recommended that cwd (or another *cwd() function) is used in
60I<all> code to ensure portability.
4633a7c4
LW
61
62If you ask to override your chdir() built-in function, then your PWD
63environment variable will be kept up to date. (See
55497cff 64L<perlsub/Overriding Builtin Functions>.) Note that it will only be
1fef88e7 65kept up to date if all packages which use chdir import it from Cwd.
4633a7c4 66
f06db76b
AD
67=cut
68
b060a406 69use strict;
96e4d5b1
PP
70
71use Carp;
72
1f4f94f5 73our $VERSION = '2.04';
96e4d5b1 74
b060a406
TJ
75use base qw/ Exporter /;
76our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
77our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
a0d0e21e 78
4633a7c4 79
8b88ae92 80# The 'natural and safe form' for UNIX (pwd may be setuid root)
96e4d5b1 81
8b88ae92 82sub _backtick_pwd {
7e03f963
TJ
83 my $cwd = `pwd`;
84 # `pwd` may fail e.g. if the disk is full
85 chomp($cwd) if defined $cwd;
4633a7c4 86 $cwd;
8b88ae92 87}
4633a7c4
LW
88
89# Since some ports may predefine cwd internally (e.g., NT)
90# we take care not to override an existing definition for cwd().
91
ea54c8bd
EC
92unless(defined &cwd) {
93 # The pwd command is not available in some chroot(2)'ed environments
94 if(grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
95 *cwd = \&_backtick_pwd;
96 }
97 else {
98 *cwd = \&getcwd;
99 }
100}
a0d0e21e 101
1f4f94f5
RS
102# set a reasonable (and very safe) default for fastgetcwd, in case it
103# isn't redefined later (20001212 rspier)
104*fastgetcwd = \&cwd;
748a9306 105
a0d0e21e
LW
106# By Brandon S. Allbery
107#
108# Usage: $cwd = getcwd();
109
110sub getcwd
111{
07569ed3 112 abs_path('.');
a0d0e21e
LW
113}
114
a0d0e21e
LW
115# By John Bazik
116#
117# Usage: $cwd = &fastcwd;
118#
119# This is a faster version of getcwd. It's also more dangerous because
120# you might chdir out of a directory that you can't chdir back into.
fb73857a 121
a0d0e21e
LW
122sub fastcwd {
123 my($odev, $oino, $cdev, $cino, $tdev, $tino);
124 my(@path, $path);
125 local(*DIR);
126
fb73857a
PP
127 my($orig_cdev, $orig_cino) = stat('.');
128 ($cdev, $cino) = ($orig_cdev, $orig_cino);
a0d0e21e 129 for (;;) {
40000a8c 130 my $direntry;
a0d0e21e 131 ($odev, $oino) = ($cdev, $cino);
e79e61e4 132 CORE::chdir('..') || return undef;
a0d0e21e
LW
133 ($cdev, $cino) = stat('.');
134 last if $odev == $cdev && $oino == $cino;
fb73857a 135 opendir(DIR, '.') || return undef;
a0d0e21e 136 for (;;) {
40000a8c 137 $direntry = readdir(DIR);
fb73857a 138 last unless defined $direntry;
40000a8c
AD
139 next if $direntry eq '.';
140 next if $direntry eq '..';
a0d0e21e 141
40000a8c 142 ($tdev, $tino) = lstat($direntry);
a0d0e21e
LW
143 last unless $tdev != $odev || $tino != $oino;
144 }
145 closedir(DIR);
fb73857a 146 return undef unless defined $direntry; # should never happen
40000a8c 147 unshift(@path, $direntry);
a0d0e21e 148 }
fb73857a 149 $path = '/' . join('/', @path);
21ac5ced 150 if ($^O eq 'apollo') { $path = "/".$path; }
fb73857a
PP
151 # At this point $path may be tainted (if tainting) and chdir would fail.
152 # To be more useful we untaint it then check that we landed where we started.
392d8ab8 153 $path = $1 if $path =~ /^(.*)\z/s; # untaint
e79e61e4 154 CORE::chdir($path) || return undef;
fb73857a
PP
155 ($cdev, $cino) = stat('.');
156 die "Unstable directory path, current directory changed unexpectedly"
157 if $cdev != $orig_cdev || $cino != $orig_cino;
a0d0e21e
LW
158 $path;
159}
160
161
4633a7c4 162# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
163# Usage:
164# use Cwd 'chdir';
165# chdir $newdir;
166
4633a7c4 167my $chdir_init = 0;
a0d0e21e 168
4633a7c4 169sub chdir_init {
3b8e3443 170 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
171 my($dd,$di) = stat('.');
172 my($pd,$pi) = stat($ENV{'PWD'});
173 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 174 $ENV{'PWD'} = cwd();
a0d0e21e
LW
175 }
176 }
177 else {
3b8e3443
GS
178 my $wd = cwd();
179 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
180 $ENV{'PWD'} = $wd;
a0d0e21e 181 }
4633a7c4 182 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 183 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
184 my($pd,$pi) = stat($2);
185 my($dd,$di) = stat($1);
186 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
187 $ENV{'PWD'}="$2$3";
188 }
189 }
190 $chdir_init = 1;
191}
192
193sub chdir {
22978713 194 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 195 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 196 chdir_init() unless $chdir_init;
4633a7c4 197 return 0 unless CORE::chdir $newdir;
3b8e3443
GS
198 if ($^O eq 'VMS') {
199 return $ENV{'PWD'} = $ENV{'DEFAULT'}
200 }
201 elsif ($^O eq 'MSWin32') {
202 $ENV{'PWD'} = Win32::GetFullPathName($newdir);
203 return 1;
204 }
748a9306 205
392d8ab8 206 if ($newdir =~ m#^/#s) {
a0d0e21e 207 $ENV{'PWD'} = $newdir;
4633a7c4
LW
208 } else {
209 my @curdir = split(m#/#,$ENV{'PWD'});
210 @curdir = ('') unless @curdir;
211 my $component;
a0d0e21e
LW
212 foreach $component (split(m#/#, $newdir)) {
213 next if $component eq '.';
214 pop(@curdir),next if $component eq '..';
215 push(@curdir,$component);
216 }
217 $ENV{'PWD'} = join('/',@curdir) || '/';
218 }
4633a7c4 219 1;
a0d0e21e
LW
220}
221
d57281c6
JH
222# Taken from Cwd.pm It is really getcwd with an optional
223# parameter instead of '.'
224#
8b88ae92 225
d57281c6
JH
226sub abs_path
227{
228 my $start = @_ ? shift : '.';
229 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
929327b2 230
d57281c6
JH
231 unless (@cst = stat( $start ))
232 {
233 carp "stat($start): $!";
234 return '';
8b88ae92 235 }
d57281c6
JH
236 $cwd = '';
237 $dotdots = $start;
238 do
239 {
240 $dotdots .= '/..';
241 @pst = @cst;
242 unless (opendir(PARENT, $dotdots))
243 {
244 carp "opendir($dotdots): $!";
245 return '';
246 }
247 unless (@cst = stat($dotdots))
248 {
249 carp "stat($dotdots): $!";
250 closedir(PARENT);
251 return '';
252 }
253 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
254 {
255 $dir = undef;
256 }
257 else
258 {
259 do
260 {
261 unless (defined ($dir = readdir(PARENT)))
262 {
263 carp "readdir($dotdots): $!";
264 closedir(PARENT);
265 return '';
266 }
267 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
268 }
269 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
270 $tst[1] != $pst[1]);
271 }
272 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
273 closedir(PARENT);
274 } while (defined $dir);
275 chop($cwd) unless $cwd eq '/'; # drop the trailing /
276 $cwd;
8b88ae92
NIS
277}
278
e4c51978
GS
279# added function alias for those of us more
280# used to the libc function. --tchrist 27-Jan-00
281*realpath = \&abs_path;
282
96e4d5b1
PP
283sub fast_abs_path {
284 my $cwd = getcwd();
3c65c14b 285 my $path = @_ ? shift : '.';
e79e61e4 286 CORE::chdir($path) || croak "Cannot chdir to $path:$!";
96e4d5b1 287 my $realpath = getcwd();
e79e61e4 288 CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
96e4d5b1 289 $realpath;
8b88ae92
NIS
290}
291
e4c51978
GS
292# added function alias to follow principle of least surprise
293# based on previous aliasing. --tchrist 27-Jan-00
294*fast_realpath = \&fast_abs_path;
295
4633a7c4
LW
296
297# --- PORTING SECTION ---
298
299# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 300# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 301# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
302# in the process logical name table as the default device and directory
303# seen by Perl. This may not be the same as the default device
4633a7c4
LW
304# and directory seen by DCL after Perl exits, since the effects
305# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
306
307sub _vms_cwd {
96e4d5b1
PP
308 return $ENV{'DEFAULT'};
309}
310
311sub _vms_abs_path {
312 return $ENV{'DEFAULT'} unless @_;
313 my $path = VMS::Filespec::pathify($_[0]);
314 croak("Invalid path name $_[0]") unless defined $path;
315 return VMS::Filespec::rmsexpand($path);
4633a7c4 316}
68dc0745 317
4633a7c4
LW
318sub _os2_cwd {
319 $ENV{'PWD'} = `cmd /c cd`;
320 chop $ENV{'PWD'};
321 $ENV{'PWD'} =~ s:\\:/:g ;
322 return $ENV{'PWD'};
323}
324
96e4d5b1 325sub _win32_cwd {
2d7a9237 326 $ENV{'PWD'} = Win32::GetCwd();
96e4d5b1
PP
327 $ENV{'PWD'} =~ s:\\:/:g ;
328 return $ENV{'PWD'};
329}
330
331*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237 332 defined &Win32::GetCwd);
96e4d5b1
PP
333
334*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745 335
39e571d4
ML
336sub _dos_cwd {
337 if (!defined &Dos::GetCwd) {
338 $ENV{'PWD'} = `command /c cd`;
339 chop $ENV{'PWD'};
340 $ENV{'PWD'} =~ s:\\:/:g ;
341 } else {
342 $ENV{'PWD'} = Dos::GetCwd();
343 }
55497cff
PP
344 return $ENV{'PWD'};
345}
346
7fbf1995
NA
347sub _qnx_cwd {
348 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
349 chop $ENV{'PWD'};
350 return $ENV{'PWD'};
351}
352
353sub _qnx_abs_path {
fa921dc6 354 my $path = @_ ? shift : '.';
7fbf1995
NA
355 my $realpath=`/usr/bin/fullpath -t $path`;
356 chop $realpath;
357 return $realpath;
358}
359
ed79a026
OF
360sub _epoc_cwd {
361 $ENV{'PWD'} = EPOC::getcwd();
362 return $ENV{'PWD'};
363}
364
ac1ad7f0 365{
db376a24 366 no warnings; # assignments trigger 'subroutine redefined' warning
4633a7c4 367
ac1ad7f0 368 if ($^O eq 'VMS') {
96e4d5b1
PP
369 *cwd = \&_vms_cwd;
370 *getcwd = \&_vms_cwd;
371 *fastcwd = \&_vms_cwd;
372 *fastgetcwd = \&_vms_cwd;
373 *abs_path = \&_vms_abs_path;
374 *fast_abs_path = \&_vms_abs_path;
ac1ad7f0
PM
375 }
376 elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
377 # We assume that &_NT_cwd is defined as an XSUB or in the core.
96e4d5b1
PP
378 *cwd = \&_NT_cwd;
379 *getcwd = \&_NT_cwd;
380 *fastcwd = \&_NT_cwd;
381 *fastgetcwd = \&_NT_cwd;
382 *abs_path = \&fast_abs_path;
ac1ad7f0
PM
383 }
384 elsif ($^O eq 'os2') {
385 # sys_cwd may keep the builtin command
96e4d5b1
PP
386 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
387 *getcwd = \&cwd;
388 *fastgetcwd = \&cwd;
389 *fastcwd = \&cwd;
390 *abs_path = \&fast_abs_path;
ac1ad7f0 391 }
39e571d4
ML
392 elsif ($^O eq 'dos') {
393 *cwd = \&_dos_cwd;
394 *getcwd = \&_dos_cwd;
395 *fastgetcwd = \&_dos_cwd;
396 *fastcwd = \&_dos_cwd;
96e4d5b1 397 *abs_path = \&fast_abs_path;
ac1ad7f0 398 }
7fbf1995
NA
399 elsif ($^O eq 'qnx') {
400 *cwd = \&_qnx_cwd;
401 *getcwd = \&_qnx_cwd;
402 *fastgetcwd = \&_qnx_cwd;
403 *fastcwd = \&_qnx_cwd;
404 *abs_path = \&_qnx_abs_path;
405 *fast_abs_path = \&_qnx_abs_path;
406 }
4fabb596 407 elsif ($^O eq 'cygwin') {
1cab015a
FE
408 *getcwd = \&cwd;
409 *fastgetcwd = \&cwd;
410 *fastcwd = \&cwd;
411 *abs_path = \&fast_abs_path;
412 }
ed79a026 413 elsif ($^O eq 'epoc') {
fa6a1c44
OF
414 *cwd = \&_epoc_cwd;
415 *getcwd = \&_epoc_cwd;
ed79a026
OF
416 *fastgetcwd = \&_epoc_cwd;
417 *fastcwd = \&_epoc_cwd;
418 *abs_path = \&fast_abs_path;
419 }
55497cff 420}
4633a7c4
LW
421
422# package main; eval join('',<DATA>) || die $@; # quick test
423
a0d0e21e
LW
4241;
425
4633a7c4
LW
426__END__
427BEGIN { import Cwd qw(:DEFAULT chdir); }
428print join("\n", cwd, getcwd, fastcwd, "");
429chdir('..');
430print join("\n", cwd, getcwd, fastcwd, "");
431print "$ENV{PWD}\n";