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 |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 8µs | 10µs | BEGIN@2 | Cwd::
1 | 1 | 1 | 7µs | 20µs | BEGIN@3 | Cwd::
1 | 1 | 1 | 7µs | 12µs | BEGIN@644 | Cwd::
1 | 1 | 1 | 2µs | 2µs | BEGIN@41 | Cwd::
0 | 0 | 0 | 0s | 0s | __ANON__[:222] | Cwd::
0 | 0 | 0 | 0s | 0s | __ANON__[:231] | Cwd::
0 | 0 | 0 | 0s | 0s | _backtick_pwd | Cwd::
0 | 0 | 0 | 0s | 0s | _carp | Cwd::
0 | 0 | 0 | 0s | 0s | _croak | Cwd::
0 | 0 | 0 | 0s | 0s | _dos_cwd | Cwd::
0 | 0 | 0 | 0s | 0s | _os2_cwd | Cwd::
0 | 0 | 0 | 0s | 0s | _perl_abs_path | Cwd::
0 | 0 | 0 | 0s | 0s | _perl_getcwd | Cwd::
0 | 0 | 0 | 0s | 0s | _qnx_abs_path | Cwd::
0 | 0 | 0 | 0s | 0s | _qnx_cwd | Cwd::
0 | 0 | 0 | 0s | 0s | _vms_abs_path | Cwd::
0 | 0 | 0 | 0s | 0s | _vms_cwd | Cwd::
0 | 0 | 0 | 0s | 0s | _vms_efs | Cwd::
0 | 0 | 0 | 0s | 0s | _vms_unix_rpt | Cwd::
0 | 0 | 0 | 0s | 0s | _win32_cwd | Cwd::
0 | 0 | 0 | 0s | 0s | _win32_cwd_simple | Cwd::
0 | 0 | 0 | 0s | 0s | chdir | Cwd::
0 | 0 | 0 | 0s | 0s | chdir_init | Cwd::
0 | 0 | 0 | 0s | 0s | fast_abs_path | Cwd::
0 | 0 | 0 | 0s | 0s | fastcwd_ | Cwd::
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 # 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 # 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 | ||||
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 # 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__ |