Filename | /usr/lib64/perl5/vendor_perl/5.16.0/x86_64-linux/Cwd.pm |
Statements | Executed 52 statements in 73.9ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
16310 | 5 | 2 | 1.29s | 1.29s | abs_path (xsub) | Cwd::
1 | 1 | 1 | 2.46ms | 4.94ms | BEGIN@172 | Cwd::
1 | 1 | 1 | 93µs | 192µs | BEGIN@170 | Cwd::
1 | 1 | 1 | 70µs | 186µs | BEGIN@171 | Cwd::
1 | 1 | 1 | 63µs | 158µs | BEGIN@823 | Cwd::
1 | 1 | 1 | 49µs | 49µs | CORE:fteexec (opcode) | Cwd::
1 | 1 | 1 | 33µs | 33µs | CORE:regcomp (opcode) | Cwd::
1 | 1 | 1 | 31µs | 31µs | BEGIN@209 | Cwd::
1 | 1 | 1 | 23µs | 23µs | getcwd (xsub) | Cwd::
0 | 0 | 0 | 0s | 0s | __ANON__[:403] | 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 | _epoc_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 | |||||
3 | =head1 NAME | ||||
4 | |||||
5 | Cwd - get pathname of current working directory | ||||
6 | |||||
7 | =head1 SYNOPSIS | ||||
8 | |||||
9 | use Cwd; | ||||
10 | my $dir = getcwd; | ||||
11 | |||||
12 | use Cwd 'abs_path'; | ||||
13 | my $abs_path = abs_path($file); | ||||
14 | |||||
15 | =head1 DESCRIPTION | ||||
16 | |||||
17 | This module provides functions for determining the pathname of the | ||||
18 | current working directory. It is recommended that getcwd (or another | ||||
19 | *cwd() function) be used in I<all> code to ensure portability. | ||||
20 | |||||
21 | By default, it exports the functions cwd(), getcwd(), fastcwd(), and | ||||
22 | fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. | ||||
23 | |||||
24 | |||||
25 | =head2 getcwd and friends | ||||
26 | |||||
27 | Each of these functions are called without arguments and return the | ||||
28 | absolute path of the current working directory. | ||||
29 | |||||
30 | =over 4 | ||||
31 | |||||
32 | =item getcwd | ||||
33 | |||||
34 | my $cwd = getcwd(); | ||||
35 | |||||
36 | Returns the current working directory. | ||||
37 | |||||
38 | Exposes the POSIX function getcwd(3) or re-implements it if it's not | ||||
39 | available. | ||||
40 | |||||
41 | =item cwd | ||||
42 | |||||
43 | my $cwd = cwd(); | ||||
44 | |||||
45 | The cwd() is the most natural form for the current architecture. For | ||||
46 | most systems it is identical to `pwd` (but without the trailing line | ||||
47 | terminator). | ||||
48 | |||||
49 | =item fastcwd | ||||
50 | |||||
51 | my $cwd = fastcwd(); | ||||
52 | |||||
53 | A more dangerous version of getcwd(), but potentially faster. | ||||
54 | |||||
55 | It might conceivably chdir() you out of a directory that it can't | ||||
56 | chdir() you back into. If fastcwd encounters a problem it will return | ||||
57 | undef but will probably leave you in a different directory. For a | ||||
58 | measure of extra security, if everything appears to have worked, the | ||||
59 | fastcwd() function will check that it leaves you in the same directory | ||||
60 | that it started in. If it has changed it will C<die> with the message | ||||
61 | "Unstable directory path, current directory changed | ||||
62 | unexpectedly". That should never happen. | ||||
63 | |||||
64 | =item fastgetcwd | ||||
65 | |||||
66 | my $cwd = fastgetcwd(); | ||||
67 | |||||
68 | The fastgetcwd() function is provided as a synonym for cwd(). | ||||
69 | |||||
70 | =item getdcwd | ||||
71 | |||||
72 | my $cwd = getdcwd(); | ||||
73 | my $cwd = getdcwd('C:'); | ||||
74 | |||||
75 | The getdcwd() function is also provided on Win32 to get the current working | ||||
76 | directory on the specified drive, since Windows maintains a separate current | ||||
77 | working directory for each drive. If no drive is specified then the current | ||||
78 | drive is assumed. | ||||
79 | |||||
80 | This function simply calls the Microsoft C library _getdcwd() function. | ||||
81 | |||||
82 | =back | ||||
83 | |||||
84 | |||||
85 | =head2 abs_path and friends | ||||
86 | |||||
87 | These functions are exported only on request. They each take a single | ||||
88 | argument and return the absolute pathname for it. If no argument is | ||||
89 | given they'll use the current working directory. | ||||
90 | |||||
91 | =over 4 | ||||
92 | |||||
93 | =item abs_path | ||||
94 | |||||
95 | my $abs_path = abs_path($file); | ||||
96 | |||||
97 | Uses the same algorithm as getcwd(). Symbolic links and relative-path | ||||
98 | components ("." and "..") are resolved to return the canonical | ||||
99 | pathname, just like realpath(3). | ||||
100 | |||||
101 | =item realpath | ||||
102 | |||||
103 | my $abs_path = realpath($file); | ||||
104 | |||||
105 | A synonym for abs_path(). | ||||
106 | |||||
107 | =item fast_abs_path | ||||
108 | |||||
109 | my $abs_path = fast_abs_path($file); | ||||
110 | |||||
111 | A more dangerous, but potentially faster version of abs_path. | ||||
112 | |||||
113 | =back | ||||
114 | |||||
115 | =head2 $ENV{PWD} | ||||
116 | |||||
117 | If you ask to override your chdir() built-in function, | ||||
118 | |||||
119 | use Cwd qw(chdir); | ||||
120 | |||||
121 | then your PWD environment variable will be kept up to date. Note that | ||||
122 | it will only be kept up to date if all packages which use chdir import | ||||
123 | it from Cwd. | ||||
124 | |||||
125 | |||||
126 | =head1 NOTES | ||||
127 | |||||
128 | =over 4 | ||||
129 | |||||
130 | =item * | ||||
131 | |||||
132 | Since the path separators are different on some operating systems ('/' | ||||
133 | on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec | ||||
134 | modules wherever portability is a concern. | ||||
135 | |||||
136 | =item * | ||||
137 | |||||
138 | Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()> | ||||
139 | functions are all aliases for the C<cwd()> function, which, on Mac OS, | ||||
140 | calls `pwd`. Likewise, the C<abs_path()> function is an alias for | ||||
141 | C<fast_abs_path()>. | ||||
142 | |||||
143 | =back | ||||
144 | |||||
145 | =head1 AUTHOR | ||||
146 | |||||
147 | Originally by the perl5-porters. | ||||
148 | |||||
149 | Maintained by Ken Williams <KWILLIAMS@cpan.org> | ||||
150 | |||||
151 | =head1 COPYRIGHT | ||||
152 | |||||
153 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. | ||||
154 | |||||
155 | This program is free software; you can redistribute it and/or modify | ||||
156 | it under the same terms as Perl itself. | ||||
157 | |||||
158 | Portions of the C code in this library are copyright (c) 1994 by the | ||||
159 | Regents of the University of California. All rights reserved. The | ||||
160 | license on this code is compatible with the licensing of the rest of | ||||
161 | the distribution - please see the source code in F<Cwd.xs> for the | ||||
162 | details. | ||||
163 | |||||
164 | =head1 SEE ALSO | ||||
165 | |||||
166 | L<File::chdir> | ||||
167 | |||||
168 | =cut | ||||
169 | |||||
170 | 2 | 149µs | 2 | 292µs | # spent 192µs (93+99) within Cwd::BEGIN@170 which was called:
# once (93µs+99µs) by FindBin::BEGIN@83 at line 170 # spent 192µs making 1 call to Cwd::BEGIN@170
# spent 99µs making 1 call to strict::import |
171 | 2 | 159µs | 2 | 302µs | # spent 186µs (70+116) within Cwd::BEGIN@171 which was called:
# once (70µs+116µs) by FindBin::BEGIN@83 at line 171 # spent 186µs making 1 call to Cwd::BEGIN@171
# spent 116µs making 1 call to Exporter::import |
172 | 2 | 1.63ms | 2 | 5.33ms | # spent 4.94ms (2.46+2.48) within Cwd::BEGIN@172 which was called:
# once (2.46ms+2.48ms) by FindBin::BEGIN@83 at line 172 # spent 4.94ms making 1 call to Cwd::BEGIN@172
# spent 386µs making 1 call to vars::import |
173 | |||||
174 | 1 | 4µs | $VERSION = '3.40'; | ||
175 | 1 | 2µs | my $xs_version = $VERSION; | ||
176 | 1 | 14µs | $VERSION =~ tr/_//; | ||
177 | |||||
178 | 1 | 41µs | @ISA = qw/ Exporter /; | ||
179 | 1 | 7µs | @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); | ||
180 | 1 | 6µs | push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; | ||
181 | 1 | 7µs | @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); | ||
182 | |||||
183 | # sys_cwd may keep the builtin command | ||||
184 | |||||
185 | # All the functionality of this module may provided by builtins, | ||||
186 | # there is no sense to process the rest of the file. | ||||
187 | # The best choice may be to have this in BEGIN, but how to return from BEGIN? | ||||
188 | |||||
189 | 1 | 2µs | if ($^O eq 'os2') { | ||
190 | local $^W = 0; | ||||
191 | |||||
192 | *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; | ||||
193 | *getcwd = \&cwd; | ||||
194 | *fastgetcwd = \&cwd; | ||||
195 | *fastcwd = \&cwd; | ||||
196 | |||||
197 | *fast_abs_path = \&sys_abspath if defined &sys_abspath; | ||||
198 | *abs_path = \&fast_abs_path; | ||||
199 | *realpath = \&fast_abs_path; | ||||
200 | *fast_realpath = \&fast_abs_path; | ||||
201 | |||||
202 | return 1; | ||||
203 | } | ||||
204 | |||||
205 | # Need to look up the feature settings on VMS. The preferred way is to use the | ||||
206 | # VMS::Feature module, but that may not be available to dual life modules. | ||||
207 | |||||
208 | 1 | 700ns | my $use_vms_feature; | ||
209 | # spent 31µs within Cwd::BEGIN@209 which was called:
# once (31µs+0s) by FindBin::BEGIN@83 at line 215 | ||||
210 | 1 | 34µs | if ($^O eq 'VMS') { | ||
211 | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { | ||||
212 | $use_vms_feature = 1; | ||||
213 | } | ||||
214 | } | ||||
215 | 1 | 15.2ms | 1 | 31µs | } # spent 31µs making 1 call to Cwd::BEGIN@209 |
216 | |||||
217 | # Need to look up the UNIX report mode. This may become a dynamic mode | ||||
218 | # in the future. | ||||
219 | sub _vms_unix_rpt { | ||||
220 | my $unix_rpt; | ||||
221 | if ($use_vms_feature) { | ||||
222 | $unix_rpt = VMS::Feature::current("filename_unix_report"); | ||||
223 | } else { | ||||
224 | my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; | ||||
225 | $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; | ||||
226 | } | ||||
227 | return $unix_rpt; | ||||
228 | } | ||||
229 | |||||
230 | # Need to look up the EFS character set mode. This may become a dynamic | ||||
231 | # mode in the future. | ||||
232 | sub _vms_efs { | ||||
233 | my $efs; | ||||
234 | if ($use_vms_feature) { | ||||
235 | $efs = VMS::Feature::current("efs_charset"); | ||||
236 | } else { | ||||
237 | my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; | ||||
238 | $efs = $env_efs =~ /^[ET1]/i; | ||||
239 | } | ||||
240 | return $efs; | ||||
241 | } | ||||
242 | |||||
243 | |||||
244 | # If loading the XS stuff doesn't work, we can fall back to pure perl | ||||
245 | 1 | 12µs | eval { | ||
246 | 1 | 10µs | if ( $] >= 5.006 ) { | ||
247 | 1 | 3µs | require XSLoader; | ||
248 | 1 | 55.4ms | 1 | 55.3ms | XSLoader::load( __PACKAGE__, $xs_version); # spent 55.3ms making 1 call to XSLoader::load |
249 | } else { | ||||
250 | require DynaLoader; | ||||
251 | push @ISA, 'DynaLoader'; | ||||
252 | __PACKAGE__->bootstrap( $xs_version ); | ||||
253 | } | ||||
254 | }; | ||||
255 | |||||
256 | # Big nasty table of function aliases | ||||
257 | 1 | 68µs | my %METHOD_MAP = | ||
258 | ( | ||||
259 | VMS => | ||||
260 | { | ||||
261 | cwd => '_vms_cwd', | ||||
262 | getcwd => '_vms_cwd', | ||||
263 | fastcwd => '_vms_cwd', | ||||
264 | fastgetcwd => '_vms_cwd', | ||||
265 | abs_path => '_vms_abs_path', | ||||
266 | fast_abs_path => '_vms_abs_path', | ||||
267 | }, | ||||
268 | |||||
269 | MSWin32 => | ||||
270 | { | ||||
271 | # We assume that &_NT_cwd is defined as an XSUB or in the core. | ||||
272 | cwd => '_NT_cwd', | ||||
273 | getcwd => '_NT_cwd', | ||||
274 | fastcwd => '_NT_cwd', | ||||
275 | fastgetcwd => '_NT_cwd', | ||||
276 | abs_path => 'fast_abs_path', | ||||
277 | realpath => 'fast_abs_path', | ||||
278 | }, | ||||
279 | |||||
280 | dos => | ||||
281 | { | ||||
282 | cwd => '_dos_cwd', | ||||
283 | getcwd => '_dos_cwd', | ||||
284 | fastgetcwd => '_dos_cwd', | ||||
285 | fastcwd => '_dos_cwd', | ||||
286 | abs_path => 'fast_abs_path', | ||||
287 | }, | ||||
288 | |||||
289 | # QNX4. QNX6 has a $os of 'nto'. | ||||
290 | qnx => | ||||
291 | { | ||||
292 | cwd => '_qnx_cwd', | ||||
293 | getcwd => '_qnx_cwd', | ||||
294 | fastgetcwd => '_qnx_cwd', | ||||
295 | fastcwd => '_qnx_cwd', | ||||
296 | abs_path => '_qnx_abs_path', | ||||
297 | fast_abs_path => '_qnx_abs_path', | ||||
298 | }, | ||||
299 | |||||
300 | cygwin => | ||||
301 | { | ||||
302 | getcwd => 'cwd', | ||||
303 | fastgetcwd => 'cwd', | ||||
304 | fastcwd => 'cwd', | ||||
305 | abs_path => 'fast_abs_path', | ||||
306 | realpath => 'fast_abs_path', | ||||
307 | }, | ||||
308 | |||||
309 | epoc => | ||||
310 | { | ||||
311 | cwd => '_epoc_cwd', | ||||
312 | getcwd => '_epoc_cwd', | ||||
313 | fastgetcwd => '_epoc_cwd', | ||||
314 | fastcwd => '_epoc_cwd', | ||||
315 | abs_path => 'fast_abs_path', | ||||
316 | }, | ||||
317 | |||||
318 | MacOS => | ||||
319 | { | ||||
320 | getcwd => 'cwd', | ||||
321 | fastgetcwd => 'cwd', | ||||
322 | fastcwd => 'cwd', | ||||
323 | abs_path => 'fast_abs_path', | ||||
324 | }, | ||||
325 | ); | ||||
326 | |||||
327 | 1 | 4µs | $METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; | ||
328 | |||||
329 | |||||
330 | # Find the pwd command in the expected locations. We assume these | ||||
331 | # are safe. This prevents _backtick_pwd() consulting $ENV{PATH} | ||||
332 | # so everything works under taint mode. | ||||
333 | 1 | 1µs | my $pwd_cmd; | ||
334 | 1 | 5µs | foreach my $try ('/bin/pwd', | ||
335 | '/usr/bin/pwd', | ||||
336 | '/QOpenSys/bin/pwd', # OS/400 PASE. | ||||
337 | ) { | ||||
338 | |||||
339 | 1 | 82µs | 1 | 49µs | if( -x $try ) { # spent 49µs making 1 call to Cwd::CORE:fteexec |
340 | 1 | 3µs | $pwd_cmd = $try; | ||
341 | 1 | 14µs | last; | ||
342 | } | ||||
343 | } | ||||
344 | 1 | 4µs | my $found_pwd_cmd = defined($pwd_cmd); | ||
345 | 1 | 900ns | unless ($pwd_cmd) { | ||
346 | # Isn't this wrong? _backtick_pwd() will fail if somenone has | ||||
347 | # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? | ||||
348 | # See [perl #16774]. --jhi | ||||
349 | $pwd_cmd = 'pwd'; | ||||
350 | } | ||||
351 | |||||
352 | # Lazy-load Carp | ||||
353 | sub _carp { require Carp; Carp::carp(@_) } | ||||
354 | sub _croak { require Carp; Carp::croak(@_) } | ||||
355 | |||||
356 | # The 'natural and safe form' for UNIX (pwd may be setuid root) | ||||
357 | sub _backtick_pwd { | ||||
358 | # Localize %ENV entries in a way that won't create new hash keys | ||||
359 | my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); | ||||
360 | local @ENV{@localize}; | ||||
361 | |||||
362 | my $cwd = `$pwd_cmd`; | ||||
363 | # Belt-and-suspenders in case someone said "undef $/". | ||||
364 | local $/ = "\n"; | ||||
365 | # `pwd` may fail e.g. if the disk is full | ||||
366 | chomp($cwd) if defined $cwd; | ||||
367 | $cwd; | ||||
368 | } | ||||
369 | |||||
370 | # Since some ports may predefine cwd internally (e.g., NT) | ||||
371 | # we take care not to override an existing definition for cwd(). | ||||
372 | |||||
373 | 1 | 18µs | unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { | ||
374 | # The pwd command is not available in some chroot(2)'ed environments | ||||
375 | 1 | 5µs | my $sep = $Config::Config{path_sep} || ':'; | ||
376 | 1 | 5µs | my $os = $^O; # Protect $^O from tainting | ||
377 | |||||
378 | |||||
379 | # Try again to find a pwd, this time searching the whole PATH. | ||||
380 | 1 | 6µs | if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows | ||
381 | 1 | 77µs | 1 | 33µs | my @candidates = split($sep, $ENV{PATH}); # spent 33µs making 1 call to Cwd::CORE:regcomp |
382 | 1 | 8µs | while (!$found_pwd_cmd and @candidates) { | ||
383 | my $candidate = shift @candidates; | ||||
384 | $found_pwd_cmd = 1 if -x "$candidate/pwd"; | ||||
385 | } | ||||
386 | } | ||||
387 | |||||
388 | # MacOS has some special magic to make `pwd` work. | ||||
389 | 1 | 11µs | if( $os eq 'MacOS' || $found_pwd_cmd ) | ||
390 | { | ||||
391 | *cwd = \&_backtick_pwd; | ||||
392 | } | ||||
393 | else { | ||||
394 | *cwd = \&getcwd; | ||||
395 | } | ||||
396 | } | ||||
397 | |||||
398 | 1 | 4µs | if ($^O eq 'cygwin') { | ||
399 | # We need to make sure cwd() is called with no args, because it's | ||||
400 | # got an arg-less prototype and will die if args are present. | ||||
401 | local $^W = 0; | ||||
402 | my $orig_cwd = \&cwd; | ||||
403 | *cwd = sub { &$orig_cwd() } | ||||
404 | } | ||||
405 | |||||
406 | |||||
407 | # set a reasonable (and very safe) default for fastgetcwd, in case it | ||||
408 | # isn't redefined later (20001212 rspier) | ||||
409 | 1 | 5µs | *fastgetcwd = \&cwd; | ||
410 | |||||
411 | # A non-XS version of getcwd() - also used to bootstrap the perl build | ||||
412 | # process, when miniperl is running and no XS loading happens. | ||||
413 | sub _perl_getcwd | ||||
414 | { | ||||
415 | abs_path('.'); | ||||
416 | } | ||||
417 | |||||
418 | # By John Bazik | ||||
419 | # | ||||
420 | # Usage: $cwd = &fastcwd; | ||||
421 | # | ||||
422 | # This is a faster version of getcwd. It's also more dangerous because | ||||
423 | # you might chdir out of a directory that you can't chdir back into. | ||||
424 | |||||
425 | sub fastcwd_ { | ||||
426 | my($odev, $oino, $cdev, $cino, $tdev, $tino); | ||||
427 | my(@path, $path); | ||||
428 | local(*DIR); | ||||
429 | |||||
430 | my($orig_cdev, $orig_cino) = stat('.'); | ||||
431 | ($cdev, $cino) = ($orig_cdev, $orig_cino); | ||||
432 | for (;;) { | ||||
433 | my $direntry; | ||||
434 | ($odev, $oino) = ($cdev, $cino); | ||||
435 | CORE::chdir('..') || return undef; | ||||
436 | ($cdev, $cino) = stat('.'); | ||||
437 | last if $odev == $cdev && $oino == $cino; | ||||
438 | opendir(DIR, '.') || return undef; | ||||
439 | for (;;) { | ||||
440 | $direntry = readdir(DIR); | ||||
441 | last unless defined $direntry; | ||||
442 | next if $direntry eq '.'; | ||||
443 | next if $direntry eq '..'; | ||||
444 | |||||
445 | ($tdev, $tino) = lstat($direntry); | ||||
446 | last unless $tdev != $odev || $tino != $oino; | ||||
447 | } | ||||
448 | closedir(DIR); | ||||
449 | return undef unless defined $direntry; # should never happen | ||||
450 | unshift(@path, $direntry); | ||||
451 | } | ||||
452 | $path = '/' . join('/', @path); | ||||
453 | if ($^O eq 'apollo') { $path = "/".$path; } | ||||
454 | # At this point $path may be tainted (if tainting) and chdir would fail. | ||||
455 | # Untaint it then check that we landed where we started. | ||||
456 | $path =~ /^(.*)\z/s # untaint | ||||
457 | && CORE::chdir($1) or return undef; | ||||
458 | ($cdev, $cino) = stat('.'); | ||||
459 | die "Unstable directory path, current directory changed unexpectedly" | ||||
460 | if $cdev != $orig_cdev || $cino != $orig_cino; | ||||
461 | $path; | ||||
462 | } | ||||
463 | 1 | 2µs | if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } | ||
464 | |||||
465 | |||||
466 | # Keeps track of current working directory in PWD environment var | ||||
467 | # Usage: | ||||
468 | # use Cwd 'chdir'; | ||||
469 | # chdir $newdir; | ||||
470 | |||||
471 | 1 | 2µs | my $chdir_init = 0; | ||
472 | |||||
473 | sub chdir_init { | ||||
474 | if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { | ||||
475 | my($dd,$di) = stat('.'); | ||||
476 | my($pd,$pi) = stat($ENV{'PWD'}); | ||||
477 | if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { | ||||
478 | $ENV{'PWD'} = cwd(); | ||||
479 | } | ||||
480 | } | ||||
481 | else { | ||||
482 | my $wd = cwd(); | ||||
483 | $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; | ||||
484 | $ENV{'PWD'} = $wd; | ||||
485 | } | ||||
486 | # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) | ||||
487 | if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { | ||||
488 | my($pd,$pi) = stat($2); | ||||
489 | my($dd,$di) = stat($1); | ||||
490 | if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { | ||||
491 | $ENV{'PWD'}="$2$3"; | ||||
492 | } | ||||
493 | } | ||||
494 | $chdir_init = 1; | ||||
495 | } | ||||
496 | |||||
497 | sub chdir { | ||||
498 | my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) | ||||
499 | $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; | ||||
500 | chdir_init() unless $chdir_init; | ||||
501 | my $newpwd; | ||||
502 | if ($^O eq 'MSWin32') { | ||||
503 | # get the full path name *before* the chdir() | ||||
504 | $newpwd = Win32::GetFullPathName($newdir); | ||||
505 | } | ||||
506 | |||||
507 | return 0 unless CORE::chdir $newdir; | ||||
508 | |||||
509 | if ($^O eq 'VMS') { | ||||
510 | return $ENV{'PWD'} = $ENV{'DEFAULT'} | ||||
511 | } | ||||
512 | elsif ($^O eq 'MacOS') { | ||||
513 | return $ENV{'PWD'} = cwd(); | ||||
514 | } | ||||
515 | elsif ($^O eq 'MSWin32') { | ||||
516 | $ENV{'PWD'} = $newpwd; | ||||
517 | return 1; | ||||
518 | } | ||||
519 | |||||
520 | if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in | ||||
521 | $ENV{'PWD'} = cwd(); | ||||
522 | } elsif ($newdir =~ m#^/#s) { | ||||
523 | $ENV{'PWD'} = $newdir; | ||||
524 | } else { | ||||
525 | my @curdir = split(m#/#,$ENV{'PWD'}); | ||||
526 | @curdir = ('') unless @curdir; | ||||
527 | my $component; | ||||
528 | foreach $component (split(m#/#, $newdir)) { | ||||
529 | next if $component eq '.'; | ||||
530 | pop(@curdir),next if $component eq '..'; | ||||
531 | push(@curdir,$component); | ||||
532 | } | ||||
533 | $ENV{'PWD'} = join('/',@curdir) || '/'; | ||||
534 | } | ||||
535 | 1; | ||||
536 | } | ||||
537 | |||||
538 | |||||
539 | sub _perl_abs_path | ||||
540 | { | ||||
541 | my $start = @_ ? shift : '.'; | ||||
542 | my($dotdots, $cwd, @pst, @cst, $dir, @tst); | ||||
543 | |||||
544 | unless (@cst = stat( $start )) | ||||
545 | { | ||||
546 | _carp("stat($start): $!"); | ||||
547 | return ''; | ||||
548 | } | ||||
549 | |||||
550 | unless (-d _) { | ||||
551 | # Make sure we can be invoked on plain files, not just directories. | ||||
552 | # NOTE that this routine assumes that '/' is the only directory separator. | ||||
553 | |||||
554 | my ($dir, $file) = $start =~ m{^(.*)/(.+)$} | ||||
555 | or return cwd() . '/' . $start; | ||||
556 | |||||
557 | # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). | ||||
558 | if (-l $start) { | ||||
559 | my $link_target = readlink($start); | ||||
560 | die "Can't resolve link $start: $!" unless defined $link_target; | ||||
561 | |||||
562 | require File::Spec; | ||||
563 | $link_target = $dir . '/' . $link_target | ||||
564 | unless File::Spec->file_name_is_absolute($link_target); | ||||
565 | |||||
566 | return abs_path($link_target); | ||||
567 | } | ||||
568 | |||||
569 | return $dir ? abs_path($dir) . "/$file" : "/$file"; | ||||
570 | } | ||||
571 | |||||
572 | $cwd = ''; | ||||
573 | $dotdots = $start; | ||||
574 | do | ||||
575 | { | ||||
576 | $dotdots .= '/..'; | ||||
577 | @pst = @cst; | ||||
578 | local *PARENT; | ||||
579 | unless (opendir(PARENT, $dotdots)) | ||||
580 | { | ||||
581 | # probably a permissions issue. Try the native command. | ||||
582 | require File::Spec; | ||||
583 | return File::Spec->rel2abs( $start, _backtick_pwd() ); | ||||
584 | } | ||||
585 | unless (@cst = stat($dotdots)) | ||||
586 | { | ||||
587 | _carp("stat($dotdots): $!"); | ||||
588 | closedir(PARENT); | ||||
589 | return ''; | ||||
590 | } | ||||
591 | if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) | ||||
592 | { | ||||
593 | $dir = undef; | ||||
594 | } | ||||
595 | else | ||||
596 | { | ||||
597 | do | ||||
598 | { | ||||
599 | unless (defined ($dir = readdir(PARENT))) | ||||
600 | { | ||||
601 | _carp("readdir($dotdots): $!"); | ||||
602 | closedir(PARENT); | ||||
603 | return ''; | ||||
604 | } | ||||
605 | $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) | ||||
606 | } | ||||
607 | while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || | ||||
608 | $tst[1] != $pst[1]); | ||||
609 | } | ||||
610 | $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; | ||||
611 | closedir(PARENT); | ||||
612 | } while (defined $dir); | ||||
613 | chop($cwd) unless $cwd eq '/'; # drop the trailing / | ||||
614 | $cwd; | ||||
615 | } | ||||
616 | |||||
617 | |||||
618 | 1 | 1µs | my $Curdir; | ||
619 | sub fast_abs_path { | ||||
620 | local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage | ||||
621 | my $cwd = getcwd(); | ||||
622 | require File::Spec; | ||||
623 | my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); | ||||
624 | |||||
625 | # Detaint else we'll explode in taint mode. This is safe because | ||||
626 | # we're not doing anything dangerous with it. | ||||
627 | ($path) = $path =~ /(.*)/s; | ||||
628 | ($cwd) = $cwd =~ /(.*)/s; | ||||
629 | |||||
630 | unless (-e $path) { | ||||
631 | _croak("$path: No such file or directory"); | ||||
632 | } | ||||
633 | |||||
634 | unless (-d _) { | ||||
635 | # Make sure we can be invoked on plain files, not just directories. | ||||
636 | |||||
637 | my ($vol, $dir, $file) = File::Spec->splitpath($path); | ||||
638 | return File::Spec->catfile($cwd, $path) unless length $dir; | ||||
639 | |||||
640 | if (-l $path) { | ||||
641 | my $link_target = readlink($path); | ||||
642 | die "Can't resolve link $path: $!" unless defined $link_target; | ||||
643 | |||||
644 | $link_target = File::Spec->catpath($vol, $dir, $link_target) | ||||
645 | unless File::Spec->file_name_is_absolute($link_target); | ||||
646 | |||||
647 | return fast_abs_path($link_target); | ||||
648 | } | ||||
649 | |||||
650 | return $dir eq File::Spec->rootdir | ||||
651 | ? File::Spec->catpath($vol, $dir, $file) | ||||
652 | : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; | ||||
653 | } | ||||
654 | |||||
655 | if (!CORE::chdir($path)) { | ||||
656 | _croak("Cannot chdir to $path: $!"); | ||||
657 | } | ||||
658 | my $realpath = getcwd(); | ||||
659 | if (! ((-d $cwd) && (CORE::chdir($cwd)))) { | ||||
660 | _croak("Cannot chdir back to $cwd: $!"); | ||||
661 | } | ||||
662 | $realpath; | ||||
663 | } | ||||
664 | |||||
665 | # added function alias to follow principle of least surprise | ||||
666 | # based on previous aliasing. --tchrist 27-Jan-00 | ||||
667 | 1 | 3µs | *fast_realpath = \&fast_abs_path; | ||
668 | |||||
669 | |||||
670 | # --- PORTING SECTION --- | ||||
671 | |||||
672 | # VMS: $ENV{'DEFAULT'} points to default directory at all times | ||||
673 | # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu | ||||
674 | # Note: Use of Cwd::chdir() causes the logical name PWD to be defined | ||||
675 | # in the process logical name table as the default device and directory | ||||
676 | # seen by Perl. This may not be the same as the default device | ||||
677 | # and directory seen by DCL after Perl exits, since the effects | ||||
678 | # the CRTL chdir() function persist only until Perl exits. | ||||
679 | |||||
680 | sub _vms_cwd { | ||||
681 | return $ENV{'DEFAULT'}; | ||||
682 | } | ||||
683 | |||||
684 | sub _vms_abs_path { | ||||
685 | return $ENV{'DEFAULT'} unless @_; | ||||
686 | my $path = shift; | ||||
687 | |||||
688 | my $efs = _vms_efs; | ||||
689 | my $unix_rpt = _vms_unix_rpt; | ||||
690 | |||||
691 | if (defined &VMS::Filespec::vmsrealpath) { | ||||
692 | my $path_unix = 0; | ||||
693 | my $path_vms = 0; | ||||
694 | |||||
695 | $path_unix = 1 if ($path =~ m#(?<=\^)/#); | ||||
696 | $path_unix = 1 if ($path =~ /^\.\.?$/); | ||||
697 | $path_vms = 1 if ($path =~ m#[\[<\]]#); | ||||
698 | $path_vms = 1 if ($path =~ /^--?$/); | ||||
699 | |||||
700 | my $unix_mode = $path_unix; | ||||
701 | if ($efs) { | ||||
702 | # In case of a tie, the Unix report mode decides. | ||||
703 | if ($path_vms == $path_unix) { | ||||
704 | $unix_mode = $unix_rpt; | ||||
705 | } else { | ||||
706 | $unix_mode = 0 if $path_vms; | ||||
707 | } | ||||
708 | } | ||||
709 | |||||
710 | if ($unix_mode) { | ||||
711 | # Unix format | ||||
712 | return VMS::Filespec::unixrealpath($path); | ||||
713 | } | ||||
714 | |||||
715 | # VMS format | ||||
716 | |||||
717 | my $new_path = VMS::Filespec::vmsrealpath($path); | ||||
718 | |||||
719 | # Perl expects directories to be in directory format | ||||
720 | $new_path = VMS::Filespec::pathify($new_path) if -d $path; | ||||
721 | return $new_path; | ||||
722 | } | ||||
723 | |||||
724 | # Fallback to older algorithm if correct ones are not | ||||
725 | # available. | ||||
726 | |||||
727 | if (-l $path) { | ||||
728 | my $link_target = readlink($path); | ||||
729 | die "Can't resolve link $path: $!" unless defined $link_target; | ||||
730 | |||||
731 | return _vms_abs_path($link_target); | ||||
732 | } | ||||
733 | |||||
734 | # may need to turn foo.dir into [.foo] | ||||
735 | my $pathified = VMS::Filespec::pathify($path); | ||||
736 | $path = $pathified if defined $pathified; | ||||
737 | |||||
738 | return VMS::Filespec::rmsexpand($path); | ||||
739 | } | ||||
740 | |||||
741 | sub _os2_cwd { | ||||
742 | $ENV{'PWD'} = `cmd /c cd`; | ||||
743 | chomp $ENV{'PWD'}; | ||||
744 | $ENV{'PWD'} =~ s:\\:/:g ; | ||||
745 | return $ENV{'PWD'}; | ||||
746 | } | ||||
747 | |||||
748 | sub _win32_cwd_simple { | ||||
749 | $ENV{'PWD'} = `cd`; | ||||
750 | chomp $ENV{'PWD'}; | ||||
751 | $ENV{'PWD'} =~ s:\\:/:g ; | ||||
752 | return $ENV{'PWD'}; | ||||
753 | } | ||||
754 | |||||
755 | sub _win32_cwd { | ||||
756 | # Need to avoid taking any sort of reference to the typeglob or the code in | ||||
757 | # the optree, so that this tests the runtime state of things, as the | ||||
758 | # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at | ||||
759 | # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table | ||||
760 | # lookup avoids needing a string eval, which has been reported to cause | ||||
761 | # problems (for reasons that we haven't been able to get to the bottom of - | ||||
762 | # rt.cpan.org #56225) | ||||
763 | if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) { | ||||
764 | $ENV{'PWD'} = Win32::GetCwd(); | ||||
765 | } | ||||
766 | else { # miniperl | ||||
767 | chomp($ENV{'PWD'} = `cd`); | ||||
768 | } | ||||
769 | $ENV{'PWD'} =~ s:\\:/:g ; | ||||
770 | return $ENV{'PWD'}; | ||||
771 | } | ||||
772 | |||||
773 | 1 | 5µs | *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple; | ||
774 | |||||
775 | sub _dos_cwd { | ||||
776 | if (!defined &Dos::GetCwd) { | ||||
777 | $ENV{'PWD'} = `command /c cd`; | ||||
778 | chomp $ENV{'PWD'}; | ||||
779 | $ENV{'PWD'} =~ s:\\:/:g ; | ||||
780 | } else { | ||||
781 | $ENV{'PWD'} = Dos::GetCwd(); | ||||
782 | } | ||||
783 | return $ENV{'PWD'}; | ||||
784 | } | ||||
785 | |||||
786 | sub _qnx_cwd { | ||||
787 | local $ENV{PATH} = ''; | ||||
788 | local $ENV{CDPATH} = ''; | ||||
789 | local $ENV{ENV} = ''; | ||||
790 | $ENV{'PWD'} = `/usr/bin/fullpath -t`; | ||||
791 | chomp $ENV{'PWD'}; | ||||
792 | return $ENV{'PWD'}; | ||||
793 | } | ||||
794 | |||||
795 | sub _qnx_abs_path { | ||||
796 | local $ENV{PATH} = ''; | ||||
797 | local $ENV{CDPATH} = ''; | ||||
798 | local $ENV{ENV} = ''; | ||||
799 | my $path = @_ ? shift : '.'; | ||||
800 | local *REALPATH; | ||||
801 | |||||
802 | defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or | ||||
803 | die "Can't open /usr/bin/fullpath: $!"; | ||||
804 | my $realpath = <REALPATH>; | ||||
805 | close REALPATH; | ||||
806 | chomp $realpath; | ||||
807 | return $realpath; | ||||
808 | } | ||||
809 | |||||
810 | sub _epoc_cwd { | ||||
811 | $ENV{'PWD'} = EPOC::getcwd(); | ||||
812 | return $ENV{'PWD'}; | ||||
813 | } | ||||
814 | |||||
815 | |||||
816 | # Now that all the base-level functions are set up, alias the | ||||
817 | # user-level functions to the right places | ||||
818 | |||||
819 | 1 | 7µs | if (exists $METHOD_MAP{$^O}) { | ||
820 | 1 | 4µs | my $map = $METHOD_MAP{$^O}; | ||
821 | 1 | 13µs | foreach my $name (keys %$map) { | ||
822 | local $^W = 0; # assignments trigger 'subroutine redefined' warning | ||||
823 | 2 | 600µs | 2 | 252µs | # spent 158µs (63+94) within Cwd::BEGIN@823 which was called:
# once (63µs+94µs) by FindBin::BEGIN@83 at line 823 # spent 158µs making 1 call to Cwd::BEGIN@823
# spent 94µs making 1 call to strict::unimport |
824 | *{$name} = \&{$map->{$name}}; | ||||
825 | } | ||||
826 | } | ||||
827 | |||||
828 | # In case the XS version doesn't load. | ||||
829 | 1 | 2µs | *abs_path = \&_perl_abs_path unless defined &abs_path; | ||
830 | 1 | 1µs | *getcwd = \&_perl_getcwd unless defined &getcwd; | ||
831 | |||||
832 | # added function alias for those of us more | ||||
833 | # used to the libc function. --tchrist 27-Jan-00 | ||||
834 | 1 | 4µs | *realpath = \&abs_path; | ||
835 | |||||
836 | 1 | 240µs | 1; | ||
# spent 49µs within Cwd::CORE:fteexec which was called:
# once (49µs+0s) by FindBin::BEGIN@83 at line 339 | |||||
# spent 33µs within Cwd::CORE:regcomp which was called:
# once (33µs+0s) by FindBin::BEGIN@83 at line 381 | |||||
# spent 1.29s within Cwd::abs_path which was called 16310 times, avg 79µs/call:
# 13585 times (1.08s+0s) by RTP::Webmerge::Path::importURI at line 80 of webmerge/scripts/modules/RTP/Webmerge/Path.pm, avg 79µs/call
# 2719 times (213ms+0s) by RTP::Webmerge::Path::check_path at line 164 of webmerge/scripts/modules/RTP/Webmerge/Path.pm, avg 78µs/call
# 4 times (254µs+0s) by RTP::Webmerge::Path::chdir at line 204 of webmerge/scripts/modules/RTP/Webmerge/Path.pm, avg 64µs/call
# once (56µs+0s) by FindBin::init at line 158 of FindBin.pm
# once (40µs+0s) by FindBin::init at line 161 of FindBin.pm | |||||
# spent 23µs within Cwd::getcwd which was called:
# once (23µs+0s) by FindBin::cwd2 at line 101 of FindBin.pm |