Filename | /Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/darwin-2level/Cwd.pm |
Statements | Executed 45 statements in 3.49ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 52µs | 52µs | CORE:fteexec (opcode) | Cwd::
1 | 1 | 1 | 18µs | 42µs | BEGIN@638 | Cwd::
1 | 1 | 1 | 12µs | 13µs | BEGIN@2 | Cwd::
1 | 1 | 1 | 3µs | 14µs | BEGIN@3 | Cwd::
1 | 1 | 1 | 2µs | 2µs | BEGIN@41 | Cwd::
1 | 1 | 1 | 2µs | 2µs | CORE:match (opcode) | Cwd::
0 | 0 | 0 | 0s | 0s | __ANON__[:216] | Cwd::
0 | 0 | 0 | 0s | 0s | __ANON__[:225] | 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 | 16µs | 2 | 14µs | # spent 13µs (12+1000ns) within Cwd::BEGIN@2 which was called:
# once (12µs+1000ns) by File::Spec::Unix::BEGIN@4 at line 2 # spent 13µs making 1 call to Cwd::BEGIN@2
# spent 1µs making 1 call to strict::import |
3 | 2 | 147µs | 2 | 25µs | # spent 14µs (3+11) within Cwd::BEGIN@3 which was called:
# once (3µs+11µs) by File::Spec::Unix::BEGIN@4 at line 3 # spent 14µs making 1 call to Cwd::BEGIN@3
# spent 11µs making 1 call to Exporter::import |
4 | |||||
5 | |||||
6 | 1 | 0s | our $VERSION = '3.84'; | ||
7 | 1 | 0s | my $xs_version = $VERSION; | ||
8 | 1 | 2µs | $VERSION =~ tr/_//d; | ||
9 | |||||
10 | 1 | 13µs | our @ISA = qw/ Exporter /; | ||
11 | 1 | 1µs | our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); | ||
12 | 1 | 2µs | push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; | ||
13 | 1 | 1µs | 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 | 0s | 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 | 0s | my $use_vms_feature; | ||
41 | # spent 2µs within Cwd::BEGIN@41 which was called:
# once (2µs+0s) by File::Spec::Unix::BEGIN@4 at line 50 | ||||
42 | 1 | 3µ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 | 2.42ms | 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 | 4µs | if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { # skipped on miniperl | ||
81 | 1 | 1µs | require XSLoader; | ||
82 | 1 | 434µs | 1 | 425µs | XSLoader::load( __PACKAGE__, $xs_version); # spent 425µs making 1 call to XSLoader::load |
83 | } | ||||
84 | |||||
85 | # Big nasty table of function aliases | ||||
86 | 1 | 10µ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 | 2µs | $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 | 0s | my $pwd_cmd; | ||
154 | 1 | 3µs | if($^O ne 'MSWin32') { | ||
155 | 1 | 0s | foreach my $try ('/bin/pwd', | ||
156 | '/usr/bin/pwd', | ||||
157 | '/QOpenSys/bin/pwd', # OS/400 PASE. | ||||
158 | ) { | ||||
159 | 1 | 82µs | 1 | 52µs | if( -x $try ) { # spent 52µs making 1 call to Cwd::CORE:fteexec |
160 | 1 | 0s | $pwd_cmd = $try; | ||
161 | 1 | 1µs | 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 | 7µs | 1 | 2µs | if ($^O =~ /android/) { # spent 2µs making 1 call to Cwd::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 | 1µs | 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(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos"; | ||||
196 | local @ENV{@localize} if @localize; | ||||
197 | |||||
198 | my $cwd = `$pwd_cmd`; | ||||
199 | # Belt-and-suspenders in case someone said "undef $/". | ||||
200 | local $/ = "\n"; | ||||
201 | # `pwd` may fail e.g. if the disk is full | ||||
202 | chomp($cwd) if defined $cwd; | ||||
203 | $cwd; | ||||
204 | } | ||||
205 | |||||
206 | # Since some ports may predefine cwd internally (e.g., NT) | ||||
207 | # we take care not to override an existing definition for cwd(). | ||||
208 | |||||
209 | 1 | 4µs | unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { | ||
210 | if( $found_pwd_cmd ) | ||||
211 | { | ||||
212 | *cwd = \&_backtick_pwd; | ||||
213 | } | ||||
214 | else { | ||||
215 | # getcwd() might have an empty prototype | ||||
216 | *cwd = sub { getcwd(); }; | ||||
217 | } | ||||
218 | } | ||||
219 | |||||
220 | 1 | 1µs | if ($^O eq 'cygwin') { | ||
221 | # We need to make sure cwd() is called with no args, because it's | ||||
222 | # got an arg-less prototype and will die if args are present. | ||||
223 | local $^W = 0; | ||||
224 | my $orig_cwd = \&cwd; | ||||
225 | *cwd = sub { &$orig_cwd() } | ||||
226 | } | ||||
227 | |||||
228 | |||||
229 | # set a reasonable (and very safe) default for fastgetcwd, in case it | ||||
230 | # isn't redefined later (20001212 rspier) | ||||
231 | 1 | 1µs | *fastgetcwd = \&cwd; | ||
232 | |||||
233 | # A non-XS version of getcwd() - also used to bootstrap the perl build | ||||
234 | # process, when miniperl is running and no XS loading happens. | ||||
235 | sub _perl_getcwd | ||||
236 | { | ||||
237 | abs_path('.'); | ||||
238 | } | ||||
239 | |||||
240 | # By John Bazik | ||||
241 | # | ||||
242 | # Usage: $cwd = &fastcwd; | ||||
243 | # | ||||
244 | # This is a faster version of getcwd. It's also more dangerous because | ||||
245 | # you might chdir out of a directory that you can't chdir back into. | ||||
246 | |||||
247 | sub fastcwd_ { | ||||
248 | my($odev, $oino, $cdev, $cino, $tdev, $tino); | ||||
249 | my(@path, $path); | ||||
250 | local(*DIR); | ||||
251 | |||||
252 | my($orig_cdev, $orig_cino) = stat('.'); | ||||
253 | ($cdev, $cino) = ($orig_cdev, $orig_cino); | ||||
254 | for (;;) { | ||||
255 | my $direntry; | ||||
256 | ($odev, $oino) = ($cdev, $cino); | ||||
257 | CORE::chdir('..') || return undef; | ||||
258 | ($cdev, $cino) = stat('.'); | ||||
259 | last if $odev == $cdev && $oino eq $cino; | ||||
260 | opendir(DIR, '.') || return undef; | ||||
261 | for (;;) { | ||||
262 | $direntry = readdir(DIR); | ||||
263 | last unless defined $direntry; | ||||
264 | next if $direntry eq '.'; | ||||
265 | next if $direntry eq '..'; | ||||
266 | |||||
267 | ($tdev, $tino) = lstat($direntry); | ||||
268 | last unless $tdev != $odev || $tino ne $oino; | ||||
269 | } | ||||
270 | closedir(DIR); | ||||
271 | return undef unless defined $direntry; # should never happen | ||||
272 | unshift(@path, $direntry); | ||||
273 | } | ||||
274 | $path = '/' . join('/', @path); | ||||
275 | if ($^O eq 'apollo') { $path = "/".$path; } | ||||
276 | # At this point $path may be tainted (if tainting) and chdir would fail. | ||||
277 | # Untaint it then check that we landed where we started. | ||||
278 | $path =~ /^(.*)\z/s # untaint | ||||
279 | && CORE::chdir($1) or return undef; | ||||
280 | ($cdev, $cino) = stat('.'); | ||||
281 | die "Unstable directory path, current directory changed unexpectedly" | ||||
282 | if $cdev != $orig_cdev || $cino ne $orig_cino; | ||||
283 | $path; | ||||
284 | } | ||||
285 | 1 | 1µs | if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } | ||
286 | |||||
287 | |||||
288 | # Keeps track of current working directory in PWD environment var | ||||
289 | # Usage: | ||||
290 | # use Cwd 'chdir'; | ||||
291 | # chdir $newdir; | ||||
292 | |||||
293 | 1 | 0s | my $chdir_init = 0; | ||
294 | |||||
295 | sub chdir_init { | ||||
296 | if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { | ||||
297 | my($dd,$di) = stat('.'); | ||||
298 | my($pd,$pi) = stat($ENV{'PWD'}); | ||||
299 | if (!defined $dd or !defined $pd or $di ne $pi or $dd != $pd) { | ||||
300 | $ENV{'PWD'} = cwd(); | ||||
301 | } | ||||
302 | } | ||||
303 | else { | ||||
304 | my $wd = cwd(); | ||||
305 | $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; | ||||
306 | $ENV{'PWD'} = $wd; | ||||
307 | } | ||||
308 | # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) | ||||
309 | if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { | ||||
310 | my($pd,$pi) = stat($2); | ||||
311 | my($dd,$di) = stat($1); | ||||
312 | if (defined $pd and defined $dd and $di ne $pi and $dd == $pd) { | ||||
313 | $ENV{'PWD'}="$2$3"; | ||||
314 | } | ||||
315 | } | ||||
316 | $chdir_init = 1; | ||||
317 | } | ||||
318 | |||||
319 | sub chdir { | ||||
320 | my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) | ||||
321 | if ($^O eq "cygwin") { | ||||
322 | $newdir =~ s|\A///+|//|; | ||||
323 | $newdir =~ s|(?<=[^/])//+|/|g; | ||||
324 | } | ||||
325 | elsif ($^O ne 'MSWin32') { | ||||
326 | $newdir =~ s|///*|/|g; | ||||
327 | } | ||||
328 | chdir_init() unless $chdir_init; | ||||
329 | my $newpwd; | ||||
330 | if ($^O eq 'MSWin32') { | ||||
331 | # get the full path name *before* the chdir() | ||||
332 | $newpwd = Win32::GetFullPathName($newdir); | ||||
333 | } | ||||
334 | |||||
335 | return 0 unless CORE::chdir $newdir; | ||||
336 | |||||
337 | if ($^O eq 'VMS') { | ||||
338 | return $ENV{'PWD'} = $ENV{'DEFAULT'} | ||||
339 | } | ||||
340 | elsif ($^O eq 'MSWin32') { | ||||
341 | $ENV{'PWD'} = $newpwd; | ||||
342 | return 1; | ||||
343 | } | ||||
344 | |||||
345 | if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in | ||||
346 | $ENV{'PWD'} = cwd(); | ||||
347 | } elsif ($newdir =~ m#^/#s) { | ||||
348 | $ENV{'PWD'} = $newdir; | ||||
349 | } else { | ||||
350 | my @curdir = split(m#/#,$ENV{'PWD'}); | ||||
351 | @curdir = ('') unless @curdir; | ||||
352 | my $component; | ||||
353 | foreach $component (split(m#/#, $newdir)) { | ||||
354 | next if $component eq '.'; | ||||
355 | pop(@curdir),next if $component eq '..'; | ||||
356 | push(@curdir,$component); | ||||
357 | } | ||||
358 | $ENV{'PWD'} = join('/',@curdir) || '/'; | ||||
359 | } | ||||
360 | 1; | ||||
361 | } | ||||
362 | |||||
363 | |||||
364 | sub _perl_abs_path | ||||
365 | { | ||||
366 | my $start = @_ ? shift : '.'; | ||||
367 | my($dotdots, $cwd, @pst, @cst, $dir, @tst); | ||||
368 | |||||
369 | unless (@cst = stat( $start )) | ||||
370 | { | ||||
371 | return undef; | ||||
372 | } | ||||
373 | |||||
374 | unless (-d _) { | ||||
375 | # Make sure we can be invoked on plain files, not just directories. | ||||
376 | # NOTE that this routine assumes that '/' is the only directory separator. | ||||
377 | |||||
378 | my ($dir, $file) = $start =~ m{^(.*)/(.+)$} | ||||
379 | or return cwd() . '/' . $start; | ||||
380 | |||||
381 | # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). | ||||
382 | if (-l $start) { | ||||
383 | my $link_target = readlink($start); | ||||
384 | die "Can't resolve link $start: $!" unless defined $link_target; | ||||
385 | |||||
386 | require File::Spec; | ||||
387 | $link_target = $dir . '/' . $link_target | ||||
388 | unless File::Spec->file_name_is_absolute($link_target); | ||||
389 | |||||
390 | return abs_path($link_target); | ||||
391 | } | ||||
392 | |||||
393 | return $dir ? abs_path($dir) . "/$file" : "/$file"; | ||||
394 | } | ||||
395 | |||||
396 | $cwd = ''; | ||||
397 | $dotdots = $start; | ||||
398 | do | ||||
399 | { | ||||
400 | $dotdots .= '/..'; | ||||
401 | @pst = @cst; | ||||
402 | local *PARENT; | ||||
403 | unless (opendir(PARENT, $dotdots)) | ||||
404 | { | ||||
405 | return undef; | ||||
406 | } | ||||
407 | unless (@cst = stat($dotdots)) | ||||
408 | { | ||||
409 | my $e = $!; | ||||
410 | closedir(PARENT); | ||||
411 | $! = $e; | ||||
412 | return undef; | ||||
413 | } | ||||
414 | if ($pst[0] == $cst[0] && $pst[1] eq $cst[1]) | ||||
415 | { | ||||
416 | $dir = undef; | ||||
417 | } | ||||
418 | else | ||||
419 | { | ||||
420 | do | ||||
421 | { | ||||
422 | unless (defined ($dir = readdir(PARENT))) | ||||
423 | { | ||||
424 | closedir(PARENT); | ||||
425 | require Errno; | ||||
426 | $! = Errno::ENOENT(); | ||||
427 | return undef; | ||||
428 | } | ||||
429 | $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) | ||||
430 | } | ||||
431 | while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || | ||||
432 | $tst[1] ne $pst[1]); | ||||
433 | } | ||||
434 | $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; | ||||
435 | closedir(PARENT); | ||||
436 | } while (defined $dir); | ||||
437 | chop($cwd) unless $cwd eq '/'; # drop the trailing / | ||||
438 | $cwd; | ||||
439 | } | ||||
440 | |||||
441 | |||||
442 | 1 | 0s | my $Curdir; | ||
443 | sub fast_abs_path { | ||||
444 | local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage | ||||
445 | my $cwd = getcwd(); | ||||
446 | defined $cwd or return undef; | ||||
447 | require File::Spec; | ||||
448 | my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); | ||||
449 | |||||
450 | # Detaint else we'll explode in taint mode. This is safe because | ||||
451 | # we're not doing anything dangerous with it. | ||||
452 | ($path) = $path =~ /(.*)/s; | ||||
453 | ($cwd) = $cwd =~ /(.*)/s; | ||||
454 | |||||
455 | unless (-e $path) { | ||||
456 | require Errno; | ||||
457 | $! = Errno::ENOENT(); | ||||
458 | return undef; | ||||
459 | } | ||||
460 | |||||
461 | unless (-d _) { | ||||
462 | # Make sure we can be invoked on plain files, not just directories. | ||||
463 | |||||
464 | my ($vol, $dir, $file) = File::Spec->splitpath($path); | ||||
465 | return File::Spec->catfile($cwd, $path) unless length $dir; | ||||
466 | |||||
467 | if (-l $path) { | ||||
468 | my $link_target = readlink($path); | ||||
469 | defined $link_target or return undef; | ||||
470 | |||||
471 | $link_target = File::Spec->catpath($vol, $dir, $link_target) | ||||
472 | unless File::Spec->file_name_is_absolute($link_target); | ||||
473 | |||||
474 | return fast_abs_path($link_target); | ||||
475 | } | ||||
476 | |||||
477 | return $dir eq File::Spec->rootdir | ||||
478 | ? File::Spec->catpath($vol, $dir, $file) | ||||
479 | : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; | ||||
480 | } | ||||
481 | |||||
482 | if (!CORE::chdir($path)) { | ||||
483 | return undef; | ||||
484 | } | ||||
485 | my $realpath = getcwd(); | ||||
486 | if (! ((-d $cwd) && (CORE::chdir($cwd)))) { | ||||
487 | _croak("Cannot chdir back to $cwd: $!"); | ||||
488 | } | ||||
489 | $realpath; | ||||
490 | } | ||||
491 | |||||
492 | # added function alias to follow principle of least surprise | ||||
493 | # based on previous aliasing. --tchrist 27-Jan-00 | ||||
494 | 1 | 1µs | *fast_realpath = \&fast_abs_path; | ||
495 | |||||
496 | |||||
497 | # --- PORTING SECTION --- | ||||
498 | |||||
499 | # VMS: $ENV{'DEFAULT'} points to default directory at all times | ||||
500 | # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu | ||||
501 | # Note: Use of Cwd::chdir() causes the logical name PWD to be defined | ||||
502 | # in the process logical name table as the default device and directory | ||||
503 | # seen by Perl. This may not be the same as the default device | ||||
504 | # and directory seen by DCL after Perl exits, since the effects | ||||
505 | # the CRTL chdir() function persist only until Perl exits. | ||||
506 | |||||
507 | sub _vms_cwd { | ||||
508 | return $ENV{'DEFAULT'}; | ||||
509 | } | ||||
510 | |||||
511 | sub _vms_abs_path { | ||||
512 | return $ENV{'DEFAULT'} unless @_; | ||||
513 | my $path = shift; | ||||
514 | |||||
515 | my $efs = _vms_efs; | ||||
516 | my $unix_rpt = _vms_unix_rpt; | ||||
517 | |||||
518 | if (defined &VMS::Filespec::vmsrealpath) { | ||||
519 | my $path_unix = 0; | ||||
520 | my $path_vms = 0; | ||||
521 | |||||
522 | $path_unix = 1 if ($path =~ m#(?<=\^)/#); | ||||
523 | $path_unix = 1 if ($path =~ /^\.\.?$/); | ||||
524 | $path_vms = 1 if ($path =~ m#[\[<\]]#); | ||||
525 | $path_vms = 1 if ($path =~ /^--?$/); | ||||
526 | |||||
527 | my $unix_mode = $path_unix; | ||||
528 | if ($efs) { | ||||
529 | # In case of a tie, the Unix report mode decides. | ||||
530 | if ($path_vms == $path_unix) { | ||||
531 | $unix_mode = $unix_rpt; | ||||
532 | } else { | ||||
533 | $unix_mode = 0 if $path_vms; | ||||
534 | } | ||||
535 | } | ||||
536 | |||||
537 | if ($unix_mode) { | ||||
538 | # Unix format | ||||
539 | return VMS::Filespec::unixrealpath($path); | ||||
540 | } | ||||
541 | |||||
542 | # VMS format | ||||
543 | |||||
544 | my $new_path = VMS::Filespec::vmsrealpath($path); | ||||
545 | |||||
546 | # Perl expects directories to be in directory format | ||||
547 | $new_path = VMS::Filespec::pathify($new_path) if -d $path; | ||||
548 | return $new_path; | ||||
549 | } | ||||
550 | |||||
551 | # Fallback to older algorithm if correct ones are not | ||||
552 | # available. | ||||
553 | |||||
554 | if (-l $path) { | ||||
555 | my $link_target = readlink($path); | ||||
556 | die "Can't resolve link $path: $!" unless defined $link_target; | ||||
557 | |||||
558 | return _vms_abs_path($link_target); | ||||
559 | } | ||||
560 | |||||
561 | # may need to turn foo.dir into [.foo] | ||||
562 | my $pathified = VMS::Filespec::pathify($path); | ||||
563 | $path = $pathified if defined $pathified; | ||||
564 | |||||
565 | return VMS::Filespec::rmsexpand($path); | ||||
566 | } | ||||
567 | |||||
568 | sub _os2_cwd { | ||||
569 | my $pwd = `cmd /c cd`; | ||||
570 | chomp $pwd; | ||||
571 | $pwd =~ s:\\:/:g ; | ||||
572 | $ENV{'PWD'} = $pwd; | ||||
573 | return $pwd; | ||||
574 | } | ||||
575 | |||||
576 | sub _win32_cwd_simple { | ||||
577 | my $pwd = `cd`; | ||||
578 | chomp $pwd; | ||||
579 | $pwd =~ s:\\:/:g ; | ||||
580 | $ENV{'PWD'} = $pwd; | ||||
581 | return $pwd; | ||||
582 | } | ||||
583 | |||||
584 | sub _win32_cwd { | ||||
585 | my $pwd; | ||||
586 | $pwd = Win32::GetCwd(); | ||||
587 | $pwd =~ s:\\:/:g ; | ||||
588 | $ENV{'PWD'} = $pwd; | ||||
589 | return $pwd; | ||||
590 | } | ||||
591 | |||||
592 | 1 | 1µs | *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple; | ||
593 | |||||
594 | sub _dos_cwd { | ||||
595 | my $pwd; | ||||
596 | if (!defined &Dos::GetCwd) { | ||||
597 | chomp($pwd = `command /c cd`); | ||||
598 | $pwd =~ s:\\:/:g ; | ||||
599 | } else { | ||||
600 | $pwd = Dos::GetCwd(); | ||||
601 | } | ||||
602 | $ENV{'PWD'} = $pwd; | ||||
603 | return $pwd; | ||||
604 | } | ||||
605 | |||||
606 | sub _qnx_cwd { | ||||
607 | local $ENV{PATH} = ''; | ||||
608 | local $ENV{CDPATH} = ''; | ||||
609 | local $ENV{ENV} = ''; | ||||
610 | my $pwd = `/usr/bin/fullpath -t`; | ||||
611 | chomp $pwd; | ||||
612 | $ENV{'PWD'} = $pwd; | ||||
613 | return $pwd; | ||||
614 | } | ||||
615 | |||||
616 | sub _qnx_abs_path { | ||||
617 | local $ENV{PATH} = ''; | ||||
618 | local $ENV{CDPATH} = ''; | ||||
619 | local $ENV{ENV} = ''; | ||||
620 | my $path = @_ ? shift : '.'; | ||||
621 | local *REALPATH; | ||||
622 | |||||
623 | defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or | ||||
624 | die "Can't open /usr/bin/fullpath: $!"; | ||||
625 | my $realpath = <REALPATH>; | ||||
626 | close REALPATH; | ||||
627 | chomp $realpath; | ||||
628 | return $realpath; | ||||
629 | } | ||||
630 | |||||
631 | # Now that all the base-level functions are set up, alias the | ||||
632 | # user-level functions to the right places | ||||
633 | |||||
634 | 1 | 2µs | if (exists $METHOD_MAP{$^O}) { | ||
635 | 1 | 0s | my $map = $METHOD_MAP{$^O}; | ||
636 | 1 | 2µs | foreach my $name (keys %$map) { | ||
637 | local $^W = 0; # assignments trigger 'subroutine redefined' warning | ||||
638 | 2 | 264µs | 2 | 66µs | # spent 42µs (18+24) within Cwd::BEGIN@638 which was called:
# once (18µs+24µs) by File::Spec::Unix::BEGIN@4 at line 638 # spent 42µs making 1 call to Cwd::BEGIN@638
# spent 24µs making 1 call to strict::unimport |
639 | *{$name} = \&{$map->{$name}}; | ||||
640 | } | ||||
641 | } | ||||
642 | |||||
643 | # built-in from 5.30 | ||||
644 | 1 | 1µs | *getcwd = \&Internals::getcwd | ||
645 | if !defined &getcwd && defined &Internals::getcwd; | ||||
646 | |||||
647 | # In case the XS version doesn't load. | ||||
648 | 1 | 0s | *abs_path = \&_perl_abs_path unless defined &abs_path; | ||
649 | 1 | 0s | *getcwd = \&_perl_getcwd unless defined &getcwd; | ||
650 | |||||
651 | # added function alias for those of us more | ||||
652 | # used to the libc function. --tchrist 27-Jan-00 | ||||
653 | 1 | 0s | *realpath = \&abs_path; | ||
654 | |||||
655 | 1 | 57µs | 1; | ||
656 | __END__ | ||||
# spent 52µs within Cwd::CORE:fteexec which was called:
# once (52µs+0s) by File::Spec::Unix::BEGIN@4 at line 159 | |||||
# spent 2µs within Cwd::CORE:match which was called:
# once (2µs+0s) by File::Spec::Unix::BEGIN@4 at line 171 |