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