This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5.000 patch.0k: MakeMaker 4.06 and to fix minor portability and build problems...
[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 = '';
42793c05 24 $dotdots = '';
a0d0e21e
LW
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
TB
49 unless (defined ($dir = readdir(PARENT)))
50 {
a0d0e21e
LW
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
LW
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
81sub 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
3edbfbe5 98 last unless defined;
a0d0e21e
LW
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
122sub 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
143sub 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
1611;
162