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