This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid "uninitialized" warnings from POSIX::constant()
[perl5.git] / lib / Cwd.pm
CommitLineData
a0d0e21e
LW
1package Cwd;
2require 5.000;
3require Exporter;
4
f06db76b
AD
5=head1 NAME
6
7getcwd - get pathname of current working directory
8
9=head1 SYNOPSIS
10
4633a7c4
LW
11 use Cwd;
12 $dir = cwd;
13
14 use Cwd;
15 $dir = getcwd;
f06db76b
AD
16
17 use Cwd;
4633a7c4 18 $dir = fastgetcwd;
f06db76b
AD
19
20 use Cwd 'chdir';
21 chdir "/tmp";
22 print $ENV{'PWD'};
23
24=head1 DESCRIPTION
25
26The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
4633a7c4 27in Perl.
f06db76b 28
cb1a09d0 29The fastcwd() function looks the same as getcwd(), but runs faster.
f06db76b
AD
30It's also more dangerous because you might conceivably chdir() out of a
31directory that you can't chdir() back into.
32
4633a7c4
LW
33The cwd() function looks the same as getcwd and fastgetcwd but is
34implemented using the most natural and safe form for the current
35architecture. For most systems it is identical to `pwd` (but without
36the trailing line terminator). It is recommended that cwd (or another
37*cwd() function) is used in I<all> code to ensure portability.
38
39If you ask to override your chdir() built-in function, then your PWD
40environment variable will be kept up to date. (See
55497cff 41L<perlsub/Overriding Builtin Functions>.) Note that it will only be
1fef88e7 42kept up to date if all packages which use chdir import it from Cwd.
4633a7c4 43
f06db76b
AD
44=cut
45
a0d0e21e 46@ISA = qw(Exporter);
e7ae0116 47@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
a0d0e21e
LW
48@EXPORT_OK = qw(chdir);
49
4633a7c4
LW
50# use strict;
51
52sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root)
53 my $cwd;
54 chop($cwd = `pwd`);
55 $cwd;
56}
57
58# Since some ports may predefine cwd internally (e.g., NT)
59# we take care not to override an existing definition for cwd().
60
61*cwd = \&_backtick_pwd unless defined &cwd;
a0d0e21e 62
748a9306 63
a0d0e21e
LW
64# By Brandon S. Allbery
65#
66# Usage: $cwd = getcwd();
67
68sub getcwd
69{
70 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
71
72 unless (@cst = stat('.'))
73 {
74 warn "stat(.): $!";
75 return '';
76 }
77 $cwd = '';
42793c05 78 $dotdots = '';
a0d0e21e
LW
79 do
80 {
81 $dotdots .= '/' if $dotdots;
82 $dotdots .= '..';
83 @pst = @cst;
84 unless (opendir(PARENT, $dotdots))
85 {
86 warn "opendir($dotdots): $!";
87 return '';
88 }
89 unless (@cst = stat($dotdots))
90 {
91 warn "stat($dotdots): $!";
92 closedir(PARENT);
93 return '';
94 }
95 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
96 {
97 $dir = '';
98 }
99 else
100 {
101 do
102 {
3edbfbe5
TB
103 unless (defined ($dir = readdir(PARENT)))
104 {
a0d0e21e
LW
105 warn "readdir($dotdots): $!";
106 closedir(PARENT);
107 return '';
108 }
109 unless (@tst = lstat("$dotdots/$dir"))
110 {
55497cff 111 # warn "lstat($dotdots/$dir): $!";
37120919
AD
112 # Just because you can't lstat this directory
113 # doesn't mean you'll never find the right one.
114 # closedir(PARENT);
115 # return '';
a0d0e21e
LW
116 }
117 }
118 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
119 $tst[1] != $pst[1]);
120 }
121 $cwd = "$dir/$cwd";
122 closedir(PARENT);
123 } while ($dir);
f6c18ff1 124 chop($cwd) unless $cwd eq '/'; # drop the trailing /
a0d0e21e
LW
125 $cwd;
126}
127
128
129
130# By John Bazik
131#
132# Usage: $cwd = &fastcwd;
133#
134# This is a faster version of getcwd. It's also more dangerous because
135# you might chdir out of a directory that you can't chdir back into.
136
137sub fastcwd {
138 my($odev, $oino, $cdev, $cino, $tdev, $tino);
139 my(@path, $path);
140 local(*DIR);
141
142 ($cdev, $cino) = stat('.');
143 for (;;) {
40000a8c 144 my $direntry;
a0d0e21e
LW
145 ($odev, $oino) = ($cdev, $cino);
146 chdir('..');
147 ($cdev, $cino) = stat('.');
148 last if $odev == $cdev && $oino == $cino;
149 opendir(DIR, '.');
150 for (;;) {
40000a8c
AD
151 $direntry = readdir(DIR);
152 next if $direntry eq '.';
153 next if $direntry eq '..';
a0d0e21e 154
40000a8c
AD
155 last unless defined $direntry;
156 ($tdev, $tino) = lstat($direntry);
a0d0e21e
LW
157 last unless $tdev != $odev || $tino != $oino;
158 }
159 closedir(DIR);
40000a8c 160 unshift(@path, $direntry);
a0d0e21e
LW
161 }
162 chdir($path = '/' . join('/', @path));
163 $path;
164}
165
166
4633a7c4 167# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
168# Usage:
169# use Cwd 'chdir';
170# chdir $newdir;
171
4633a7c4 172my $chdir_init = 0;
a0d0e21e 173
4633a7c4 174sub chdir_init {
55497cff 175 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') {
a0d0e21e
LW
176 my($dd,$di) = stat('.');
177 my($pd,$pi) = stat($ENV{'PWD'});
178 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 179 $ENV{'PWD'} = cwd();
a0d0e21e
LW
180 }
181 }
182 else {
4633a7c4 183 $ENV{'PWD'} = cwd();
a0d0e21e 184 }
4633a7c4 185 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
a0d0e21e
LW
186 if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
187 my($pd,$pi) = stat($2);
188 my($dd,$di) = stat($1);
189 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
190 $ENV{'PWD'}="$2$3";
191 }
192 }
193 $chdir_init = 1;
194}
195
196sub chdir {
4633a7c4
LW
197 my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
198 $newdir =~ s|///*|/|g;
a0d0e21e 199 chdir_init() unless $chdir_init;
4633a7c4 200 return 0 unless CORE::chdir $newdir;
c6538b72 201 if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
748a9306 202
a0d0e21e
LW
203 if ($newdir =~ m#^/#) {
204 $ENV{'PWD'} = $newdir;
4633a7c4
LW
205 } else {
206 my @curdir = split(m#/#,$ENV{'PWD'});
207 @curdir = ('') unless @curdir;
208 my $component;
a0d0e21e
LW
209 foreach $component (split(m#/#, $newdir)) {
210 next if $component eq '.';
211 pop(@curdir),next if $component eq '..';
212 push(@curdir,$component);
213 }
214 $ENV{'PWD'} = join('/',@curdir) || '/';
215 }
4633a7c4 216 1;
a0d0e21e
LW
217}
218
4633a7c4
LW
219
220# --- PORTING SECTION ---
221
222# VMS: $ENV{'DEFAULT'} points to default directory at all times
c6538b72
PP
223# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu
224# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
225# in the process logical name table as the default device and directory
4633a7c4
LW
226# seen by Perl. This may not be the same as the default device
227# and directory seen by DCL after Perl exits, since the effects
228# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
229
230sub _vms_cwd {
231 return $ENV{'DEFAULT'}
232}
4633a7c4
LW
233sub _os2_cwd {
234 $ENV{'PWD'} = `cmd /c cd`;
235 chop $ENV{'PWD'};
236 $ENV{'PWD'} =~ s:\\:/:g ;
237 return $ENV{'PWD'};
238}
239
55497cff
PP
240sub _msdos_cwd {
241 $ENV{'PWD'} = `command /c cd`;
242 chop $ENV{'PWD'};
243 $ENV{'PWD'} =~ s:\\:/:g ;
244 return $ENV{'PWD'};
245}
246
c6538b72
PP
247my($oldw) = $^W;
248$^W = 0; # assignments trigger 'subroutine redefined' warning
249if ($^O eq 'VMS') {
4633a7c4 250
c6538b72
PP
251 *cwd = \&_vms_cwd;
252 *getcwd = \&_vms_cwd;
e7ae0116 253 *fastcwd = \&_vms_cwd;
4633a7c4
LW
254 *fastgetcwd = \&_vms_cwd;
255}
f6c18ff1 256elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
4633a7c4 257
f6c18ff1
PP
258 # We assume that &_NT_cwd is defined as an XSUB or in the core.
259 *getcwd = \&_NT_cwd;
260 *fastcwd = \&_NT_cwd;
261 *fastgetcwd = \&_NT_cwd;
4633a7c4 262}
c6538b72 263elsif ($^O eq 'os2') {
5ce853d7
IZ
264 # sys_cwd may keep the builtin command
265 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
266 *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
267 *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
268 *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
55497cff
PP
269}
270elsif ($^O eq 'msdos') {
271 *cwd = \&_msdos_cwd;
272 *getcwd = \&_msdos_cwd;
273 *fastgetcwd = \&_msdos_cwd;
274 *fastcwd = \&_msdos_cwd;
275}
c6538b72 276$^W = $oldw;
4633a7c4
LW
277
278# package main; eval join('',<DATA>) || die $@; # quick test
279
a0d0e21e
LW
2801;
281
4633a7c4
LW
282__END__
283BEGIN { import Cwd qw(:DEFAULT chdir); }
284print join("\n", cwd, getcwd, fastcwd, "");
285chdir('..');
286print join("\n", cwd, getcwd, fastcwd, "");
287print "$ENV{PWD}\n";