Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package Cwd; |
2 | require 5.000; | |
3 | require Exporter; | |
748a9306 | 4 | use Config; |
a0d0e21e | 5 | |
f06db76b AD |
6 | =head1 NAME |
7 | ||
8 | getcwd - 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 | ||
24 | The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions | |
25 | in Perl. If you ask to override your chdir() built-in function, then your | |
26 | PWD environment variable will be kept up to date. (See | |
27 | L<perlsub/Overriding builtin functions>.) | |
28 | ||
29 | The fastgetcwd() function looks the same as getcwd(), but runs faster. | |
30 | It's also more dangerous because you might conceivably chdir() out of a | |
31 | directory 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 | ||
53 | sub 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 | ||
122 | sub 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 | ||
166 | sub 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 | ||
187 | sub 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 | ||
208 | 1; | |
209 |