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