This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.000
[perl5.git] / lib / Cwd.pm
CommitLineData
a0d0e21e
LW
1package Cwd;
2require 5.000;
3require 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
14sub 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
80sub 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
121sub 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
142sub 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
1601;
161