← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:20 2017

Filename/usr/local/lib/perl5/5.24/mach/Cwd.pm
StatementsExecuted 52 statements in 7.78ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11156µs316µsCwd::::BEGIN@4Cwd::BEGIN@4
11150µs65µsCwd::::BEGIN@2Cwd::BEGIN@2
11148µs48µsCwd::::CORE:fteexecCwd::CORE:fteexec (opcode)
11129µs86µsCwd::::BEGIN@691Cwd::BEGIN@691
11122µs120µsCwd::::BEGIN@3Cwd::BEGIN@3
11121µs21µsCwd::::BEGIN@41Cwd::BEGIN@41
11118µs18µsCwd::::CORE:regcompCwd::CORE:regcomp (opcode)
11112µs12µsCwd::::CORE:matchCwd::CORE:match (opcode)
0000s0sCwd::::__ANON__[:272]Cwd::__ANON__[:272]
0000s0sCwd::::_backtick_pwdCwd::_backtick_pwd
0000s0sCwd::::_carpCwd::_carp
0000s0sCwd::::_croakCwd::_croak
0000s0sCwd::::_dos_cwdCwd::_dos_cwd
0000s0sCwd::::_epoc_cwdCwd::_epoc_cwd
0000s0sCwd::::_os2_cwdCwd::_os2_cwd
0000s0sCwd::::_perl_abs_pathCwd::_perl_abs_path
0000s0sCwd::::_perl_getcwdCwd::_perl_getcwd
0000s0sCwd::::_qnx_abs_pathCwd::_qnx_abs_path
0000s0sCwd::::_qnx_cwdCwd::_qnx_cwd
0000s0sCwd::::_vms_abs_pathCwd::_vms_abs_path
0000s0sCwd::::_vms_cwdCwd::_vms_cwd
0000s0sCwd::::_vms_efsCwd::_vms_efs
0000s0sCwd::::_vms_unix_rptCwd::_vms_unix_rpt
0000s0sCwd::::_win32_cwdCwd::_win32_cwd
0000s0sCwd::::_win32_cwd_simpleCwd::_win32_cwd_simple
0000s0sCwd::::chdirCwd::chdir
0000s0sCwd::::chdir_initCwd::chdir_init
0000s0sCwd::::fast_abs_pathCwd::fast_abs_path
0000s0sCwd::::fastcwd_Cwd::fastcwd_
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Cwd;
2273µs280µs
# spent 65µs (50+15) within Cwd::BEGIN@2 which was called: # once (50µs+15µs) by File::Path::BEGIN@6 at line 2
use strict;
# spent 65µs making 1 call to Cwd::BEGIN@2 # spent 15µs making 1 call to strict::import
3269µs2218µs
# spent 120µs (22+98) within Cwd::BEGIN@3 which was called: # once (22µs+98µs) by File::Path::BEGIN@6 at line 3
use Exporter;
# spent 120µs making 1 call to Cwd::BEGIN@3 # spent 98µs making 1 call to Exporter::import
42524µs2576µs
# spent 316µs (56+260) within Cwd::BEGIN@4 which was called: # once (56µs+260µs) by File::Path::BEGIN@6 at line 4
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
# spent 316µs making 1 call to Cwd::BEGIN@4 # spent 260µs making 1 call to vars::import
5
612µs$VERSION = '3.63_01';
712µsmy $xs_version = $VERSION;
819µs$VERSION =~ tr/_//d;
9
10115µs@ISA = qw/ Exporter /;
1113µs@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
12112µspush @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
1313µs@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
2112µsif ($^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
4011µsmy $use_vms_feature;
41
# spent 21µs within Cwd::BEGIN@41 which was called: # once (21µs+0s) by File::Path::BEGIN@6 at line 50
BEGIN {
42112µ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 }
5016.25ms121µs}
# spent 21µ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.
54sub _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.
67sub _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
8012µsif(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) {
81 eval {#eval is questionable since we are handling potential errors like
82 #"Cwd object version 3.48 does not match bootstrap parameter 3.50
83 #at lib/DynaLoader.pm line 216." by having this eval
84 if ( $] >= 5.006 ) {
85 require XSLoader;
86 XSLoader::load( __PACKAGE__, $xs_version);
87 } else {
88 require DynaLoader;
89 push @ISA, 'DynaLoader';
90 __PACKAGE__->bootstrap( $xs_version );
91 }
92 };
93}
94
95# Big nasty table of function aliases
96128µsmy %METHOD_MAP =
97 (
98 VMS =>
99 {
100 cwd => '_vms_cwd',
101 getcwd => '_vms_cwd',
102 fastcwd => '_vms_cwd',
103 fastgetcwd => '_vms_cwd',
104 abs_path => '_vms_abs_path',
105 fast_abs_path => '_vms_abs_path',
106 },
107
108 MSWin32 =>
109 {
110 # We assume that &_NT_cwd is defined as an XSUB or in the core.
111 cwd => '_NT_cwd',
112 getcwd => '_NT_cwd',
113 fastcwd => '_NT_cwd',
114 fastgetcwd => '_NT_cwd',
115 abs_path => 'fast_abs_path',
116 realpath => 'fast_abs_path',
117 },
118
119 dos =>
120 {
121 cwd => '_dos_cwd',
122 getcwd => '_dos_cwd',
123 fastgetcwd => '_dos_cwd',
124 fastcwd => '_dos_cwd',
125 abs_path => 'fast_abs_path',
126 },
127
128 # QNX4. QNX6 has a $os of 'nto'.
129 qnx =>
130 {
131 cwd => '_qnx_cwd',
132 getcwd => '_qnx_cwd',
133 fastgetcwd => '_qnx_cwd',
134 fastcwd => '_qnx_cwd',
135 abs_path => '_qnx_abs_path',
136 fast_abs_path => '_qnx_abs_path',
137 },
138
139 cygwin =>
140 {
141 getcwd => 'cwd',
142 fastgetcwd => 'cwd',
143 fastcwd => 'cwd',
144 abs_path => 'fast_abs_path',
145 realpath => 'fast_abs_path',
146 },
147
148 epoc =>
149 {
150 cwd => '_epoc_cwd',
151 getcwd => '_epoc_cwd',
152 fastgetcwd => '_epoc_cwd',
153 fastcwd => '_epoc_cwd',
154 abs_path => 'fast_abs_path',
155 },
156
157 MacOS =>
158 {
159 getcwd => 'cwd',
160 fastgetcwd => 'cwd',
161 fastcwd => 'cwd',
162 abs_path => 'fast_abs_path',
163 },
164
165 amigaos =>
166 {
167 getcwd => '_backtick_pwd',
168 fastgetcwd => '_backtick_pwd',
169 fastcwd => '_backtick_pwd',
170 abs_path => 'fast_abs_path',
171 }
172 );
173
17412µs$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
175
176
177# Find the pwd command in the expected locations. We assume these
178# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
179# so everything works under taint mode.
18011µsmy $pwd_cmd;
18114µsif($^O ne 'MSWin32') {
18212µs foreach my $try ('/bin/pwd',
183 '/usr/bin/pwd',
184 '/QOpenSys/bin/pwd', # OS/400 PASE.
185 ) {
186168µs148µs if( -x $try ) {
# spent 48µs making 1 call to Cwd::CORE:fteexec
18712µs $pwd_cmd = $try;
18814µs last;
189 }
190 }
191}
192
193# Android has a built-in pwd. Using $pwd_cmd will DTRT if
194# this perl was compiled with -Dd_useshellcmds, which is the
195# default for Android, but the block below is needed for the
196# miniperl running on the host when cross-compiling, and
197# potentially for native builds with -Ud_useshellcmds.
198123µs112µsif ($^O =~ /android/) {
# spent 12µs making 1 call to Cwd::CORE:match
199 # If targetsh is executable, then we're either a full
200 # perl, or a miniperl for a native build.
201 if (-x $Config::Config{targetsh}) {
202 $pwd_cmd = "$Config::Config{targetsh} -c pwd"
203 }
204 else {
205 my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
206 $pwd_cmd = "$sh -c pwd"
207 }
208}
209
21012µsmy $found_pwd_cmd = defined($pwd_cmd);
21112µsunless ($pwd_cmd) {
212 # Isn't this wrong? _backtick_pwd() will fail if someone has
213 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
214 # See [perl #16774]. --jhi
215 $pwd_cmd = 'pwd';
216}
217
218# Lazy-load Carp
219sub _carp { require Carp; Carp::carp(@_) }
220sub _croak { require Carp; Carp::croak(@_) }
221
222# The 'natural and safe form' for UNIX (pwd may be setuid root)
223sub _backtick_pwd {
224
225 # Localize %ENV entries in a way that won't create new hash keys.
226 # Under AmigaOS we don't want to localize as it stops perl from
227 # finding 'sh' in the PATH.
228 my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos";
229 local @ENV{@localize} if @localize;
230
231 my $cwd = `$pwd_cmd`;
232 # Belt-and-suspenders in case someone said "undef $/".
233 local $/ = "\n";
234 # `pwd` may fail e.g. if the disk is full
235 chomp($cwd) if defined $cwd;
236 $cwd;
237}
238
239# Since some ports may predefine cwd internally (e.g., NT)
240# we take care not to override an existing definition for cwd().
241
24215µsunless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
243 # The pwd command is not available in some chroot(2)'ed environments
244117µs112µs my $sep = $Config::Config{path_sep} || ':';
# spent 12µs making 1 call to Config::FETCH
24512µs my $os = $^O; # Protect $^O from tainting
246
247
248 # Try again to find a pwd, this time searching the whole PATH.
24915µs if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
250141µs118µs my @candidates = split($sep, $ENV{PATH});
# spent 18µs making 1 call to Cwd::CORE:regcomp
25117µs while (!$found_pwd_cmd and @candidates) {
252 my $candidate = shift @candidates;
253 $found_pwd_cmd = 1 if -x "$candidate/pwd";
254 }
255 }
256
257 # MacOS has some special magic to make `pwd` work.
25814µs if( $os eq 'MacOS' || $found_pwd_cmd )
259 {
260114µs *cwd = \&_backtick_pwd;
261 }
262 else {
263 *cwd = \&getcwd;
264 }
265}
266
267110µsif ($^O eq 'cygwin') {
268 # We need to make sure cwd() is called with no args, because it's
269 # got an arg-less prototype and will die if args are present.
270 local $^W = 0;
271 my $orig_cwd = \&cwd;
272 *cwd = sub { &$orig_cwd() }
273}
274
275
276# set a reasonable (and very safe) default for fastgetcwd, in case it
277# isn't redefined later (20001212 rspier)
27812µs*fastgetcwd = \&cwd;
279
280# A non-XS version of getcwd() - also used to bootstrap the perl build
281# process, when miniperl is running and no XS loading happens.
282sub _perl_getcwd
283{
284 abs_path('.');
285}
286
287# By John Bazik
288#
289# Usage: $cwd = &fastcwd;
290#
291# This is a faster version of getcwd. It's also more dangerous because
292# you might chdir out of a directory that you can't chdir back into.
293
294sub fastcwd_ {
295 my($odev, $oino, $cdev, $cino, $tdev, $tino);
296 my(@path, $path);
297 local(*DIR);
298
299 my($orig_cdev, $orig_cino) = stat('.');
300 ($cdev, $cino) = ($orig_cdev, $orig_cino);
301 for (;;) {
302 my $direntry;
303 ($odev, $oino) = ($cdev, $cino);
304 CORE::chdir('..') || return undef;
305 ($cdev, $cino) = stat('.');
306 last if $odev == $cdev && $oino == $cino;
307 opendir(DIR, '.') || return undef;
308 for (;;) {
309 $direntry = readdir(DIR);
310 last unless defined $direntry;
311 next if $direntry eq '.';
312 next if $direntry eq '..';
313
314 ($tdev, $tino) = lstat($direntry);
315 last unless $tdev != $odev || $tino != $oino;
316 }
317 closedir(DIR);
318 return undef unless defined $direntry; # should never happen
319 unshift(@path, $direntry);
320 }
321 $path = '/' . join('/', @path);
322 if ($^O eq 'apollo') { $path = "/".$path; }
323 # At this point $path may be tainted (if tainting) and chdir would fail.
324 # Untaint it then check that we landed where we started.
325 $path =~ /^(.*)\z/s # untaint
326 && CORE::chdir($1) or return undef;
327 ($cdev, $cino) = stat('.');
328 die "Unstable directory path, current directory changed unexpectedly"
329 if $cdev != $orig_cdev || $cino != $orig_cino;
330 $path;
331}
33217µsif (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
333
334
335# Keeps track of current working directory in PWD environment var
336# Usage:
337# use Cwd 'chdir';
338# chdir $newdir;
339
34012µsmy $chdir_init = 0;
341
342sub chdir_init {
343 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
344 my($dd,$di) = stat('.');
345 my($pd,$pi) = stat($ENV{'PWD'});
346 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
347 $ENV{'PWD'} = cwd();
348 }
349 }
350 else {
351 my $wd = cwd();
352 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
353 $ENV{'PWD'} = $wd;
354 }
355 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
356 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
357 my($pd,$pi) = stat($2);
358 my($dd,$di) = stat($1);
359 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
360 $ENV{'PWD'}="$2$3";
361 }
362 }
363 $chdir_init = 1;
364}
365
366sub chdir {
367 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
368 if ($^O eq "cygwin") {
369 $newdir =~ s|\A///+|//|;
370 $newdir =~ s|(?<=[^/])//+|/|g;
371 }
372 elsif ($^O ne 'MSWin32') {
373 $newdir =~ s|///*|/|g;
374 }
375 chdir_init() unless $chdir_init;
376 my $newpwd;
377 if ($^O eq 'MSWin32') {
378 # get the full path name *before* the chdir()
379 $newpwd = Win32::GetFullPathName($newdir);
380 }
381
382 return 0 unless CORE::chdir $newdir;
383
384 if ($^O eq 'VMS') {
385 return $ENV{'PWD'} = $ENV{'DEFAULT'}
386 }
387 elsif ($^O eq 'MacOS') {
388 return $ENV{'PWD'} = cwd();
389 }
390 elsif ($^O eq 'MSWin32') {
391 $ENV{'PWD'} = $newpwd;
392 return 1;
393 }
394
395 if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
396 $ENV{'PWD'} = cwd();
397 } elsif ($newdir =~ m#^/#s) {
398 $ENV{'PWD'} = $newdir;
399 } else {
400 my @curdir = split(m#/#,$ENV{'PWD'});
401 @curdir = ('') unless @curdir;
402 my $component;
403 foreach $component (split(m#/#, $newdir)) {
404 next if $component eq '.';
405 pop(@curdir),next if $component eq '..';
406 push(@curdir,$component);
407 }
408 $ENV{'PWD'} = join('/',@curdir) || '/';
409 }
410 1;
411}
412
413
414sub _perl_abs_path
415{
416 my $start = @_ ? shift : '.';
417 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
418
419 unless (@cst = stat( $start ))
420 {
421 _carp("stat($start): $!");
422 return '';
423 }
424
425 unless (-d _) {
426 # Make sure we can be invoked on plain files, not just directories.
427 # NOTE that this routine assumes that '/' is the only directory separator.
428
429 my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
430 or return cwd() . '/' . $start;
431
432 # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
433 if (-l $start) {
434 my $link_target = readlink($start);
435 die "Can't resolve link $start: $!" unless defined $link_target;
436
437 require File::Spec;
438 $link_target = $dir . '/' . $link_target
439 unless File::Spec->file_name_is_absolute($link_target);
440
441 return abs_path($link_target);
442 }
443
444 return $dir ? abs_path($dir) . "/$file" : "/$file";
445 }
446
447 $cwd = '';
448 $dotdots = $start;
449 do
450 {
451 $dotdots .= '/..';
452 @pst = @cst;
453 local *PARENT;
454 unless (opendir(PARENT, $dotdots))
455 {
456 # probably a permissions issue. Try the native command.
457 require File::Spec;
458 return File::Spec->rel2abs( $start, _backtick_pwd() );
459 }
460 unless (@cst = stat($dotdots))
461 {
462 _carp("stat($dotdots): $!");
463 closedir(PARENT);
464 return '';
465 }
466 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
467 {
468 $dir = undef;
469 }
470 else
471 {
472 do
473 {
474 unless (defined ($dir = readdir(PARENT)))
475 {
476 _carp("readdir($dotdots): $!");
477 closedir(PARENT);
478 return '';
479 }
480 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
481 }
482 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
483 $tst[1] != $pst[1]);
484 }
485 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
486 closedir(PARENT);
487 } while (defined $dir);
488 chop($cwd) unless $cwd eq '/'; # drop the trailing /
489 $cwd;
490}
491
492
49311µsmy $Curdir;
494sub fast_abs_path {
495 local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
496 my $cwd = getcwd();
497 require File::Spec;
498 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
499
500 # Detaint else we'll explode in taint mode. This is safe because
501 # we're not doing anything dangerous with it.
502 ($path) = $path =~ /(.*)/s;
503 ($cwd) = $cwd =~ /(.*)/s;
504
505 unless (-e $path) {
506 _croak("$path: No such file or directory");
507 }
508
509 unless (-d _) {
510 # Make sure we can be invoked on plain files, not just directories.
511
512 my ($vol, $dir, $file) = File::Spec->splitpath($path);
513 return File::Spec->catfile($cwd, $path) unless length $dir;
514
515 if (-l $path) {
516 my $link_target = readlink($path);
517 die "Can't resolve link $path: $!" unless defined $link_target;
518
519 $link_target = File::Spec->catpath($vol, $dir, $link_target)
520 unless File::Spec->file_name_is_absolute($link_target);
521
522 return fast_abs_path($link_target);
523 }
524
525 return $dir eq File::Spec->rootdir
526 ? File::Spec->catpath($vol, $dir, $file)
527 : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
528 }
529
530 if (!CORE::chdir($path)) {
531 _croak("Cannot chdir to $path: $!");
532 }
533 my $realpath = getcwd();
534 if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
535 _croak("Cannot chdir back to $cwd: $!");
536 }
537 $realpath;
538}
539
540# added function alias to follow principle of least surprise
541# based on previous aliasing. --tchrist 27-Jan-00
54212µs*fast_realpath = \&fast_abs_path;
543
544
545# --- PORTING SECTION ---
546
547# VMS: $ENV{'DEFAULT'} points to default directory at all times
548# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
549# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
550# in the process logical name table as the default device and directory
551# seen by Perl. This may not be the same as the default device
552# and directory seen by DCL after Perl exits, since the effects
553# the CRTL chdir() function persist only until Perl exits.
554
555sub _vms_cwd {
556 return $ENV{'DEFAULT'};
557}
558
559sub _vms_abs_path {
560 return $ENV{'DEFAULT'} unless @_;
561 my $path = shift;
562
563 my $efs = _vms_efs;
564 my $unix_rpt = _vms_unix_rpt;
565
566 if (defined &VMS::Filespec::vmsrealpath) {
567 my $path_unix = 0;
568 my $path_vms = 0;
569
570 $path_unix = 1 if ($path =~ m#(?<=\^)/#);
571 $path_unix = 1 if ($path =~ /^\.\.?$/);
572 $path_vms = 1 if ($path =~ m#[\[<\]]#);
573 $path_vms = 1 if ($path =~ /^--?$/);
574
575 my $unix_mode = $path_unix;
576 if ($efs) {
577 # In case of a tie, the Unix report mode decides.
578 if ($path_vms == $path_unix) {
579 $unix_mode = $unix_rpt;
580 } else {
581 $unix_mode = 0 if $path_vms;
582 }
583 }
584
585 if ($unix_mode) {
586 # Unix format
587 return VMS::Filespec::unixrealpath($path);
588 }
589
590 # VMS format
591
592 my $new_path = VMS::Filespec::vmsrealpath($path);
593
594 # Perl expects directories to be in directory format
595 $new_path = VMS::Filespec::pathify($new_path) if -d $path;
596 return $new_path;
597 }
598
599 # Fallback to older algorithm if correct ones are not
600 # available.
601
602 if (-l $path) {
603 my $link_target = readlink($path);
604 die "Can't resolve link $path: $!" unless defined $link_target;
605
606 return _vms_abs_path($link_target);
607 }
608
609 # may need to turn foo.dir into [.foo]
610 my $pathified = VMS::Filespec::pathify($path);
611 $path = $pathified if defined $pathified;
612
613 return VMS::Filespec::rmsexpand($path);
614}
615
616sub _os2_cwd {
617 my $pwd = `cmd /c cd`;
618 chomp $pwd;
619 $pwd =~ s:\\:/:g ;
620 $ENV{'PWD'} = $pwd;
621 return $pwd;
622}
623
624sub _win32_cwd_simple {
625 my $pwd = `cd`;
626 chomp $pwd;
627 $pwd =~ s:\\:/:g ;
628 $ENV{'PWD'} = $pwd;
629 return $pwd;
630}
631
632sub _win32_cwd {
633 my $pwd;
634 $pwd = Win32::GetCwd();
635 $pwd =~ s:\\:/:g ;
636 $ENV{'PWD'} = $pwd;
637 return $pwd;
638}
639
64012µs*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
641
642sub _dos_cwd {
643 my $pwd;
644 if (!defined &Dos::GetCwd) {
645 chomp($pwd = `command /c cd`);
646 $pwd =~ s:\\:/:g ;
647 } else {
648 $pwd = Dos::GetCwd();
649 }
650 $ENV{'PWD'} = $pwd;
651 return $pwd;
652}
653
654sub _qnx_cwd {
655 local $ENV{PATH} = '';
656 local $ENV{CDPATH} = '';
657 local $ENV{ENV} = '';
658 my $pwd = `/usr/bin/fullpath -t`;
659 chomp $pwd;
660 $ENV{'PWD'} = $pwd;
661 return $pwd;
662}
663
664sub _qnx_abs_path {
665 local $ENV{PATH} = '';
666 local $ENV{CDPATH} = '';
667 local $ENV{ENV} = '';
668 my $path = @_ ? shift : '.';
669 local *REALPATH;
670
671 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
672 die "Can't open /usr/bin/fullpath: $!";
673 my $realpath = <REALPATH>;
674 close REALPATH;
675 chomp $realpath;
676 return $realpath;
677}
678
679sub _epoc_cwd {
680 return $ENV{'PWD'} = EPOC::getcwd();
681}
682
683
684# Now that all the base-level functions are set up, alias the
685# user-level functions to the right places
686
68713µsif (exists $METHOD_MAP{$^O}) {
68812µs my $map = $METHOD_MAP{$^O};
68916µs foreach my $name (keys %$map) {
690 local $^W = 0; # assignments trigger 'subroutine redefined' warning
6912359µs2144µs
# spent 86µs (29+58) within Cwd::BEGIN@691 which was called: # once (29µs+58µs) by File::Path::BEGIN@6 at line 691
no strict 'refs';
# spent 86µs making 1 call to Cwd::BEGIN@691 # spent 58µs making 1 call to strict::unimport
692 *{$name} = \&{$map->{$name}};
693 }
694}
695
696# In case the XS version doesn't load.
697110µs*abs_path = \&_perl_abs_path unless defined &abs_path;
69811µs*getcwd = \&_perl_getcwd unless defined &getcwd;
699
700# added function alias for those of us more
701# used to the libc function. --tchrist 27-Jan-00
70212µs*realpath = \&abs_path;
703
7041150µs1;
705__END__
 
# spent 48µs within Cwd::CORE:fteexec which was called: # once (48µs+0s) by File::Path::BEGIN@6 at line 186
sub Cwd::CORE:fteexec; # opcode
# spent 12µs within Cwd::CORE:match which was called: # once (12µs+0s) by File::Path::BEGIN@6 at line 198
sub Cwd::CORE:match; # opcode
# spent 18µs within Cwd::CORE:regcomp which was called: # once (18µs+0s) by File::Path::BEGIN@6 at line 250
sub Cwd::CORE:regcomp; # opcode
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.