This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
This is my patch patch.1n for perl5.001.
[perl5.git] / lib / Cwd.pm
CommitLineData
a0d0e21e
LW
1package Cwd;
2require 5.000;
3require Exporter;
748a9306 4use Config;
a0d0e21e 5
f06db76b
AD
6=head1 NAME
7
8getcwd - get pathname of current working directory
9
10=head1 SYNOPSIS
11
12 require Cwd;
13 $dir = Cwd::getcwd();
14
15 use Cwd;
16 $dir = getcwd();
17
18 use Cwd 'chdir';
19 chdir "/tmp";
20 print $ENV{'PWD'};
21
22=head1 DESCRIPTION
23
24The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
25in Perl. If you ask to override your chdir() built-in function, then your
26PWD environment variable will be kept up to date. (See
27L<perlsub/Overriding builtin functions>.)
28
29The fastgetcwd() function looks the same as getcwd(), but runs faster.
30It's also more dangerous because you might conceivably chdir() out of a
31directory that you can't chdir() back into.
32
33=cut
34
a0d0e21e
LW
35@ISA = qw(Exporter);
36@EXPORT = qw(getcwd fastcwd);
37@EXPORT_OK = qw(chdir);
38
39
748a9306
LW
40# VMS: $ENV{'DEFAULT'} points to default directory at all times
41# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu
42# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
43# causes the logical name PWD to be defined in the process
44# logical name table as the default device and directory
45# seen by Perl. This may not be the same as the default device
46# and directory seen by DCL after Perl exits, since the effects
47# the CRTL chdir() function persist only until Perl exits.
48
a0d0e21e
LW
49# By Brandon S. Allbery
50#
51# Usage: $cwd = getcwd();
52
53sub getcwd
54{
748a9306
LW
55 if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
56
a0d0e21e
LW
57 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
58
59 unless (@cst = stat('.'))
60 {
61 warn "stat(.): $!";
62 return '';
63 }
64 $cwd = '';
42793c05 65 $dotdots = '';
a0d0e21e
LW
66 do
67 {
68 $dotdots .= '/' if $dotdots;
69 $dotdots .= '..';
70 @pst = @cst;
71 unless (opendir(PARENT, $dotdots))
72 {
73 warn "opendir($dotdots): $!";
74 return '';
75 }
76 unless (@cst = stat($dotdots))
77 {
78 warn "stat($dotdots): $!";
79 closedir(PARENT);
80 return '';
81 }
82 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
83 {
84 $dir = '';
85 }
86 else
87 {
88 do
89 {
3edbfbe5
TB
90 unless (defined ($dir = readdir(PARENT)))
91 {
a0d0e21e
LW
92 warn "readdir($dotdots): $!";
93 closedir(PARENT);
94 return '';
95 }
96 unless (@tst = lstat("$dotdots/$dir"))
97 {
98 warn "lstat($dotdots/$dir): $!";
99 closedir(PARENT);
100 return '';
101 }
102 }
103 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
104 $tst[1] != $pst[1]);
105 }
106 $cwd = "$dir/$cwd";
107 closedir(PARENT);
108 } while ($dir);
3edbfbe5 109 chop($cwd); # drop the trailing /
a0d0e21e
LW
110 $cwd;
111}
112
113
114
115# By John Bazik
116#
117# Usage: $cwd = &fastcwd;
118#
119# This is a faster version of getcwd. It's also more dangerous because
120# you might chdir out of a directory that you can't chdir back into.
121
122sub fastcwd {
748a9306
LW
123 if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} }
124
a0d0e21e
LW
125 my($odev, $oino, $cdev, $cino, $tdev, $tino);
126 my(@path, $path);
127 local(*DIR);
128
129 ($cdev, $cino) = stat('.');
130 for (;;) {
40000a8c 131 my $direntry;
a0d0e21e
LW
132 ($odev, $oino) = ($cdev, $cino);
133 chdir('..');
134 ($cdev, $cino) = stat('.');
135 last if $odev == $cdev && $oino == $cino;
136 opendir(DIR, '.');
137 for (;;) {
40000a8c
AD
138 $direntry = readdir(DIR);
139 next if $direntry eq '.';
140 next if $direntry eq '..';
a0d0e21e 141
40000a8c
AD
142 last unless defined $direntry;
143 ($tdev, $tino) = lstat($direntry);
a0d0e21e
LW
144 last unless $tdev != $odev || $tino != $oino;
145 }
146 closedir(DIR);
40000a8c 147 unshift(@path, $direntry);
a0d0e21e
LW
148 }
149 chdir($path = '/' . join('/', @path));
150 $path;
151}
152
153
154# keeps track of current working directory in PWD environment var
155#
156# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
157#
158# $Log: pwd.pl,v $
159#
160# Usage:
161# use Cwd 'chdir';
162# chdir $newdir;
163
164$chdir_init = 0;
165
166sub chdir_init{
167 if ($ENV{'PWD'}) {
168 my($dd,$di) = stat('.');
169 my($pd,$pi) = stat($ENV{'PWD'});
170 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
171 chop($ENV{'PWD'} = `pwd`);
172 }
173 }
174 else {
175 chop($ENV{'PWD'} = `pwd`);
176 }
177 if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
178 my($pd,$pi) = stat($2);
179 my($dd,$di) = stat($1);
180 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
181 $ENV{'PWD'}="$2$3";
182 }
183 }
184 $chdir_init = 1;
185}
186
187sub chdir {
188 my($newdir) = shift;
748a9306 189 $newdir =~ s|/{2,}|/|g;
a0d0e21e
LW
190 chdir_init() unless $chdir_init;
191 return 0 unless (CORE::chdir $newdir);
748a9306
LW
192 if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} }
193
a0d0e21e
LW
194 if ($newdir =~ m#^/#) {
195 $ENV{'PWD'} = $newdir;
196 }else{
197 my(@curdir) = split(m#/#,$ENV{'PWD'});
198 @curdir = '' unless @curdir;
199 foreach $component (split(m#/#, $newdir)) {
200 next if $component eq '.';
201 pop(@curdir),next if $component eq '..';
202 push(@curdir,$component);
203 }
204 $ENV{'PWD'} = join('/',@curdir) || '/';
205 }
206}
207
2081;
209