This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Plug the security hole described in the Aug 05 2000 bugtraq message
[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
96e4d5b1
PP
69## use strict;
70
71use Carp;
72
929327b2 73$VERSION = '2.03';
96e4d5b1
PP
74
75require Exporter;
a0d0e21e 76@ISA = qw(Exporter);
e7ae0116 77@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
e4c51978 78@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
a0d0e21e 79
4633a7c4 80
8b88ae92 81# The 'natural and safe form' for UNIX (pwd may be setuid root)
96e4d5b1 82
8b88ae92 83sub _backtick_pwd {
4633a7c4
LW
84 my $cwd;
85 chop($cwd = `pwd`);
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 {
39e571d4 159 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') {
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 {
4633a7c4 167 $ENV{'PWD'} = cwd();
a0d0e21e 168 }
4633a7c4 169 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
392d8ab8 170 if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
171 my($pd,$pi) = stat($2);
172 my($dd,$di) = stat($1);
173 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
174 $ENV{'PWD'}="$2$3";
175 }
176 }
177 $chdir_init = 1;
178}
179
180sub chdir {
4633a7c4
LW
181 my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
182 $newdir =~ s|///*|/|g;
a0d0e21e 183 chdir_init() unless $chdir_init;
4633a7c4 184 return 0 unless CORE::chdir $newdir;
c6538b72 185 if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
748a9306 186
392d8ab8 187 if ($newdir =~ m#^/#s) {
a0d0e21e 188 $ENV{'PWD'} = $newdir;
4633a7c4
LW
189 } else {
190 my @curdir = split(m#/#,$ENV{'PWD'});
191 @curdir = ('') unless @curdir;
192 my $component;
a0d0e21e
LW
193 foreach $component (split(m#/#, $newdir)) {
194 next if $component eq '.';
195 pop(@curdir),next if $component eq '..';
196 push(@curdir,$component);
197 }
198 $ENV{'PWD'} = join('/',@curdir) || '/';
199 }
4633a7c4 200 1;
a0d0e21e
LW
201}
202
8b88ae92 203
929327b2
JP
204# By Jeff "japhy" Pinyan (07/23/2000)
205# usage: abs_path(PATHNAME)
206# see the docs
207
208sub abs_path {
209 my $base = @_ ? $_[0] : ".";
210 my $path = "";
211 my $file;
212
213 do {
214 my @devino = (stat($base))[0,1] or
215 carp("stat($base): $!"), return;
8b88ae92 216
929327b2
JP
217 $base .= "/..";
218
219 opendir PREV, $base or carp("opendir($base): $!"), return;
220 while (defined($file = readdir PREV)) {
221 next if $file eq "." or $file eq "..";
222 my @entry = (lstat("$base/$file"))[0,1] or
223 carp("lstat($base/$file): $!"), return;
224 last if $devino[0] == $entry[0] and $devino[1] == $entry[1];
8b88ae92 225 }
929327b2
JP
226 closedir PREV;
227
228 $path = (defined $file and $file) . "/$path";
229 } while defined $file;
230
231 length($path) > 1 and chop $path;
232 return $path;
8b88ae92
NIS
233}
234
929327b2 235
e4c51978
GS
236# added function alias for those of us more
237# used to the libc function. --tchrist 27-Jan-00
238*realpath = \&abs_path;
239
96e4d5b1
PP
240sub fast_abs_path {
241 my $cwd = getcwd();
242 my $path = shift || '.';
e79e61e4 243 CORE::chdir($path) || croak "Cannot chdir to $path:$!";
96e4d5b1 244 my $realpath = getcwd();
e79e61e4 245 CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
96e4d5b1 246 $realpath;
8b88ae92
NIS
247}
248
e4c51978
GS
249# added function alias to follow principle of least surprise
250# based on previous aliasing. --tchrist 27-Jan-00
251*fast_realpath = \&fast_abs_path;
252
4633a7c4
LW
253
254# --- PORTING SECTION ---
255
256# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 257# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 258# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
259# in the process logical name table as the default device and directory
260# seen by Perl. This may not be the same as the default device
4633a7c4
LW
261# and directory seen by DCL after Perl exits, since the effects
262# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
263
264sub _vms_cwd {
96e4d5b1
PP
265 return $ENV{'DEFAULT'};
266}
267
268sub _vms_abs_path {
269 return $ENV{'DEFAULT'} unless @_;
270 my $path = VMS::Filespec::pathify($_[0]);
271 croak("Invalid path name $_[0]") unless defined $path;
272 return VMS::Filespec::rmsexpand($path);
4633a7c4 273}
68dc0745 274
4633a7c4
LW
275sub _os2_cwd {
276 $ENV{'PWD'} = `cmd /c cd`;
277 chop $ENV{'PWD'};
278 $ENV{'PWD'} =~ s:\\:/:g ;
279 return $ENV{'PWD'};
280}
281
96e4d5b1 282sub _win32_cwd {
2d7a9237 283 $ENV{'PWD'} = Win32::GetCwd();
96e4d5b1
PP
284 $ENV{'PWD'} =~ s:\\:/:g ;
285 return $ENV{'PWD'};
286}
287
288*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237 289 defined &Win32::GetCwd);
96e4d5b1
PP
290
291*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745 292
39e571d4
ML
293sub _dos_cwd {
294 if (!defined &Dos::GetCwd) {
295 $ENV{'PWD'} = `command /c cd`;
296 chop $ENV{'PWD'};
297 $ENV{'PWD'} =~ s:\\:/:g ;
298 } else {
299 $ENV{'PWD'} = Dos::GetCwd();
300 }
55497cff
PP
301 return $ENV{'PWD'};
302}
303
7fbf1995
NA
304sub _qnx_cwd {
305 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
306 chop $ENV{'PWD'};
307 return $ENV{'PWD'};
308}
309
310sub _qnx_abs_path {
311 my $path = shift || '.';
312 my $realpath=`/usr/bin/fullpath -t $path`;
313 chop $realpath;
314 return $realpath;
315}
316
ac1ad7f0 317{
db376a24 318 no warnings; # assignments trigger 'subroutine redefined' warning
4633a7c4 319
ac1ad7f0 320 if ($^O eq 'VMS') {
96e4d5b1
PP
321 *cwd = \&_vms_cwd;
322 *getcwd = \&_vms_cwd;
323 *fastcwd = \&_vms_cwd;
324 *fastgetcwd = \&_vms_cwd;
325 *abs_path = \&_vms_abs_path;
326 *fast_abs_path = \&_vms_abs_path;
ac1ad7f0
PM
327 }
328 elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
329 # We assume that &_NT_cwd is defined as an XSUB or in the core.
96e4d5b1
PP
330 *cwd = \&_NT_cwd;
331 *getcwd = \&_NT_cwd;
332 *fastcwd = \&_NT_cwd;
333 *fastgetcwd = \&_NT_cwd;
334 *abs_path = \&fast_abs_path;
ac1ad7f0
PM
335 }
336 elsif ($^O eq 'os2') {
337 # sys_cwd may keep the builtin command
96e4d5b1
PP
338 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
339 *getcwd = \&cwd;
340 *fastgetcwd = \&cwd;
341 *fastcwd = \&cwd;
342 *abs_path = \&fast_abs_path;
ac1ad7f0 343 }
39e571d4
ML
344 elsif ($^O eq 'dos') {
345 *cwd = \&_dos_cwd;
346 *getcwd = \&_dos_cwd;
347 *fastgetcwd = \&_dos_cwd;
348 *fastcwd = \&_dos_cwd;
96e4d5b1 349 *abs_path = \&fast_abs_path;
ac1ad7f0 350 }
7fbf1995
NA
351 elsif ($^O eq 'qnx') {
352 *cwd = \&_qnx_cwd;
353 *getcwd = \&_qnx_cwd;
354 *fastgetcwd = \&_qnx_cwd;
355 *fastcwd = \&_qnx_cwd;
356 *abs_path = \&_qnx_abs_path;
357 *fast_abs_path = \&_qnx_abs_path;
358 }
4fabb596 359 elsif ($^O eq 'cygwin') {
1cab015a
FE
360 *getcwd = \&cwd;
361 *fastgetcwd = \&cwd;
362 *fastcwd = \&cwd;
363 *abs_path = \&fast_abs_path;
364 }
55497cff 365}
4633a7c4
LW
366
367# package main; eval join('',<DATA>) || die $@; # quick test
368
a0d0e21e
LW
3691;
370
4633a7c4
LW
371__END__
372BEGIN { import Cwd qw(:DEFAULT chdir); }
373print join("\n", cwd, getcwd, fastcwd, "");
374chdir('..');
375print join("\n", cwd, getcwd, fastcwd, "");
376print "$ENV{PWD}\n";