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