Profile of Cwd.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/x86_64-linux/Cwd.pm
Statements | Executed 45 statements in 2.22ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 8µs | 10µs | Cwd::::BEGIN@2Cwd::BEGIN@2
1 | 1 | 1 | 7µs | 20µs | Cwd::::BEGIN@3Cwd::BEGIN@3
1 | 1 | 1 | 7µs | 12µs | Cwd::::BEGIN@644Cwd::BEGIN@644
1 | 1 | 1 | 2µs | 2µs | Cwd::::BEGIN@41Cwd::BEGIN@41
0 | 0 | 0 | 0s | 0s | Cwd::::__ANON__[:222]Cwd::__ANON__[:222]
0 | 0 | 0 | 0s | 0s | Cwd::::__ANON__[:231]Cwd::__ANON__[:231]
0 | 0 | 0 | 0s | 0s | Cwd::::_backtick_pwdCwd::_backtick_pwd
0 | 0 | 0 | 0s | 0s | Cwd::::_carpCwd::_carp
0 | 0 | 0 | 0s | 0s | Cwd::::_croakCwd::_croak
0 | 0 | 0 | 0s | 0s | Cwd::::_dos_cwdCwd::_dos_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_os2_cwdCwd::_os2_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_perl_abs_pathCwd::_perl_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_perl_getcwdCwd::_perl_getcwd
0 | 0 | 0 | 0s | 0s | Cwd::::_qnx_abs_pathCwd::_qnx_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_qnx_cwdCwd::_qnx_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_abs_pathCwd::_vms_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_cwdCwd::_vms_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_efsCwd::_vms_efs
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_unix_rptCwd::_vms_unix_rpt
0 | 0 | 0 | 0s | 0s | Cwd::::_win32_cwdCwd::_win32_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_win32_cwd_simpleCwd::_win32_cwd_simple
0 | 0 | 0 | 0s | 0s | Cwd::::chdirCwd::chdir
0 | 0 | 0 | 0s | 0s | Cwd::::chdir_initCwd::chdir_init
0 | 0 | 0 | 0s | 0s | Cwd::::fast_abs_pathCwd::fast_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::fastcwd_Cwd::fastcwd_

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Cwd;
2 | 2 | 21µs | 2 | 11µs | # spent 10µs (8+1) within Cwd::BEGIN@2 which was called: # once (8µs+1µs) by Archive::Zip::BEGIN@6 at line 2 use strict; # spent 10µs making 1 call to Cwd::BEGIN@2 # spent 1µs making 1 call to strict::import
3 | 2 | 146µs | 2 | 33µs | # spent 20µs (7+13) within Cwd::BEGIN@3 which was called: # once (7µs+13µs) by Archive::Zip::BEGIN@6 at line 3 use Exporter; # spent 20µs making 1 call to Cwd::BEGIN@3 # spent 13µs making 1 call to Exporter::import
4 |  |  |  |  |
5 |  |  |  |  |
6 | 1 | 300ns |  |  | our $VERSION = '3.89';
7 | 1 | 200ns |  |  | my $xs_version = $VERSION;
8 | 1 | 800ns |  |  | $VERSION =~ tr/_//d;
9 |  |  |  |  |
10 | 1 | 6µs |  |  | our @ISA = qw/ Exporter /;
11 | 1 | 600ns |  |  | our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
12 | 1 | 700ns |  |  | push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
13 | 1 | 400ns |  |  | our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
14 |  |  |  |  |
15 |  |  |  |  | # sys_cwd may keep the builtin command
16 |  |  |  |  |
17 |  |  |  |  | # All the functionality of this module may provided by builtins,
18 |  |  |  |  | # there is no sense to process the rest of the file.
19 |  |  |  |  | # The best choice may be to have this in BEGIN, but how to return from BEGIN?
20 |  |  |  |  |
21 | 1 | 200ns |  |  | if ($^O eq 'os2') {
22 |  |  |  |  | local $^W = 0;
23 |  |  |  |  |
24 |  |  |  |  | *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
25 |  |  |  |  | *getcwd = \&cwd;
26 |  |  |  |  | *fastgetcwd = \&cwd;
27 |  |  |  |  | *fastcwd = \&cwd;
28 |  |  |  |  |
29 |  |  |  |  | *fast_abs_path = \&sys_abspath if defined &sys_abspath;
30 |  |  |  |  | *abs_path = \&fast_abs_path;
31 |  |  |  |  | *realpath = \&fast_abs_path;
32 |  |  |  |  | *fast_realpath = \&fast_abs_path;
33 |  |  |  |  |
34 |  |  |  |  | return 1;
35 |  |  |  |  | }
36 |  |  |  |  |
37 |  |  |  |  | # Need to look up the feature settings on VMS. The preferred way is to use the
38 |  |  |  |  | # VMS::Feature module, but that may not be available to dual life modules.
39 |  |  |  |  |
40 | 1 | 100ns |  |  | my $use_vms_feature;
41 |  |  |  |  | # spent 2µs within Cwd::BEGIN@41 which was called: # once (2µs+0s) by Archive::Zip::BEGIN@6 at line 50 BEGIN {
42 | 1 | 4µs |  |  | if ($^O eq 'VMS') {
43 |  |  |  |  | if (eval { local $SIG{__DIE__};
44 |  |  |  |  | local @INC = @INC;
45 |  |  |  |  | pop @INC if $INC[-1] eq '.';
46 |  |  |  |  | require VMS::Feature; }) {
47 |  |  |  |  | $use_vms_feature = 1;
48 |  |  |  |  | }
49 |  |  |  |  | }
50 | 1 | 1.76ms | 1 | 2µs | } # spent 2µs making 1 call to Cwd::BEGIN@41
51 |  |  |  |  |
52 |  |  |  |  | # Need to look up the UNIX report mode. This may become a dynamic mode
53 |  |  |  |  | # in the future.
54 |  |  |  |  | sub _vms_unix_rpt {
55 |  |  |  |  | my $unix_rpt;
56 |  |  |  |  | if ($use_vms_feature) {
57 |  |  |  |  | $unix_rpt = VMS::Feature::current("filename_unix_report");
58 |  |  |  |  | } else {
59 |  |  |  |  | my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
60 |  |  |  |  | $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
61 |  |  |  |  | }
62 |  |  |  |  | return $unix_rpt;
63 |  |  |  |  | }
64 |  |  |  |  |
65 |  |  |  |  | # Need to look up the EFS character set mode. This may become a dynamic
66 |  |  |  |  | # mode in the future.
67 |  |  |  |  | sub _vms_efs {
68 |  |  |  |  | my $efs;
69 |  |  |  |  | if ($use_vms_feature) {
70 |  |  |  |  | $efs = VMS::Feature::current("efs_charset");
71 |  |  |  |  | } else {
72 |  |  |  |  | my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
73 |  |  |  |  | $efs = $env_efs =~ /^[ET1]/i;
74 |  |  |  |  | }
75 |  |  |  |  | return $efs;
76 |  |  |  |  | }
77 |  |  |  |  |
78 |  |  |  |  |
79 |  |  |  |  | # If loading the XS stuff doesn't work, we can fall back to pure perl
80 | 1 | 2µs |  |  | if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { # skipped on miniperl
81 | 1 | 400ns |  |  | require XSLoader;
82 | 1 | 119µs | 1 | 115µs | XSLoader::load( __PACKAGE__, $xs_version); # spent 115µs making 1 call to XSLoader::load
83 |  |  |  |  | }
84 |  |  |  |  |
85 |  |  |  |  | # Big nasty table of function aliases
86 | 1 | 6µs |  |  | my %METHOD_MAP =
87 |  |  |  |  | (
88 |  |  |  |  | VMS =>
89 |  |  |  |  | {
90 |  |  |  |  | cwd => '_vms_cwd',
91 |  |  |  |  | getcwd => '_vms_cwd',
92 |  |  |  |  | fastcwd => '_vms_cwd',
93 |  |  |  |  | fastgetcwd => '_vms_cwd',
94 |  |  |  |  | abs_path => '_vms_abs_path',
95 |  |  |  |  | fast_abs_path => '_vms_abs_path',
96 |  |  |  |  | },
97 |  |  |  |  |
98 |  |  |  |  | MSWin32 =>
99 |  |  |  |  | {
100 |  |  |  |  | # We assume that &_NT_cwd is defined as an XSUB or in the core.
101 |  |  |  |  | cwd => '_NT_cwd',
102 |  |  |  |  | getcwd => '_NT_cwd',
103 |  |  |  |  | fastcwd => '_NT_cwd',
104 |  |  |  |  | fastgetcwd => '_NT_cwd',
105 |  |  |  |  | abs_path => 'fast_abs_path',
106 |  |  |  |  | realpath => 'fast_abs_path',
107 |  |  |  |  | },
108 |  |  |  |  |
109 |  |  |  |  | dos =>
110 |  |  |  |  | {
111 |  |  |  |  | cwd => '_dos_cwd',
112 |  |  |  |  | getcwd => '_dos_cwd',
113 |  |  |  |  | fastgetcwd => '_dos_cwd',
114 |  |  |  |  | fastcwd => '_dos_cwd',
115 |  |  |  |  | abs_path => 'fast_abs_path',
116 |  |  |  |  | },
117 |  |  |  |  |
118 |  |  |  |  | # QNX4. QNX6 has a $os of 'nto'.
119 |  |  |  |  | qnx =>
120 |  |  |  |  | {
121 |  |  |  |  | cwd => '_qnx_cwd',
122 |  |  |  |  | getcwd => '_qnx_cwd',
123 |  |  |  |  | fastgetcwd => '_qnx_cwd',
124 |  |  |  |  | fastcwd => '_qnx_cwd',
125 |  |  |  |  | abs_path => '_qnx_abs_path',
126 |  |  |  |  | fast_abs_path => '_qnx_abs_path',
127 |  |  |  |  | },
128 |  |  |  |  |
129 |  |  |  |  | cygwin =>
130 |  |  |  |  | {
131 |  |  |  |  | getcwd => 'cwd',
132 |  |  |  |  | fastgetcwd => 'cwd',
133 |  |  |  |  | fastcwd => 'cwd',
134 |  |  |  |  | abs_path => 'fast_abs_path',
135 |  |  |  |  | realpath => 'fast_abs_path',
136 |  |  |  |  | },
137 |  |  |  |  |
138 |  |  |  |  | amigaos =>
139 |  |  |  |  | {
140 |  |  |  |  | getcwd => '_backtick_pwd',
141 |  |  |  |  | fastgetcwd => '_backtick_pwd',
142 |  |  |  |  | fastcwd => '_backtick_pwd',
143 |  |  |  |  | abs_path => 'fast_abs_path',
144 |  |  |  |  | }
145 |  |  |  |  | );
146 |  |  |  |  |
147 | 1 | 600ns |  |  | $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
148 |  |  |  |  |
149 |  |  |  |  |
150 |  |  |  |  | # Find the pwd command in the expected locations. We assume these
151 |  |  |  |  | # are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
152 |  |  |  |  | # so everything works under taint mode.
153 | 1 | 100ns |  |  | my $pwd_cmd;
154 | 1 | 1µs |  |  | if($^O ne 'MSWin32') {
155 | 1 | 300ns |  |  | foreach my $try ('/bin/pwd',
156 |  |  |  |  | '/usr/bin/pwd',
157 |  |  |  |  | '/QOpenSys/bin/pwd', # OS/400 PASE.
158 |  |  |  |  | ) {
159 | 1 | 12µs | 1 | 8µs | if( -x $try ) { # spent 8µs making 1 call to CORE::fteexec
160 | 1 | 200ns |  |  | $pwd_cmd = $try;
161 | 1 | 700ns |  |  | last;
162 |  |  |  |  | }
163 |  |  |  |  | }
164 |  |  |  |  | }
165 |  |  |  |  |
166 |  |  |  |  | # Android has a built-in pwd. Using $pwd_cmd will DTRT if
167 |  |  |  |  | # this perl was compiled with -Dd_useshellcmds, which is the
168 |  |  |  |  | # default for Android, but the block below is needed for the
169 |  |  |  |  | # miniperl running on the host when cross-compiling, and
170 |  |  |  |  | # potentially for native builds with -Ud_useshellcmds.
171 | 1 | 2µs | 1 | 400ns | if ($^O =~ /android/) { # spent 400ns making 1 call to CORE::match
172 |  |  |  |  | # If targetsh is executable, then we're either a full
173 |  |  |  |  | # perl, or a miniperl for a native build.
174 |  |  |  |  | if ( exists($Config::Config{targetsh}) && -x $Config::Config{targetsh}) {
175 |  |  |  |  | $pwd_cmd = "$Config::Config{targetsh} -c pwd"
176 |  |  |  |  | }
177 |  |  |  |  | else {
178 |  |  |  |  | my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
179 |  |  |  |  | $pwd_cmd = "$sh -c pwd"
180 |  |  |  |  | }
181 |  |  |  |  | }
182 |  |  |  |  |
183 | 1 | 300ns |  |  | my $found_pwd_cmd = defined($pwd_cmd);
184 |  |  |  |  |
185 |  |  |  |  | # Lazy-load Carp
186 |  |  |  |  | sub _carp { require Carp; Carp::carp(@_) }
187 |  |  |  |  | sub _croak { require Carp; Carp::croak(@_) }
188 |  |  |  |  |
189 |  |  |  |  | # The 'natural and safe form' for UNIX (pwd may be setuid root)
190 |  |  |  |  | sub _backtick_pwd {
191 |  |  |  |  |
192 |  |  |  |  | # Localize %ENV entries in a way that won't create new hash keys.
193 |  |  |  |  | # Under AmigaOS we don't want to localize as it stops perl from
194 |  |  |  |  | # finding 'sh' in the PATH.
195 |  |  |  |  | my @localize = grep exists $ENV{$_}, qw(IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos";
196 |  |  |  |  | local @ENV{@localize} if @localize;
197 |  |  |  |  | # empty PATH is the same as "." on *nix, so localize it to /something/
198 |  |  |  |  | # we won't *use* the path as code above turns $pwd_cmd into a specific
199 |  |  |  |  | # executable, but it will blow up anyway under taint. We could set it to
200 |  |  |  |  | # anything absolute. Perhaps "/" would be better.
201 |  |  |  |  | local $ENV{PATH}= "/usr/bin"
202 |  |  |  |  | if $^O ne "amigaos";
203 |  |  |  |  |
204 |  |  |  |  | my $cwd = `$pwd_cmd`;
205 |  |  |  |  | # Belt-and-suspenders in case someone said "undef $/".
206 |  |  |  |  | local $/ = "\n";
207 |  |  |  |  | # `pwd` may fail e.g. if the disk is full
208 |  |  |  |  | chomp($cwd) if defined $cwd;
209 |  |  |  |  | $cwd;
210 |  |  |  |  | }
211 |  |  |  |  |
212 |  |  |  |  | # Since some ports may predefine cwd internally (e.g., NT)
213 |  |  |  |  | # we take care not to override an existing definition for cwd().
214 |  |  |  |  |
215 | 1 | 2µs |  |  | unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
216 |  |  |  |  | if( $found_pwd_cmd )
217 |  |  |  |  | {
218 |  |  |  |  | *cwd = \&_backtick_pwd;
219 |  |  |  |  | }
220 |  |  |  |  | else {
221 |  |  |  |  | # getcwd() might have an empty prototype
222 |  |  |  |  | *cwd = sub { getcwd(); };
223 |  |  |  |  | }
224 |  |  |  |  | }
225 |  |  |  |  |
226 | 1 | 300ns |  |  | if ($^O eq 'cygwin') {
227 |  |  |  |  | # We need to make sure cwd() is called with no args, because it's
228 |  |  |  |  | # got an arg-less prototype and will die if args are present.
229 |  |  |  |  | local $^W = 0;
230 |  |  |  |  | my $orig_cwd = \&cwd;
231 |  |  |  |  | *cwd = sub { &$orig_cwd() }
232 |  |  |  |  | }
233 |  |  |  |  |
234 |  |  |  |  |
235 |  |  |  |  | # set a reasonable (and very safe) default for fastgetcwd, in case it
236 |  |  |  |  | # isn't redefined later (20001212 rspier)
237 | 1 | 200ns |  |  | *fastgetcwd = \&cwd;
238 |  |  |  |  |
239 |  |  |  |  | # A non-XS version of getcwd() - also used to bootstrap the perl build
240 |  |  |  |  | # process, when miniperl is running and no XS loading happens.
241 |  |  |  |  | sub _perl_getcwd
242 |  |  |  |  | {
243 |  |  |  |  | abs_path('.');
244 |  |  |  |  | }
245 |  |  |  |  |
246 |  |  |  |  | # By John Bazik
247 |  |  |  |  | #
248 |  |  |  |  | # Usage: $cwd = &fastcwd;
249 |  |  |  |  | #
250 |  |  |  |  | # This is a faster version of getcwd. It's also more dangerous because
251 |  |  |  |  | # you might chdir out of a directory that you can't chdir back into.
252 |  |  |  |  |
253 |  |  |  |  | sub fastcwd_ {
254 |  |  |  |  | my($odev, $oino, $cdev, $cino, $tdev, $tino);
255 |  |  |  |  | my(@path, $path);
256 |  |  |  |  | local(*DIR);
257 |  |  |  |  |
258 |  |  |  |  | my($orig_cdev, $orig_cino) = stat('.');
259 |  |  |  |  | ($cdev, $cino) = ($orig_cdev, $orig_cino);
260 |  |  |  |  | for (;;) {
261 |  |  |  |  | my $direntry;
262 |  |  |  |  | ($odev, $oino) = ($cdev, $cino);
263 |  |  |  |  | CORE::chdir('..') || return undef;
264 |  |  |  |  | ($cdev, $cino) = stat('.');
265 |  |  |  |  | last if $odev == $cdev && $oino eq $cino;
266 |  |  |  |  | opendir(DIR, '.') || return undef;
267 |  |  |  |  | for (;;) {
268 |  |  |  |  | $direntry = readdir(DIR);
269 |  |  |  |  | last unless defined $direntry;
270 |  |  |  |  | next if $direntry eq '.';
271 |  |  |  |  | next if $direntry eq '..';
272 |  |  |  |  |
273 |  |  |  |  | ($tdev, $tino) = lstat($direntry);
274 |  |  |  |  | last unless $tdev != $odev || $tino ne $oino;
275 |  |  |  |  | }
276 |  |  |  |  | closedir(DIR);
277 |  |  |  |  | return undef unless defined $direntry; # should never happen
278 |  |  |  |  | unshift(@path, $direntry);
279 |  |  |  |  | }
280 |  |  |  |  | $path = '/' . join('/', @path);
281 |  |  |  |  | if ($^O eq 'apollo') { $path = "/".$path; }
282 |  |  |  |  | # At this point $path may be tainted (if tainting) and chdir would fail.
283 |  |  |  |  | # Untaint it then check that we landed where we started.
284 |  |  |  |  | $path =~ /^(.*)\z/s # untaint
285 |  |  |  |  | && CORE::chdir($1) or return undef;
286 |  |  |  |  | ($cdev, $cino) = stat('.');
287 |  |  |  |  | die "Unstable directory path, current directory changed unexpectedly"
288 |  |  |  |  | if $cdev != $orig_cdev || $cino ne $orig_cino;
289 |  |  |  |  | $path;
290 |  |  |  |  | }
291 | 1 | 200ns |  |  | if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
292 |  |  |  |  |
293 |  |  |  |  |
294 |  |  |  |  | # Keeps track of current working directory in PWD environment var
295 |  |  |  |  | # Usage:
296 |  |  |  |  | # use Cwd 'chdir';
297 |  |  |  |  | # chdir $newdir;
298 |  |  |  |  |
299 | 1 | 200ns |  |  | my $chdir_init = 0;
300 |  |  |  |  |
301 |  |  |  |  | sub chdir_init {
302 |  |  |  |  | if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
303 |  |  |  |  | my($dd,$di) = stat('.');
304 |  |  |  |  | my($pd,$pi) = stat($ENV{'PWD'});
305 |  |  |  |  | if (!defined $dd or !defined $pd or $di ne $pi or $dd != $pd) {
306 |  |  |  |  | $ENV{'PWD'} = cwd();
307 |  |  |  |  | }
308 |  |  |  |  | }
309 |  |  |  |  | else {
310 |  |  |  |  | my $wd = cwd();
311 |  |  |  |  | $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
312 |  |  |  |  | $ENV{'PWD'} = $wd;
313 |  |  |  |  | }
314 |  |  |  |  | # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
315 |  |  |  |  | if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
316 |  |  |  |  | my($pd,$pi) = stat($2);
317 |  |  |  |  | my($dd,$di) = stat($1);
318 |  |  |  |  | if (defined $pd and defined $dd and $di ne $pi and $dd == $pd) {
319 |  |  |  |  | $ENV{'PWD'}="$2$3";
320 |  |  |  |  | }
321 |  |  |  |  | }
322 |  |  |  |  | $chdir_init = 1;
323 |  |  |  |  | }
324 |  |  |  |  |
325 |  |  |  |  | sub chdir {
326 |  |  |  |  | my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
327 |  |  |  |  | if ($^O eq "cygwin") {
328 |  |  |  |  | $newdir =~ s|\A///+|//|;
329 |  |  |  |  | $newdir =~ s|(?<=[^/])//+|/|g;
330 |  |  |  |  | }
331 |  |  |  |  | elsif ($^O ne 'MSWin32') {
332 |  |  |  |  | $newdir =~ s|///*|/|g;
333 |  |  |  |  | }
334 |  |  |  |  | chdir_init() unless $chdir_init;
335 |  |  |  |  | my $newpwd;
336 |  |  |  |  | if ($^O eq 'MSWin32') {
337 |  |  |  |  | # get the full path name *before* the chdir()
338 |  |  |  |  | $newpwd = Win32::GetFullPathName($newdir);
339 |  |  |  |  | }
340 |  |  |  |  |
341 |  |  |  |  | return 0 unless CORE::chdir $newdir;
342 |  |  |  |  |
343 |  |  |  |  | if ($^O eq 'VMS') {
344 |  |  |  |  | return $ENV{'PWD'} = $ENV{'DEFAULT'}
345 |  |  |  |  | }
346 |  |  |  |  | elsif ($^O eq 'MSWin32') {
347 |  |  |  |  | $ENV{'PWD'} = $newpwd;
348 |  |  |  |  | return 1;
349 |  |  |  |  | }
350 |  |  |  |  |
351 |  |  |  |  | if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
352 |  |  |  |  | $ENV{'PWD'} = cwd();
353 |  |  |  |  | } elsif ($newdir =~ m#^/#s) {
354 |  |  |  |  | $ENV{'PWD'} = $newdir;
355 |  |  |  |  | } else {
356 |  |  |  |  | my @curdir = split(m#/#,$ENV{'PWD'});
357 |  |  |  |  | @curdir = ('') unless @curdir;
358 |  |  |  |  | my $component;
359 |  |  |  |  | foreach $component (split(m#/#, $newdir)) {
360 |  |  |  |  | next if $component eq '.';
361 |  |  |  |  | pop(@curdir),next if $component eq '..';
362 |  |  |  |  | push(@curdir,$component);
363 |  |  |  |  | }
364 |  |  |  |  | $ENV{'PWD'} = join('/',@curdir) || '/';
365 |  |  |  |  | }
366 |  |  |  |  | 1;
367 |  |  |  |  | }
368 |  |  |  |  |
369 |  |  |  |  |
370 |  |  |  |  | sub _perl_abs_path
371 |  |  |  |  | {
372 |  |  |  |  | my $start = @_ ? shift : '.';
373 |  |  |  |  | my($dotdots, $cwd, @pst, @cst, $dir, @tst);
374 |  |  |  |  |
375 |  |  |  |  | unless (@cst = stat( $start ))
376 |  |  |  |  | {
377 |  |  |  |  | return undef;
378 |  |  |  |  | }
379 |  |  |  |  |
380 |  |  |  |  | unless (-d _) {
381 |  |  |  |  | # Make sure we can be invoked on plain files, not just directories.
382 |  |  |  |  | # NOTE that this routine assumes that '/' is the only directory separator.
383 |  |  |  |  |
384 |  |  |  |  | my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
385 |  |  |  |  | or return cwd() . '/' . $start;
386 |  |  |  |  |
387 |  |  |  |  | # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
388 |  |  |  |  | if (-l $start) {
389 |  |  |  |  | my $link_target = readlink($start);
390 |  |  |  |  | die "Can't resolve link $start: $!" unless defined $link_target;
391 |  |  |  |  |
392 |  |  |  |  | require File::Spec;
393 |  |  |  |  | $link_target = $dir . '/' . $link_target
394 |  |  |  |  | unless File::Spec->file_name_is_absolute($link_target);
395 |  |  |  |  |
396 |  |  |  |  | return abs_path($link_target);
397 |  |  |  |  | }
398 |  |  |  |  |
399 |  |  |  |  | return $dir ? abs_path($dir) . "/$file" : "/$file";
400 |  |  |  |  | }
401 |  |  |  |  |
402 |  |  |  |  | $cwd = '';
403 |  |  |  |  | $dotdots = $start;
404 |  |  |  |  | do
405 |  |  |  |  | {
406 |  |  |  |  | $dotdots .= '/..';
407 |  |  |  |  | @pst = @cst;
408 |  |  |  |  | local *PARENT;
409 |  |  |  |  | unless (opendir(PARENT, $dotdots))
410 |  |  |  |  | {
411 |  |  |  |  | return undef;
412 |  |  |  |  | }
413 |  |  |  |  | unless (@cst = stat($dotdots))
414 |  |  |  |  | {
415 |  |  |  |  | my $e = $!;
416 |  |  |  |  | closedir(PARENT);
417 |  |  |  |  | $! = $e;
418 |  |  |  |  | return undef;
419 |  |  |  |  | }
420 |  |  |  |  | if ($pst[0] == $cst[0] && $pst[1] eq $cst[1])
421 |  |  |  |  | {
422 |  |  |  |  | $dir = undef;
423 |  |  |  |  | }
424 |  |  |  |  | else
425 |  |  |  |  | {
426 |  |  |  |  | do
427 |  |  |  |  | {
428 |  |  |  |  | unless (defined ($dir = readdir(PARENT)))
429 |  |  |  |  | {
430 |  |  |  |  | closedir(PARENT);
431 |  |  |  |  | require Errno;
432 |  |  |  |  | $! = Errno::ENOENT();
433 |  |  |  |  | return undef;
434 |  |  |  |  | }
435 |  |  |  |  | $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
436 |  |  |  |  | }
437 |  |  |  |  | while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
438 |  |  |  |  | $tst[1] ne $pst[1]);
439 |  |  |  |  | }
440 |  |  |  |  | $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
441 |  |  |  |  | closedir(PARENT);
442 |  |  |  |  | } while (defined $dir);
443 |  |  |  |  | chop($cwd) unless $cwd eq '/'; # drop the trailing /
444 |  |  |  |  | $cwd;
445 |  |  |  |  | }
446 |  |  |  |  |
447 |  |  |  |  |
448 | 1 | 100ns |  |  | my $Curdir;
449 |  |  |  |  | sub fast_abs_path {
450 |  |  |  |  | local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
451 |  |  |  |  | my $cwd = getcwd();
452 |  |  |  |  | defined $cwd or return undef;
453 |  |  |  |  | require File::Spec;
454 |  |  |  |  | my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
455 |  |  |  |  |
456 |  |  |  |  | # Detaint else we'll explode in taint mode. This is safe because
457 |  |  |  |  | # we're not doing anything dangerous with it.
458 |  |  |  |  | ($path) = $path =~ /(.*)/s;
459 |  |  |  |  | ($cwd) = $cwd =~ /(.*)/s;
460 |  |  |  |  |
461 |  |  |  |  | unless (-e $path) {
462 |  |  |  |  | require Errno;
463 |  |  |  |  | $! = Errno::ENOENT();
464 |  |  |  |  | return undef;
465 |  |  |  |  | }
466 |  |  |  |  |
467 |  |  |  |  | unless (-d _) {
468 |  |  |  |  | # Make sure we can be invoked on plain files, not just directories.
469 |  |  |  |  |
470 |  |  |  |  | my ($vol, $dir, $file) = File::Spec->splitpath($path);
471 |  |  |  |  | return File::Spec->catfile($cwd, $path) unless length $dir;
472 |  |  |  |  |
473 |  |  |  |  | if (-l $path) {
474 |  |  |  |  | my $link_target = readlink($path);
475 |  |  |  |  | defined $link_target or return undef;
476 |  |  |  |  |
477 |  |  |  |  | $link_target = File::Spec->catpath($vol, $dir, $link_target)
478 |  |  |  |  | unless File::Spec->file_name_is_absolute($link_target);
479 |  |  |  |  |
480 |  |  |  |  | return fast_abs_path($link_target);
481 |  |  |  |  | }
482 |  |  |  |  |
483 |  |  |  |  | return $dir eq File::Spec->rootdir
484 |  |  |  |  | ? File::Spec->catpath($vol, $dir, $file)
485 |  |  |  |  | : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
486 |  |  |  |  | }
487 |  |  |  |  |
488 |  |  |  |  | if (!CORE::chdir($path)) {
489 |  |  |  |  | return undef;
490 |  |  |  |  | }
491 |  |  |  |  | my $realpath = getcwd();
492 |  |  |  |  | if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
493 |  |  |  |  | _croak("Cannot chdir back to $cwd: $!");
494 |  |  |  |  | }
495 |  |  |  |  | $realpath;
496 |  |  |  |  | }
497 |  |  |  |  |
498 |  |  |  |  | # added function alias to follow principle of least surprise
499 |  |  |  |  | # based on previous aliasing. --tchrist 27-Jan-00
500 | 1 | 200ns |  |  | *fast_realpath = \&fast_abs_path;
501 |  |  |  |  |
502 |  |  |  |  |
503 |  |  |  |  | # --- PORTING SECTION ---
504 |  |  |  |  |
505 |  |  |  |  | # VMS: $ENV{'DEFAULT'} points to default directory at all times
506 |  |  |  |  | # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
507 |  |  |  |  | # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
508 |  |  |  |  | # in the process logical name table as the default device and directory
509 |  |  |  |  | # seen by Perl. This may not be the same as the default device
510 |  |  |  |  | # and directory seen by DCL after Perl exits, since the effects
511 |  |  |  |  | # the CRTL chdir() function persist only until Perl exits.
512 |  |  |  |  |
513 |  |  |  |  | sub _vms_cwd {
514 |  |  |  |  | return $ENV{'DEFAULT'};
515 |  |  |  |  | }
516 |  |  |  |  |
517 |  |  |  |  | sub _vms_abs_path {
518 |  |  |  |  | return $ENV{'DEFAULT'} unless @_;
519 |  |  |  |  | my $path = shift;
520 |  |  |  |  |
521 |  |  |  |  | my $efs = _vms_efs;
522 |  |  |  |  | my $unix_rpt = _vms_unix_rpt;
523 |  |  |  |  |
524 |  |  |  |  | if (defined &VMS::Filespec::vmsrealpath) {
525 |  |  |  |  | my $path_unix = 0;
526 |  |  |  |  | my $path_vms = 0;
527 |  |  |  |  |
528 |  |  |  |  | $path_unix = 1 if ($path =~ m#(?<=\^)/#);
529 |  |  |  |  | $path_unix = 1 if ($path =~ /^\.\.?$/);
530 |  |  |  |  | $path_vms = 1 if ($path =~ m#[\[<\]]#);
531 |  |  |  |  | $path_vms = 1 if ($path =~ /^--?$/);
532 |  |  |  |  |
533 |  |  |  |  | my $unix_mode = $path_unix;
534 |  |  |  |  | if ($efs) {
535 |  |  |  |  | # In case of a tie, the Unix report mode decides.
536 |  |  |  |  | if ($path_vms == $path_unix) {
537 |  |  |  |  | $unix_mode = $unix_rpt;
538 |  |  |  |  | } else {
539 |  |  |  |  | $unix_mode = 0 if $path_vms;
540 |  |  |  |  | }
541 |  |  |  |  | }
542 |  |  |  |  |
543 |  |  |  |  | if ($unix_mode) {
544 |  |  |  |  | # Unix format
545 |  |  |  |  | return VMS::Filespec::unixrealpath($path);
546 |  |  |  |  | }
547 |  |  |  |  |
548 |  |  |  |  | # VMS format
549 |  |  |  |  |
550 |  |  |  |  | my $new_path = VMS::Filespec::vmsrealpath($path);
551 |  |  |  |  |
552 |  |  |  |  | # Perl expects directories to be in directory format
553 |  |  |  |  | $new_path = VMS::Filespec::pathify($new_path) if -d $path;
554 |  |  |  |  | return $new_path;
555 |  |  |  |  | }
556 |  |  |  |  |
557 |  |  |  |  | # Fallback to older algorithm if correct ones are not
558 |  |  |  |  | # available.
559 |  |  |  |  |
560 |  |  |  |  | if (-l $path) {
561 |  |  |  |  | my $link_target = readlink($path);
562 |  |  |  |  | die "Can't resolve link $path: $!" unless defined $link_target;
563 |  |  |  |  |
564 |  |  |  |  | return _vms_abs_path($link_target);
565 |  |  |  |  | }
566 |  |  |  |  |
567 |  |  |  |  | # may need to turn foo.dir into [.foo]
568 |  |  |  |  | my $pathified = VMS::Filespec::pathify($path);
569 |  |  |  |  | $path = $pathified if defined $pathified;
570 |  |  |  |  |
571 |  |  |  |  | return VMS::Filespec::rmsexpand($path);
572 |  |  |  |  | }
573 |  |  |  |  |
574 |  |  |  |  | sub _os2_cwd {
575 |  |  |  |  | my $pwd = `cmd /c cd`;
576 |  |  |  |  | chomp $pwd;
577 |  |  |  |  | $pwd =~ s:\\:/:g ;
578 |  |  |  |  | $ENV{'PWD'} = $pwd;
579 |  |  |  |  | return $pwd;
580 |  |  |  |  | }
581 |  |  |  |  |
582 |  |  |  |  | sub _win32_cwd_simple {
583 |  |  |  |  | my $pwd = `cd`;
584 |  |  |  |  | chomp $pwd;
585 |  |  |  |  | $pwd =~ s:\\:/:g ;
586 |  |  |  |  | $ENV{'PWD'} = $pwd;
587 |  |  |  |  | return $pwd;
588 |  |  |  |  | }
589 |  |  |  |  |
590 |  |  |  |  | sub _win32_cwd {
591 |  |  |  |  | my $pwd;
592 |  |  |  |  | $pwd = Win32::GetCwd();
593 |  |  |  |  | $pwd =~ s:\\:/:g ;
594 |  |  |  |  | $ENV{'PWD'} = $pwd;
595 |  |  |  |  | return $pwd;
596 |  |  |  |  | }
597 |  |  |  |  |
598 | 1 | 400ns |  |  | *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
599 |  |  |  |  |
600 |  |  |  |  | sub _dos_cwd {
601 |  |  |  |  | my $pwd;
602 |  |  |  |  | if (!defined &Dos::GetCwd) {
603 |  |  |  |  | chomp($pwd = `command /c cd`);
604 |  |  |  |  | $pwd =~ s:\\:/:g ;
605 |  |  |  |  | } else {
606 |  |  |  |  | $pwd = Dos::GetCwd();
607 |  |  |  |  | }
608 |  |  |  |  | $ENV{'PWD'} = $pwd;
609 |  |  |  |  | return $pwd;
610 |  |  |  |  | }
611 |  |  |  |  |
612 |  |  |  |  | sub _qnx_cwd {
613 |  |  |  |  | local $ENV{PATH} = '';
614 |  |  |  |  | local $ENV{CDPATH} = '';
615 |  |  |  |  | local $ENV{ENV} = '';
616 |  |  |  |  | my $pwd = `/usr/bin/fullpath -t`;
617 |  |  |  |  | chomp $pwd;
618 |  |  |  |  | $ENV{'PWD'} = $pwd;
619 |  |  |  |  | return $pwd;
620 |  |  |  |  | }
621 |  |  |  |  |
622 |  |  |  |  | sub _qnx_abs_path {
623 |  |  |  |  | local $ENV{PATH} = '';
624 |  |  |  |  | local $ENV{CDPATH} = '';
625 |  |  |  |  | local $ENV{ENV} = '';
626 |  |  |  |  | my $path = @_ ? shift : '.';
627 |  |  |  |  | local *REALPATH;
628 |  |  |  |  |
629 |  |  |  |  | defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
630 |  |  |  |  | die "Can't open /usr/bin/fullpath: $!";
631 |  |  |  |  | my $realpath = <REALPATH>;
632 |  |  |  |  | close REALPATH;
633 |  |  |  |  | chomp $realpath;
634 |  |  |  |  | return $realpath;
635 |  |  |  |  | }
636 |  |  |  |  |
637 |  |  |  |  | # Now that all the base-level functions are set up, alias the
638 |  |  |  |  | # user-level functions to the right places
639 |  |  |  |  |
640 | 1 | 300ns |  |  | if (exists $METHOD_MAP{$^O}) {
641 | 1 | 300ns |  |  | my $map = $METHOD_MAP{$^O};
642 | 1 | 900ns |  |  | foreach my $name (keys %$map) {
643 |  |  |  |  | local $^W = 0; # assignments trigger 'subroutine redefined' warning
644 | 2 | 96µs | 2 | 16µs | # spent 12µs (7+4) within Cwd::BEGIN@644 which was called: # once (7µs+4µs) by Archive::Zip::BEGIN@6 at line 644 no strict 'refs'; # spent 12µs making 1 call to Cwd::BEGIN@644 # spent 4µs making 1 call to strict::unimport
645 |  |  |  |  | *{$name} = \&{$map->{$name}};
646 |  |  |  |  | }
647 |  |  |  |  | }
648 |  |  |  |  |
649 |  |  |  |  | # built-in from 5.30
650 | 1 | 200ns |  |  | *getcwd = \&Internals::getcwd
651 |  |  |  |  | if !defined &getcwd && defined &Internals::getcwd;
652 |  |  |  |  |
653 |  |  |  |  | # In case the XS version doesn't load.
654 | 1 | 100ns |  |  | *abs_path = \&_perl_abs_path unless defined &abs_path;
655 | 1 | 100ns |  |  | *getcwd = \&_perl_getcwd unless defined &getcwd;
656 |  |  |  |  |
657 |  |  |  |  | # added function alias for those of us more
658 |  |  |  |  | # used to the libc function. --tchrist 27-Jan-00
659 | 1 | 200ns |  |  | *realpath = \&abs_path;
660 |  |  |  |  |
661 | 1 | 27µs |  |  | 1;
662 |  |  |  |  | __END__