This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
added patch to fix Cwd.pm warnings, fixed a couple more places
[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
20408e3c
GS
23 use Cwd 'abs_path';
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
GS
34The abs_path() function takes a single argument and returns the
35absolute pathname for that argument. It uses the same algoritm as
36getcwd(). (actually getcwd() is abs_path("."))
37
cb1a09d0 38The fastcwd() function looks the same as getcwd(), but runs faster.
fb73857a
PP
39It's also more dangerous because it might conceivably chdir() you out
40of a directory that it can't chdir() you back into. If fastcwd
41encounters a problem it will return undef but will probably leave you
42in a different directory. For a measure of extra security, if
43everything appears to have worked, the fastcwd() function will check
44that it leaves you in the same directory that it started in. If it has
45changed it will C<die> with the message "Unstable directory path,
46current directory changed unexpectedly". That should never happen.
f06db76b 47
20408e3c
GS
48The fast_abs_path() function looks the same as abs_path(), but runs faster.
49And like fastcwd() is more dangerous.
50
4633a7c4
LW
51The cwd() function looks the same as getcwd and fastgetcwd but is
52implemented using the most natural and safe form for the current
53architecture. For most systems it is identical to `pwd` (but without
fb73857a
PP
54the trailing line terminator).
55
56It is recommended that cwd (or another *cwd() function) is used in
57I<all> code to ensure portability.
4633a7c4
LW
58
59If you ask to override your chdir() built-in function, then your PWD
60environment variable will be kept up to date. (See
55497cff 61L<perlsub/Overriding Builtin Functions>.) Note that it will only be
1fef88e7 62kept up to date if all packages which use chdir import it from Cwd.
4633a7c4 63
f06db76b
AD
64=cut
65
96e4d5b1
PP
66## use strict;
67
68use Carp;
69
07569ed3 70$VERSION = '2.01';
96e4d5b1
PP
71
72require Exporter;
a0d0e21e 73@ISA = qw(Exporter);
e7ae0116 74@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
96e4d5b1 75@EXPORT_OK = qw(chdir abs_path fast_abs_path);
a0d0e21e 76
4633a7c4 77
8b88ae92 78# The 'natural and safe form' for UNIX (pwd may be setuid root)
96e4d5b1 79
8b88ae92 80sub _backtick_pwd {
4633a7c4
LW
81 my $cwd;
82 chop($cwd = `pwd`);
83 $cwd;
8b88ae92 84}
4633a7c4
LW
85
86# Since some ports may predefine cwd internally (e.g., NT)
87# we take care not to override an existing definition for cwd().
88
89*cwd = \&_backtick_pwd unless defined &cwd;
a0d0e21e 90
748a9306 91
a0d0e21e
LW
92# By Brandon S. Allbery
93#
94# Usage: $cwd = getcwd();
95
96sub getcwd
97{
07569ed3 98 abs_path('.');
a0d0e21e
LW
99}
100
a0d0e21e
LW
101# By John Bazik
102#
103# Usage: $cwd = &fastcwd;
104#
105# This is a faster version of getcwd. It's also more dangerous because
106# you might chdir out of a directory that you can't chdir back into.
fb73857a
PP
107
108# List of metachars taken from do_exec() in doio.c
109my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n");
a0d0e21e
LW
110
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
PP
138 $path = '/' . join('/', @path);
139 # At this point $path may be tainted (if tainting) and chdir would fail.
140 # To be more useful we untaint it then check that we landed where we started.
141 $path = $1 if $path =~ /^(.*)$/; # untaint
e79e61e4 142 CORE::chdir($path) || return undef;
fb73857a
PP
143 ($cdev, $cino) = stat('.');
144 die "Unstable directory path, current directory changed unexpectedly"
145 if $cdev != $orig_cdev || $cino != $orig_cino;
a0d0e21e
LW
146 $path;
147}
148
149
4633a7c4 150# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
151# Usage:
152# use Cwd 'chdir';
153# chdir $newdir;
154
4633a7c4 155my $chdir_init = 0;
a0d0e21e 156
4633a7c4 157sub chdir_init {
39e571d4 158 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') {
a0d0e21e
LW
159 my($dd,$di) = stat('.');
160 my($pd,$pi) = stat($ENV{'PWD'});
161 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 162 $ENV{'PWD'} = cwd();
a0d0e21e
LW
163 }
164 }
165 else {
4633a7c4 166 $ENV{'PWD'} = cwd();
a0d0e21e 167 }
4633a7c4 168 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
a0d0e21e
LW
169 if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
170 my($pd,$pi) = stat($2);
171 my($dd,$di) = stat($1);
172 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
173 $ENV{'PWD'}="$2$3";
174 }
175 }
176 $chdir_init = 1;
177}
178
179sub chdir {
4633a7c4
LW
180 my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
181 $newdir =~ s|///*|/|g;
a0d0e21e 182 chdir_init() unless $chdir_init;
4633a7c4 183 return 0 unless CORE::chdir $newdir;
c6538b72 184 if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
748a9306 185
a0d0e21e
LW
186 if ($newdir =~ m#^/#) {
187 $ENV{'PWD'} = $newdir;
4633a7c4
LW
188 } else {
189 my @curdir = split(m#/#,$ENV{'PWD'});
190 @curdir = ('') unless @curdir;
191 my $component;
a0d0e21e
LW
192 foreach $component (split(m#/#, $newdir)) {
193 next if $component eq '.';
194 pop(@curdir),next if $component eq '..';
195 push(@curdir,$component);
196 }
197 $ENV{'PWD'} = join('/',@curdir) || '/';
198 }
4633a7c4 199 1;
a0d0e21e
LW
200}
201
8b88ae92
NIS
202# Taken from Cwd.pm It is really getcwd with an optional
203# parameter instead of '.'
204#
205
206sub abs_path
207{
07569ed3 208 my $start = @_ ? shift : '.';
8b88ae92
NIS
209 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
210
211 unless (@cst = stat( $start ))
212 {
213 carp "stat($start): $!";
214 return '';
215 }
216 $cwd = '';
217 $dotdots = $start;
218 do
219 {
220 $dotdots .= '/..';
221 @pst = @cst;
222 unless (opendir(PARENT, $dotdots))
223 {
224 carp "opendir($dotdots): $!";
225 return '';
226 }
227 unless (@cst = stat($dotdots))
228 {
229 carp "stat($dotdots): $!";
230 closedir(PARENT);
231 return '';
232 }
233 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
234 {
07569ed3 235 $dir = undef;
8b88ae92
NIS
236 }
237 else
238 {
239 do
240 {
241 unless (defined ($dir = readdir(PARENT)))
242 {
243 carp "readdir($dotdots): $!";
244 closedir(PARENT);
245 return '';
246 }
247 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
248 }
249 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
250 $tst[1] != $pst[1]);
251 }
07569ed3 252 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
8b88ae92 253 closedir(PARENT);
07569ed3
GB
254 } while (defined $dir);
255 chop($cwd) unless $cwd eq '/'; # drop the trailing /
8b88ae92
NIS
256 $cwd;
257}
258
96e4d5b1
PP
259sub fast_abs_path {
260 my $cwd = getcwd();
261 my $path = shift || '.';
e79e61e4 262 CORE::chdir($path) || croak "Cannot chdir to $path:$!";
96e4d5b1 263 my $realpath = getcwd();
e79e61e4 264 CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
96e4d5b1 265 $realpath;
8b88ae92
NIS
266}
267
4633a7c4
LW
268
269# --- PORTING SECTION ---
270
271# VMS: $ENV{'DEFAULT'} points to default directory at all times
c6538b72
PP
272# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu
273# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
274# in the process logical name table as the default device and directory
275# seen by Perl. This may not be the same as the default device
4633a7c4
LW
276# and directory seen by DCL after Perl exits, since the effects
277# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
278
279sub _vms_cwd {
96e4d5b1
PP
280 return $ENV{'DEFAULT'};
281}
282
283sub _vms_abs_path {
284 return $ENV{'DEFAULT'} unless @_;
285 my $path = VMS::Filespec::pathify($_[0]);
286 croak("Invalid path name $_[0]") unless defined $path;
287 return VMS::Filespec::rmsexpand($path);
4633a7c4 288}
68dc0745 289
4633a7c4
LW
290sub _os2_cwd {
291 $ENV{'PWD'} = `cmd /c cd`;
292 chop $ENV{'PWD'};
293 $ENV{'PWD'} =~ s:\\:/:g ;
294 return $ENV{'PWD'};
295}
296
96e4d5b1 297sub _win32_cwd {
2d7a9237 298 $ENV{'PWD'} = Win32::GetCwd();
96e4d5b1
PP
299 $ENV{'PWD'} =~ s:\\:/:g ;
300 return $ENV{'PWD'};
301}
302
303*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237 304 defined &Win32::GetCwd);
96e4d5b1
PP
305
306*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745 307
39e571d4
ML
308sub _dos_cwd {
309 if (!defined &Dos::GetCwd) {
310 $ENV{'PWD'} = `command /c cd`;
311 chop $ENV{'PWD'};
312 $ENV{'PWD'} =~ s:\\:/:g ;
313 } else {
314 $ENV{'PWD'} = Dos::GetCwd();
315 }
55497cff
PP
316 return $ENV{'PWD'};
317}
318
7fbf1995
NA
319sub _qnx_cwd {
320 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
321 chop $ENV{'PWD'};
322 return $ENV{'PWD'};
323}
324
325sub _qnx_abs_path {
326 my $path = shift || '.';
327 my $realpath=`/usr/bin/fullpath -t $path`;
328 chop $realpath;
329 return $realpath;
330}
331
ac1ad7f0
PM
332{
333 local $^W = 0; # assignments trigger 'subroutine redefined' warning
4633a7c4 334
ac1ad7f0 335 if ($^O eq 'VMS') {
96e4d5b1
PP
336 *cwd = \&_vms_cwd;
337 *getcwd = \&_vms_cwd;
338 *fastcwd = \&_vms_cwd;
339 *fastgetcwd = \&_vms_cwd;
340 *abs_path = \&_vms_abs_path;
341 *fast_abs_path = \&_vms_abs_path;
ac1ad7f0
PM
342 }
343 elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
344 # We assume that &_NT_cwd is defined as an XSUB or in the core.
96e4d5b1
PP
345 *cwd = \&_NT_cwd;
346 *getcwd = \&_NT_cwd;
347 *fastcwd = \&_NT_cwd;
348 *fastgetcwd = \&_NT_cwd;
349 *abs_path = \&fast_abs_path;
ac1ad7f0
PM
350 }
351 elsif ($^O eq 'os2') {
352 # sys_cwd may keep the builtin command
96e4d5b1
PP
353 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
354 *getcwd = \&cwd;
355 *fastgetcwd = \&cwd;
356 *fastcwd = \&cwd;
357 *abs_path = \&fast_abs_path;
ac1ad7f0 358 }
39e571d4
ML
359 elsif ($^O eq 'dos') {
360 *cwd = \&_dos_cwd;
361 *getcwd = \&_dos_cwd;
362 *fastgetcwd = \&_dos_cwd;
363 *fastcwd = \&_dos_cwd;
96e4d5b1 364 *abs_path = \&fast_abs_path;
ac1ad7f0 365 }
7fbf1995
NA
366 elsif ($^O eq 'qnx') {
367 *cwd = \&_qnx_cwd;
368 *getcwd = \&_qnx_cwd;
369 *fastgetcwd = \&_qnx_cwd;
370 *fastcwd = \&_qnx_cwd;
371 *abs_path = \&_qnx_abs_path;
372 *fast_abs_path = \&_qnx_abs_path;
373 }
55497cff 374}
4633a7c4
LW
375
376# package main; eval join('',<DATA>) || die $@; # quick test
377
a0d0e21e
LW
3781;
379
4633a7c4
LW
380__END__
381BEGIN { import Cwd qw(:DEFAULT chdir); }
382print join("\n", cwd, getcwd, fastcwd, "");
383chdir('..');
384print join("\n", cwd, getcwd, fastcwd, "");
385print "$ENV{PWD}\n";