Commit | Line | Data |
a0d0e21e |
1 | package Cwd; |
2 | require 5.000; |
3 | require Exporter; |
748a9306 |
4 | use Config; |
a0d0e21e |
5 | |
f06db76b |
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 |
35 | @ISA = qw(Exporter); |
36 | @EXPORT = qw(getcwd fastcwd); |
37 | @EXPORT_OK = qw(chdir); |
38 | |
39 | |
748a9306 |
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 |
49 | # By Brandon S. Allbery |
50 | # |
51 | # Usage: $cwd = getcwd(); |
52 | |
53 | sub getcwd |
54 | { |
748a9306 |
55 | if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } |
56 | |
a0d0e21e |
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 |
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 |
90 | unless (defined ($dir = readdir(PARENT))) |
91 | { |
a0d0e21e |
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 |
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 |
123 | if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} } |
124 | |
a0d0e21e |
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 |
132 | ($odev, $oino) = ($cdev, $cino); |
133 | chdir('..'); |
134 | ($cdev, $cino) = stat('.'); |
135 | last if $odev == $cdev && $oino == $cino; |
136 | opendir(DIR, '.'); |
137 | for (;;) { |
40000a8c |
138 | $direntry = readdir(DIR); |
139 | next if $direntry eq '.'; |
140 | next if $direntry eq '..'; |
a0d0e21e |
141 | |
40000a8c |
142 | last unless defined $direntry; |
143 | ($tdev, $tino) = lstat($direntry); |
a0d0e21e |
144 | last unless $tdev != $odev || $tino != $oino; |
145 | } |
146 | closedir(DIR); |
40000a8c |
147 | unshift(@path, $direntry); |
a0d0e21e |
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 |
190 | chdir_init() unless $chdir_init; |
191 | return 0 unless (CORE::chdir $newdir); |
748a9306 |
192 | if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} } |
193 | |
a0d0e21e |
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 | |