This is my patch patch.0a for perl5.000.
[perl.git] / lib / Cwd.pm
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     $dotdots = '';
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             {
49                 unless ($dir = readdir(PARENT))
50                 {
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);
68     chop($cwd);
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 (;;) {
88         ($odev, $oino) = ($cdev, $cino);
89         chdir('..');
90         ($cdev, $cino) = stat('.');
91         last if $odev == $cdev && $oino == $cino;
92         opendir(DIR, '.');
93         for (;;) {
94             $_ = readdir(DIR);
95             next if $_ eq '.';
96             next if $_ eq '..';
97
98             last unless $_;
99             ($tdev, $tino) = lstat($_);
100             last unless $tdev != $odev || $tino != $oino;
101         }
102         closedir(DIR);
103         unshift(@path, $_);
104     }
105     chdir($path = '/' . join('/', @path));
106     $path;
107 }
108
109
110 # keeps track of current working directory in PWD environment var
111 #
112 # $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
113 #
114 # $Log: pwd.pl,v $
115 #
116 # Usage:
117 #       use Cwd 'chdir';
118 #       chdir $newdir;
119
120 $chdir_init = 0;
121
122 sub chdir_init{
123     if ($ENV{'PWD'}) {
124         my($dd,$di) = stat('.');
125         my($pd,$pi) = stat($ENV{'PWD'});
126         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
127             chop($ENV{'PWD'} = `pwd`);
128         }
129     }
130     else {
131         chop($ENV{'PWD'} = `pwd`);
132     }
133     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
134         my($pd,$pi) = stat($2);
135         my($dd,$di) = stat($1);
136         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
137             $ENV{'PWD'}="$2$3";
138         }
139     }
140     $chdir_init = 1;
141 }
142
143 sub chdir {
144     my($newdir) = shift;
145     chdir_init() unless $chdir_init;
146     return 0 unless (CORE::chdir $newdir);
147     if ($newdir =~ m#^/#) {
148         $ENV{'PWD'} = $newdir;
149     }else{
150         my(@curdir) = split(m#/#,$ENV{'PWD'});
151         @curdir = '' unless @curdir;
152         foreach $component (split(m#/#, $newdir)) {
153             next if $component eq '.';
154             pop(@curdir),next if $component eq '..';
155             push(@curdir,$component);
156         }
157         $ENV{'PWD'} = join('/',@curdir) || '/';
158     }
159 }
160
161 1;
162