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