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