This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Regen headers.
[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
b060a406 73our $VERSION = '2.03';
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
92*cwd = \&_backtick_pwd unless defined &cwd;
a0d0e21e 93
748a9306 94
a0d0e21e
LW
95# By Brandon S. Allbery
96#
97# Usage: $cwd = getcwd();
98
99sub getcwd
100{
07569ed3 101 abs_path('.');
a0d0e21e
LW
102}
103
a0d0e21e
LW
104# By John Bazik
105#
106# Usage: $cwd = &fastcwd;
107#
108# This is a faster version of getcwd. It's also more dangerous because
109# you might chdir out of a directory that you can't chdir back into.
fb73857a 110
a0d0e21e
LW
111sub fastcwd {
112 my($odev, $oino, $cdev, $cino, $tdev, $tino);
113 my(@path, $path);
114 local(*DIR);
115
fb73857a
PP
116 my($orig_cdev, $orig_cino) = stat('.');
117 ($cdev, $cino) = ($orig_cdev, $orig_cino);
a0d0e21e 118 for (;;) {
40000a8c 119 my $direntry;
a0d0e21e 120 ($odev, $oino) = ($cdev, $cino);
e79e61e4 121 CORE::chdir('..') || return undef;
a0d0e21e
LW
122 ($cdev, $cino) = stat('.');
123 last if $odev == $cdev && $oino == $cino;
fb73857a 124 opendir(DIR, '.') || return undef;
a0d0e21e 125 for (;;) {
40000a8c 126 $direntry = readdir(DIR);
fb73857a 127 last unless defined $direntry;
40000a8c
AD
128 next if $direntry eq '.';
129 next if $direntry eq '..';
a0d0e21e 130
40000a8c 131 ($tdev, $tino) = lstat($direntry);
a0d0e21e
LW
132 last unless $tdev != $odev || $tino != $oino;
133 }
134 closedir(DIR);
fb73857a 135 return undef unless defined $direntry; # should never happen
40000a8c 136 unshift(@path, $direntry);
a0d0e21e 137 }
fb73857a 138 $path = '/' . join('/', @path);
21ac5ced 139 if ($^O eq 'apollo') { $path = "/".$path; }
fb73857a
PP
140 # At this point $path may be tainted (if tainting) and chdir would fail.
141 # To be more useful we untaint it then check that we landed where we started.
392d8ab8 142 $path = $1 if $path =~ /^(.*)\z/s; # untaint
e79e61e4 143 CORE::chdir($path) || return undef;
fb73857a
PP
144 ($cdev, $cino) = stat('.');
145 die "Unstable directory path, current directory changed unexpectedly"
146 if $cdev != $orig_cdev || $cino != $orig_cino;
a0d0e21e
LW
147 $path;
148}
149
150
4633a7c4 151# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
152# Usage:
153# use Cwd 'chdir';
154# chdir $newdir;
155
4633a7c4 156my $chdir_init = 0;
a0d0e21e 157
4633a7c4 158sub chdir_init {
3b8e3443 159 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
160 my($dd,$di) = stat('.');
161 my($pd,$pi) = stat($ENV{'PWD'});
162 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 163 $ENV{'PWD'} = cwd();
a0d0e21e
LW
164 }
165 }
166 else {
3b8e3443
GS
167 my $wd = cwd();
168 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
169 $ENV{'PWD'} = $wd;
a0d0e21e 170 }
4633a7c4 171 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 172 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
173 my($pd,$pi) = stat($2);
174 my($dd,$di) = stat($1);
175 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
176 $ENV{'PWD'}="$2$3";
177 }
178 }
179 $chdir_init = 1;
180}
181
182sub chdir {
3c65c14b 183 my $newdir = @? ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 184 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 185 chdir_init() unless $chdir_init;
4633a7c4 186 return 0 unless CORE::chdir $newdir;
3b8e3443
GS
187 if ($^O eq 'VMS') {
188 return $ENV{'PWD'} = $ENV{'DEFAULT'}
189 }
190 elsif ($^O eq 'MSWin32') {
191 $ENV{'PWD'} = Win32::GetFullPathName($newdir);
192 return 1;
193 }
748a9306 194
392d8ab8 195 if ($newdir =~ m#^/#s) {
a0d0e21e 196 $ENV{'PWD'} = $newdir;
4633a7c4
LW
197 } else {
198 my @curdir = split(m#/#,$ENV{'PWD'});
199 @curdir = ('') unless @curdir;
200 my $component;
a0d0e21e
LW
201 foreach $component (split(m#/#, $newdir)) {
202 next if $component eq '.';
203 pop(@curdir),next if $component eq '..';
204 push(@curdir,$component);
205 }
206 $ENV{'PWD'} = join('/',@curdir) || '/';
207 }
4633a7c4 208 1;
a0d0e21e
LW
209}
210
d57281c6
JH
211# Taken from Cwd.pm It is really getcwd with an optional
212# parameter instead of '.'
213#
8b88ae92 214
d57281c6
JH
215sub abs_path
216{
217 my $start = @_ ? shift : '.';
218 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
929327b2 219
d57281c6
JH
220 unless (@cst = stat( $start ))
221 {
222 carp "stat($start): $!";
223 return '';
8b88ae92 224 }
d57281c6
JH
225 $cwd = '';
226 $dotdots = $start;
227 do
228 {
229 $dotdots .= '/..';
230 @pst = @cst;
231 unless (opendir(PARENT, $dotdots))
232 {
233 carp "opendir($dotdots): $!";
234 return '';
235 }
236 unless (@cst = stat($dotdots))
237 {
238 carp "stat($dotdots): $!";
239 closedir(PARENT);
240 return '';
241 }
242 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
243 {
244 $dir = undef;
245 }
246 else
247 {
248 do
249 {
250 unless (defined ($dir = readdir(PARENT)))
251 {
252 carp "readdir($dotdots): $!";
253 closedir(PARENT);
254 return '';
255 }
256 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
257 }
258 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
259 $tst[1] != $pst[1]);
260 }
261 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
262 closedir(PARENT);
263 } while (defined $dir);
264 chop($cwd) unless $cwd eq '/'; # drop the trailing /
265 $cwd;
8b88ae92
NIS
266}
267
e4c51978
GS
268# added function alias for those of us more
269# used to the libc function. --tchrist 27-Jan-00
270*realpath = \&abs_path;
271
96e4d5b1
PP
272sub fast_abs_path {
273 my $cwd = getcwd();
3c65c14b 274 my $path = @_ ? shift : '.';
e79e61e4 275 CORE::chdir($path) || croak "Cannot chdir to $path:$!";
96e4d5b1 276 my $realpath = getcwd();
e79e61e4 277 CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
96e4d5b1 278 $realpath;
8b88ae92
NIS
279}
280
e4c51978
GS
281# added function alias to follow principle of least surprise
282# based on previous aliasing. --tchrist 27-Jan-00
283*fast_realpath = \&fast_abs_path;
284
4633a7c4
LW
285
286# --- PORTING SECTION ---
287
288# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 289# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 290# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
291# in the process logical name table as the default device and directory
292# seen by Perl. This may not be the same as the default device
4633a7c4
LW
293# and directory seen by DCL after Perl exits, since the effects
294# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
295
296sub _vms_cwd {
96e4d5b1
PP
297 return $ENV{'DEFAULT'};
298}
299
300sub _vms_abs_path {
301 return $ENV{'DEFAULT'} unless @_;
302 my $path = VMS::Filespec::pathify($_[0]);
303 croak("Invalid path name $_[0]") unless defined $path;
304 return VMS::Filespec::rmsexpand($path);
4633a7c4 305}
68dc0745 306
4633a7c4
LW
307sub _os2_cwd {
308 $ENV{'PWD'} = `cmd /c cd`;
309 chop $ENV{'PWD'};
310 $ENV{'PWD'} =~ s:\\:/:g ;
311 return $ENV{'PWD'};
312}
313
96e4d5b1 314sub _win32_cwd {
2d7a9237 315 $ENV{'PWD'} = Win32::GetCwd();
96e4d5b1
PP
316 $ENV{'PWD'} =~ s:\\:/:g ;
317 return $ENV{'PWD'};
318}
319
320*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237 321 defined &Win32::GetCwd);
96e4d5b1
PP
322
323*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745 324
39e571d4
ML
325sub _dos_cwd {
326 if (!defined &Dos::GetCwd) {
327 $ENV{'PWD'} = `command /c cd`;
328 chop $ENV{'PWD'};
329 $ENV{'PWD'} =~ s:\\:/:g ;
330 } else {
331 $ENV{'PWD'} = Dos::GetCwd();
332 }
55497cff
PP
333 return $ENV{'PWD'};
334}
335
7fbf1995
NA
336sub _qnx_cwd {
337 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
338 chop $ENV{'PWD'};
339 return $ENV{'PWD'};
340}
341
342sub _qnx_abs_path {
fa921dc6 343 my $path = @_ ? shift : '.';
7fbf1995
NA
344 my $realpath=`/usr/bin/fullpath -t $path`;
345 chop $realpath;
346 return $realpath;
347}
348
ac1ad7f0 349{
db376a24 350 no warnings; # assignments trigger 'subroutine redefined' warning
4633a7c4 351
ac1ad7f0 352 if ($^O eq 'VMS') {
96e4d5b1
PP
353 *cwd = \&_vms_cwd;
354 *getcwd = \&_vms_cwd;
355 *fastcwd = \&_vms_cwd;
356 *fastgetcwd = \&_vms_cwd;
357 *abs_path = \&_vms_abs_path;
358 *fast_abs_path = \&_vms_abs_path;
ac1ad7f0
PM
359 }
360 elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
361 # We assume that &_NT_cwd is defined as an XSUB or in the core.
96e4d5b1
PP
362 *cwd = \&_NT_cwd;
363 *getcwd = \&_NT_cwd;
364 *fastcwd = \&_NT_cwd;
365 *fastgetcwd = \&_NT_cwd;
366 *abs_path = \&fast_abs_path;
ac1ad7f0
PM
367 }
368 elsif ($^O eq 'os2') {
369 # sys_cwd may keep the builtin command
96e4d5b1
PP
370 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
371 *getcwd = \&cwd;
372 *fastgetcwd = \&cwd;
373 *fastcwd = \&cwd;
374 *abs_path = \&fast_abs_path;
ac1ad7f0 375 }
39e571d4
ML
376 elsif ($^O eq 'dos') {
377 *cwd = \&_dos_cwd;
378 *getcwd = \&_dos_cwd;
379 *fastgetcwd = \&_dos_cwd;
380 *fastcwd = \&_dos_cwd;
96e4d5b1 381 *abs_path = \&fast_abs_path;
ac1ad7f0 382 }
7fbf1995
NA
383 elsif ($^O eq 'qnx') {
384 *cwd = \&_qnx_cwd;
385 *getcwd = \&_qnx_cwd;
386 *fastgetcwd = \&_qnx_cwd;
387 *fastcwd = \&_qnx_cwd;
388 *abs_path = \&_qnx_abs_path;
389 *fast_abs_path = \&_qnx_abs_path;
390 }
4fabb596 391 elsif ($^O eq 'cygwin') {
1cab015a
FE
392 *getcwd = \&cwd;
393 *fastgetcwd = \&cwd;
394 *fastcwd = \&cwd;
395 *abs_path = \&fast_abs_path;
396 }
55497cff 397}
4633a7c4
LW
398
399# package main; eval join('',<DATA>) || die $@; # quick test
400
a0d0e21e
LW
4011;
402
4633a7c4
LW
403__END__
404BEGIN { import Cwd qw(:DEFAULT chdir); }
405print join("\n", cwd, getcwd, fastcwd, "");
406chdir('..');
407print join("\n", cwd, getcwd, fastcwd, "");
408print "$ENV{PWD}\n";