6 # Use osname for portability switches (doubled to cheaply avoid -w warning)
7 my $osname = $Config::Config{'osname'} || $Config::Config{'osname'};
12 getcwd - get pathname of current working directory
31 The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
34 The fastcwd() function looks the same as getcwd(), but runs faster.
35 It's also more dangerous because you might conceivably chdir() out of a
36 directory that you can't chdir() back into.
38 The cwd() function looks the same as getcwd and fastgetcwd but is
39 implemented using the most natural and safe form for the current
40 architecture. For most systems it is identical to `pwd` (but without
41 the trailing line terminator). It is recommended that cwd (or another
42 *cwd() function) is used in I<all> code to ensure portability.
44 If you ask to override your chdir() built-in function, then your PWD
45 environment variable will be kept up to date. (See
46 L<perlsub/Overriding builtin functions>.) Note that it will only be
47 kept up to date it all packages which use chdir import it from Cwd.
52 @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
53 @EXPORT_OK = qw(chdir);
57 sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root)
63 # Since some ports may predefine cwd internally (e.g., NT)
64 # we take care not to override an existing definition for cwd().
66 *cwd = \&_backtick_pwd unless defined &cwd;
69 # By Brandon S. Allbery
71 # Usage: $cwd = getcwd();
75 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
77 unless (@cst = stat('.'))
86 $dotdots .= '/' if $dotdots;
89 unless (opendir(PARENT, $dotdots))
91 warn "opendir($dotdots): $!";
94 unless (@cst = stat($dotdots))
96 warn "stat($dotdots): $!";
100 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
108 unless (defined ($dir = readdir(PARENT)))
110 warn "readdir($dotdots): $!";
114 unless (@tst = lstat("$dotdots/$dir"))
116 warn "lstat($dotdots/$dir): $!";
117 # Just because you can't lstat this directory
118 # doesn't mean you'll never find the right one.
123 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
129 chop($cwd); # drop the trailing /
137 # Usage: $cwd = &fastcwd;
139 # This is a faster version of getcwd. It's also more dangerous because
140 # you might chdir out of a directory that you can't chdir back into.
143 my($odev, $oino, $cdev, $cino, $tdev, $tino);
147 ($cdev, $cino) = stat('.');
150 ($odev, $oino) = ($cdev, $cino);
152 ($cdev, $cino) = stat('.');
153 last if $odev == $cdev && $oino == $cino;
156 $direntry = readdir(DIR);
157 next if $direntry eq '.';
158 next if $direntry eq '..';
160 last unless defined $direntry;
161 ($tdev, $tino) = lstat($direntry);
162 last unless $tdev != $odev || $tino != $oino;
165 unshift(@path, $direntry);
167 chdir($path = '/' . join('/', @path));
172 # Keeps track of current working directory in PWD environment var
180 if ($ENV{'PWD'} and $osname ne 'os2') {
181 my($dd,$di) = stat('.');
182 my($pd,$pi) = stat($ENV{'PWD'});
183 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
190 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
191 if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
192 my($pd,$pi) = stat($2);
193 my($dd,$di) = stat($1);
194 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
202 my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
203 $newdir =~ s|///*|/|g;
204 chdir_init() unless $chdir_init;
205 return 0 unless CORE::chdir $newdir;
206 if ($osname eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
208 if ($newdir =~ m#^/#) {
209 $ENV{'PWD'} = $newdir;
211 my @curdir = split(m#/#,$ENV{'PWD'});
212 @curdir = ('') unless @curdir;
214 foreach $component (split(m#/#, $newdir)) {
215 next if $component eq '.';
216 pop(@curdir),next if $component eq '..';
217 push(@curdir,$component);
219 $ENV{'PWD'} = join('/',@curdir) || '/';
225 # --- PORTING SECTION ---
227 # VMS: $ENV{'DEFAULT'} points to default directory at all times
228 # 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu
229 # Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
230 # causes the logical name PWD to be defined in the process
231 # logical name table as the default device and directory
232 # seen by Perl. This may not be the same as the default device
233 # and directory seen by DCL after Perl exits, since the effects
234 # the CRTL chdir() function persist only until Perl exits.
235 # This does not apply to other systems (where only chdir() sets PWD).
238 return $ENV{'DEFAULT'}
241 return $ENV{'PWD'} = $ENV{'DEFAULT'}
244 $ENV{'PWD'} = `cmd /c cd`;
246 $ENV{'PWD'} =~ s:\\:/:g ;
250 if ($osname eq 'VMS') {
253 *getcwd = \&_vms_pwd;
254 *fastcwd = \&_vms_cwd;
255 *fastgetcwd = \&_vms_cwd;
257 elsif ($osname eq 'NT') {
262 elsif ($osname eq 'os2') {
264 *getcwd = \&_os2_cwd;
265 *fastgetcwd = \&_os2_cwd;
266 *fastcwd = \&_os2_cwd;
269 # package main; eval join('',<DATA>) || die $@; # quick test
274 BEGIN { import Cwd qw(:DEFAULT chdir); }
275 print join("\n", cwd, getcwd, fastcwd, "");
277 print join("\n", cwd, getcwd, fastcwd, "");