Profile of Cwd.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:08 2016

Filename | /usr/lib/perl/5.18/Cwd.pm
Statements | Executed 52 statements in 2.75ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 386µs | 527µs | Cwd::::BEGIN@5Cwd::BEGIN@5
1 | 1 | 1 | 19µs | 33µs | Cwd::::BEGIN@3Cwd::BEGIN@3
2 | 1 | 1 | 15µs | 15µs | Cwd::::abs_pathCwd::abs_path (xsub)
5 | 2 | 2 | 13µs | 13µs | Cwd::::getcwdCwd::getcwd (xsub)
1 | 1 | 1 | 9µs | 22µs | Cwd::::BEGIN@647Cwd::BEGIN@647
1 | 1 | 1 | 9µs | 9µs | Cwd::::CORE:fteexecCwd::CORE:fteexec (opcode)
1 | 1 | 1 | 7µs | 28µs | Cwd::::BEGIN@4Cwd::BEGIN@4
1 | 1 | 1 | 6µs | 6µs | Cwd::::CORE:regcompCwd::CORE:regcomp (opcode)
1 | 1 | 1 | 4µs | 4µs | Cwd::::BEGIN@42Cwd::BEGIN@42
0 | 0 | 0 | 0s | 0s | Cwd::::__ANON__[:233]Cwd::__ANON__[:233]
0 | 0 | 0 | 0s | 0s | Cwd::::_backtick_pwdCwd::_backtick_pwd
0 | 0 | 0 | 0s | 0s | Cwd::::_carpCwd::_carp
0 | 0 | 0 | 0s | 0s | Cwd::::_croakCwd::_croak
0 | 0 | 0 | 0s | 0s | Cwd::::_dos_cwdCwd::_dos_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_epoc_cwdCwd::_epoc_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_os2_cwdCwd::_os2_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_perl_abs_pathCwd::_perl_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_perl_getcwdCwd::_perl_getcwd
0 | 0 | 0 | 0s | 0s | Cwd::::_qnx_abs_pathCwd::_qnx_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_qnx_cwdCwd::_qnx_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_abs_pathCwd::_vms_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_cwdCwd::_vms_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_efsCwd::_vms_efs
0 | 0 | 0 | 0s | 0s | Cwd::::_vms_unix_rptCwd::_vms_unix_rpt
0 | 0 | 0 | 0s | 0s | Cwd::::_win32_cwdCwd::_win32_cwd
0 | 0 | 0 | 0s | 0s | Cwd::::_win32_cwd_simpleCwd::_win32_cwd_simple
0 | 0 | 0 | 0s | 0s | Cwd::::chdirCwd::chdir
0 | 0 | 0 | 0s | 0s | Cwd::::chdir_initCwd::chdir_init
0 | 0 | 0 | 0s | 0s | Cwd::::fast_abs_pathCwd::fast_abs_path
0 | 0 | 0 | 0s | 0s | Cwd::::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Cwd;
2 |  |  |  |  |
3 | 2 | 23µs | 2 | 46µs | # spent 33µs (19+14) within Cwd::BEGIN@3 which was called: # once (19µs+14µs) by Module::Pluggable::Object::BEGIN@4 at line 3 use strict; # spent 33µs making 1 call to Cwd::BEGIN@3 # spent 14µs making 1 call to strict::import
4 | 2 | 26µs | 2 | 50µs | # spent 28µs (7+21) within Cwd::BEGIN@4 which was called: # once (7µs+21µs) by Module::Pluggable::Object::BEGIN@4 at line 4 use Exporter; # spent 28µs making 1 call to Cwd::BEGIN@4 # spent 21µs making 1 call to Exporter::import
5 | 2 | 246µs | 2 | 576µs | # spent 527µs (386+141) within Cwd::BEGIN@5 which was called: # once (386µs+141µs) by Module::Pluggable::Object::BEGIN@4 at line 5 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); # spent 527µs making 1 call to Cwd::BEGIN@5 # spent 49µs making 1 call to vars::import
6 |  |  |  |  |
7 | 1 | 800ns |  |  | $VERSION = '3.40';
8 | 1 | 200ns |  |  | my $xs_version = $VERSION;
9 | 1 | 3µs |  |  | $VERSION =~ tr/_//;
10 |  |  |  |  |
11 | 1 | 5µs |  |  | @ISA = qw/ Exporter /;
12 | 1 | 700ns |  |  | @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
13 | 1 | 600ns |  |  | push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
14 | 1 | 600ns |  |  | @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
15 |  |  |  |  |
16 |  |  |  |  | # sys_cwd may keep the builtin command
17 |  |  |  |  |
18 |  |  |  |  | # All the functionality of this module may provided by builtins,
19 |  |  |  |  | # there is no sense to process the rest of the file.
20 |  |  |  |  | # The best choice may be to have this in BEGIN, but how to return from BEGIN?
21 |  |  |  |  |
22 | 1 | 100ns |  |  | if ($^O eq 'os2') {
23 |  |  |  |  | local $^W = 0;
24 |  |  |  |  |
25 |  |  |  |  | *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
26 |  |  |  |  | *getcwd = \&cwd;
27 |  |  |  |  | *fastgetcwd = \&cwd;
28 |  |  |  |  | *fastcwd = \&cwd;
29 |  |  |  |  |
30 |  |  |  |  | *fast_abs_path = \&sys_abspath if defined &sys_abspath;
31 |  |  |  |  | *abs_path = \&fast_abs_path;
32 |  |  |  |  | *realpath = \&fast_abs_path;
33 |  |  |  |  | *fast_realpath = \&fast_abs_path;
34 |  |  |  |  |
35 |  |  |  |  | return 1;
36 |  |  |  |  | }
37 |  |  |  |  |
38 |  |  |  |  | # Need to look up the feature settings on VMS. The preferred way is to use the
39 |  |  |  |  | # VMS::Feature module, but that may not be available to dual life modules.
40 |  |  |  |  |
41 | 1 | 0s |  |  | my $use_vms_feature;
42 |  |  |  |  | # spent 4µs within Cwd::BEGIN@42 which was called: # once (4µs+0s) by Module::Pluggable::Object::BEGIN@4 at line 48 BEGIN {
43 | 1 | 4µs |  |  | if ($^O eq 'VMS') {
44 |  |  |  |  | if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
45 |  |  |  |  | $use_vms_feature = 1;
46 |  |  |  |  | }
47 |  |  |  |  | }
48 | 1 | 2.13ms | 1 | 4µs | } # spent 4µs making 1 call to Cwd::BEGIN@42
49 |  |  |  |  |
50 |  |  |  |  | # Need to look up the UNIX report mode. This may become a dynamic mode
51 |  |  |  |  | # in the future.
52 |  |  |  |  | sub _vms_unix_rpt {
53 |  |  |  |  | my $unix_rpt;
54 |  |  |  |  | if ($use_vms_feature) {
55 |  |  |  |  | $unix_rpt = VMS::Feature::current("filename_unix_report");
56 |  |  |  |  | } else {
57 |  |  |  |  | my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
58 |  |  |  |  | $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
59 |  |  |  |  | }
60 |  |  |  |  | return $unix_rpt;
61 |  |  |  |  | }
62 |  |  |  |  |
63 |  |  |  |  | # Need to look up the EFS character set mode. This may become a dynamic
64 |  |  |  |  | # mode in the future.
65 |  |  |  |  | sub _vms_efs {
66 |  |  |  |  | my $efs;
67 |  |  |  |  | if ($use_vms_feature) {
68 |  |  |  |  | $efs = VMS::Feature::current("efs_charset");
69 |  |  |  |  | } else {
70 |  |  |  |  | my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
71 |  |  |  |  | $efs = $env_efs =~ /^[ET1]/i;
72 |  |  |  |  | }
73 |  |  |  |  | return $efs;
74 |  |  |  |  | }
75 |  |  |  |  |
76 |  |  |  |  | # If loading the XS stuff doesn't work, we can fall back to pure perl
77 | 1 | 1µs |  |  | eval {
78 | 1 | 3µs |  |  | if ( $] >= 5.006 ) {
79 | 1 | 200ns |  |  | require XSLoader;
80 | 1 | 128µs | 1 | 123µs | XSLoader::load( __PACKAGE__, $xs_version); # spent 123µs making 1 call to XSLoader::load
81 |  |  |  |  | } else {
82 |  |  |  |  | require DynaLoader;
83 |  |  |  |  | push @ISA, 'DynaLoader';
84 |  |  |  |  | __PACKAGE__->bootstrap( $xs_version );
85 |  |  |  |  | }
86 |  |  |  |  | };
87 |  |  |  |  |
88 |  |  |  |  | # Big nasty table of function aliases
89 | 1 | 10µs |  |  | my %METHOD_MAP =
90 |  |  |  |  | (
91 |  |  |  |  | VMS =>
92 |  |  |  |  | {
93 |  |  |  |  | cwd => '_vms_cwd',
94 |  |  |  |  | getcwd => '_vms_cwd',
95 |  |  |  |  | fastcwd => '_vms_cwd',
96 |  |  |  |  | fastgetcwd => '_vms_cwd',
97 |  |  |  |  | abs_path => '_vms_abs_path',
98 |  |  |  |  | fast_abs_path => '_vms_abs_path',
99 |  |  |  |  | },
100 |  |  |  |  |
101 |  |  |  |  | MSWin32 =>
102 |  |  |  |  | {
103 |  |  |  |  | # We assume that &_NT_cwd is defined as an XSUB or in the core.
104 |  |  |  |  | cwd => '_NT_cwd',
105 |  |  |  |  | getcwd => '_NT_cwd',
106 |  |  |  |  | fastcwd => '_NT_cwd',
107 |  |  |  |  | fastgetcwd => '_NT_cwd',
108 |  |  |  |  | abs_path => 'fast_abs_path',
109 |  |  |  |  | realpath => 'fast_abs_path',
110 |  |  |  |  | },
111 |  |  |  |  |
112 |  |  |  |  | dos =>
113 |  |  |  |  | {
114 |  |  |  |  | cwd => '_dos_cwd',
115 |  |  |  |  | getcwd => '_dos_cwd',
116 |  |  |  |  | fastgetcwd => '_dos_cwd',
117 |  |  |  |  | fastcwd => '_dos_cwd',
118 |  |  |  |  | abs_path => 'fast_abs_path',
119 |  |  |  |  | },
120 |  |  |  |  |
121 |  |  |  |  | # QNX4. QNX6 has a $os of 'nto'.
122 |  |  |  |  | qnx =>
123 |  |  |  |  | {
124 |  |  |  |  | cwd => '_qnx_cwd',
125 |  |  |  |  | getcwd => '_qnx_cwd',
126 |  |  |  |  | fastgetcwd => '_qnx_cwd',
127 |  |  |  |  | fastcwd => '_qnx_cwd',
128 |  |  |  |  | abs_path => '_qnx_abs_path',
129 |  |  |  |  | fast_abs_path => '_qnx_abs_path',
130 |  |  |  |  | },
131 |  |  |  |  |
132 |  |  |  |  | cygwin =>
133 |  |  |  |  | {
134 |  |  |  |  | getcwd => 'cwd',
135 |  |  |  |  | fastgetcwd => 'cwd',
136 |  |  |  |  | fastcwd => 'cwd',
137 |  |  |  |  | abs_path => 'fast_abs_path',
138 |  |  |  |  | realpath => 'fast_abs_path',
139 |  |  |  |  | },
140 |  |  |  |  |
141 |  |  |  |  | epoc =>
142 |  |  |  |  | {
143 |  |  |  |  | cwd => '_epoc_cwd',
144 |  |  |  |  | getcwd => '_epoc_cwd',
145 |  |  |  |  | fastgetcwd => '_epoc_cwd',
146 |  |  |  |  | fastcwd => '_epoc_cwd',
147 |  |  |  |  | abs_path => 'fast_abs_path',
148 |  |  |  |  | },
149 |  |  |  |  |
150 |  |  |  |  | MacOS =>
151 |  |  |  |  | {
152 |  |  |  |  | getcwd => 'cwd',
153 |  |  |  |  | fastgetcwd => 'cwd',
154 |  |  |  |  | fastcwd => 'cwd',
155 |  |  |  |  | abs_path => 'fast_abs_path',
156 |  |  |  |  | },
157 |  |  |  |  | );
158 |  |  |  |  |
159 | 1 | 1µs |  |  | $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
160 |  |  |  |  |
161 |  |  |  |  | # Find the pwd command in the expected locations. We assume these
162 |  |  |  |  | # are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
163 |  |  |  |  | # so everything works under taint mode.
164 | 1 | 100ns |  |  | my $pwd_cmd;
165 | 1 | 500ns |  |  | foreach my $try ('/bin/pwd',
166 |  |  |  |  | '/usr/bin/pwd',
167 |  |  |  |  | '/QOpenSys/bin/pwd', # OS/400 PASE.
168 |  |  |  |  | ) {
169 |  |  |  |  |
170 | 1 | 13µs | 1 | 9µs | if( -x $try ) { # spent 9µs making 1 call to Cwd::CORE:fteexec
171 | 1 | 400ns |  |  | $pwd_cmd = $try;
172 | 1 | 2µs |  |  | last;
173 |  |  |  |  | }
174 |  |  |  |  | }
175 | 1 | 400ns |  |  | my $found_pwd_cmd = defined($pwd_cmd);
176 | 1 | 100ns |  |  | unless ($pwd_cmd) {
177 |  |  |  |  | # Isn't this wrong? _backtick_pwd() will fail if somenone has
178 |  |  |  |  | # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
179 |  |  |  |  | # See [perl #16774]. --jhi
180 |  |  |  |  | $pwd_cmd = 'pwd';
181 |  |  |  |  | }
182 |  |  |  |  |
183 |  |  |  |  | # Lazy-load Carp
184 |  |  |  |  | sub _carp { require Carp; Carp::carp(@_) }
185 |  |  |  |  | sub _croak { require Carp; Carp::croak(@_) }
186 |  |  |  |  |
187 |  |  |  |  | # The 'natural and safe form' for UNIX (pwd may be setuid root)
188 |  |  |  |  | sub _backtick_pwd {
189 |  |  |  |  | # Localize %ENV entries in a way that won't create new hash keys
190 |  |  |  |  | my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
191 |  |  |  |  | local @ENV{@localize};
192 |  |  |  |  |
193 |  |  |  |  | my $cwd = `$pwd_cmd`;
194 |  |  |  |  | # Belt-and-suspenders in case someone said "undef $/".
195 |  |  |  |  | local $/ = "\n";
196 |  |  |  |  | # `pwd` may fail e.g. if the disk is full
197 |  |  |  |  | chomp($cwd) if defined $cwd;
198 |  |  |  |  | $cwd;
199 |  |  |  |  | }
200 |  |  |  |  |
201 |  |  |  |  | # Since some ports may predefine cwd internally (e.g., NT)
202 |  |  |  |  | # we take care not to override an existing definition for cwd().
203 |  |  |  |  |
204 | 1 | 2µs |  |  | unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
205 |  |  |  |  | # The pwd command is not available in some chroot(2)'ed environments
206 | 1 | 300ns |  |  | my $sep = $Config::Config{path_sep} || ':';
207 | 1 | 300ns |  |  | my $os = $^O; # Protect $^O from tainting
208 |  |  |  |  |
209 |  |  |  |  | # Try again to find a pwd, this time searching the whole PATH.
210 | 1 | 500ns |  |  | if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
211 | 1 | 12µs | 1 | 6µs | my @candidates = split($sep, $ENV{PATH}); # spent 6µs making 1 call to Cwd::CORE:regcomp
212 | 1 | 1µs |  |  | while (!$found_pwd_cmd and @candidates) {
213 |  |  |  |  | my $candidate = shift @candidates;
214 |  |  |  |  | $found_pwd_cmd = 1 if -x "$candidate/pwd";
215 |  |  |  |  | }
216 |  |  |  |  | }
217 |  |  |  |  |
218 |  |  |  |  | # MacOS has some special magic to make `pwd` work.
219 | 1 | 2µs |  |  | if( $os eq 'MacOS' || $found_pwd_cmd )
220 |  |  |  |  | {
221 |  |  |  |  | *cwd = \&_backtick_pwd;
222 |  |  |  |  | }
223 |  |  |  |  | else {
224 |  |  |  |  | *cwd = \&getcwd;
225 |  |  |  |  | }
226 |  |  |  |  | }
227 |  |  |  |  |
228 | 1 | 400ns |  |  | if ($^O eq 'cygwin') {
229 |  |  |  |  | # We need to make sure cwd() is called with no args, because it's
230 |  |  |  |  | # got an arg-less prototype and will die if args are present.
231 |  |  |  |  | local $^W = 0;
232 |  |  |  |  | my $orig_cwd = \&cwd;
233 |  |  |  |  | *cwd = sub { &$orig_cwd() }
234 |  |  |  |  | }
235 |  |  |  |  |
236 |  |  |  |  | # set a reasonable (and very safe) default for fastgetcwd, in case it
237 |  |  |  |  | # isn't redefined later (20001212 rspier)
238 | 1 | 500ns |  |  | *fastgetcwd = \&cwd;
239 |  |  |  |  |
240 |  |  |  |  | # A non-XS version of getcwd() - also used to bootstrap the perl build
241 |  |  |  |  | # process, when miniperl is running and no XS loading happens.
242 |  |  |  |  | sub _perl_getcwd
243 |  |  |  |  | {
244 |  |  |  |  | abs_path('.');
245 |  |  |  |  | }
246 |  |  |  |  |
247 |  |  |  |  | # By John Bazik
248 |  |  |  |  | #
249 |  |  |  |  | # Usage: $cwd = &fastcwd;
250 |  |  |  |  | #
251 |  |  |  |  | # This is a faster version of getcwd. It's also more dangerous because
252 |  |  |  |  | # you might chdir out of a directory that you can't chdir back into.
253 |  |  |  |  |
254 |  |  |  |  | sub fastcwd_ {
255 |  |  |  |  | my($odev, $oino, $cdev, $cino, $tdev, $tino);
256 |  |  |  |  | my(@path, $path);
257 |  |  |  |  | local(*DIR);
258 |  |  |  |  |
259 |  |  |  |  | my($orig_cdev, $orig_cino) = stat('.');
260 |  |  |  |  | ($cdev, $cino) = ($orig_cdev, $orig_cino);
261 |  |  |  |  | for (;;) {
262 |  |  |  |  | my $direntry;
263 |  |  |  |  | ($odev, $oino) = ($cdev, $cino);
264 |  |  |  |  | CORE::chdir('..') || return undef;
265 |  |  |  |  | ($cdev, $cino) = stat('.');
266 |  |  |  |  | last if $odev == $cdev && $oino == $cino;
267 |  |  |  |  | opendir(DIR, '.') || return undef;
268 |  |  |  |  | for (;;) {
269 |  |  |  |  | $direntry = readdir(DIR);
270 |  |  |  |  | last unless defined $direntry;
271 |  |  |  |  | next if $direntry eq '.';
272 |  |  |  |  | next if $direntry eq '..';
273 |  |  |  |  |
274 |  |  |  |  | ($tdev, $tino) = lstat($direntry);
275 |  |  |  |  | last unless $tdev != $odev || $tino != $oino;
276 |  |  |  |  | }
277 |  |  |  |  | closedir(DIR);
278 |  |  |  |  | return undef unless defined $direntry; # should never happen
279 |  |  |  |  | unshift(@path, $direntry);
280 |  |  |  |  | }
281 |  |  |  |  | $path = '/' . join('/', @path);
282 |  |  |  |  | if ($^O eq 'apollo') { $path = "/".$path; }
283 |  |  |  |  | # At this point $path may be tainted (if tainting) and chdir would fail.
284 |  |  |  |  | # Untaint it then check that we landed where we started.
285 |  |  |  |  | $path =~ /^(.*)\z/s # untaint
286 |  |  |  |  | && CORE::chdir($1) or return undef;
287 |  |  |  |  | ($cdev, $cino) = stat('.');
288 |  |  |  |  | die "Unstable directory path, current directory changed unexpectedly"
289 |  |  |  |  | if $cdev != $orig_cdev || $cino != $orig_cino;
290 |  |  |  |  | $path;
291 |  |  |  |  | }
292 | 1 | 200ns |  |  | if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
293 |  |  |  |  |
294 |  |  |  |  | # Keeps track of current working directory in PWD environment var
295 |  |  |  |  | # Usage:
296 |  |  |  |  | # use Cwd 'chdir';
297 |  |  |  |  | # chdir $newdir;
298 |  |  |  |  |
299 | 1 | 100ns |  |  | my $chdir_init = 0;
300 |  |  |  |  |
301 |  |  |  |  | sub chdir_init {
302 |  |  |  |  | if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
303 |  |  |  |  | my($dd,$di) = stat('.');
304 |  |  |  |  | my($pd,$pi) = stat($ENV{'PWD'});
305 |  |  |  |  | if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
306 |  |  |  |  | $ENV{'PWD'} = cwd();
307 |  |  |  |  | }
308 |  |  |  |  | }
309 |  |  |  |  | else {
310 |  |  |  |  | my $wd = cwd();
311 |  |  |  |  | $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
312 |  |  |  |  | $ENV{'PWD'} = $wd;
313 |  |  |  |  | }
314 |  |  |  |  | # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
315 |  |  |  |  | if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
316 |  |  |  |  | my($pd,$pi) = stat($2);
317 |  |  |  |  | my($dd,$di) = stat($1);
318 |  |  |  |  | if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
319 |  |  |  |  | $ENV{'PWD'}="$2$3";
320 |  |  |  |  | }
321 |  |  |  |  | }
322 |  |  |  |  | $chdir_init = 1;
323 |  |  |  |  | }
324 |  |  |  |  |
325 |  |  |  |  | sub chdir {
326 |  |  |  |  | my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
327 |  |  |  |  | $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
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 'MacOS') {
341 |  |  |  |  | return $ENV{'PWD'} = cwd();
342 |  |  |  |  | }
343 |  |  |  |  | elsif ($^O eq 'MSWin32') {
344 |  |  |  |  | $ENV{'PWD'} = $newpwd;
345 |  |  |  |  | return 1;
346 |  |  |  |  | }
347 |  |  |  |  |
348 |  |  |  |  | if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
349 |  |  |  |  | $ENV{'PWD'} = cwd();
350 |  |  |  |  | } elsif ($newdir =~ m#^/#s) {
351 |  |  |  |  | $ENV{'PWD'} = $newdir;
352 |  |  |  |  | } else {
353 |  |  |  |  | my @curdir = split(m#/#,$ENV{'PWD'});
354 |  |  |  |  | @curdir = ('') unless @curdir;
355 |  |  |  |  | my $component;
356 |  |  |  |  | foreach $component (split(m#/#, $newdir)) {
357 |  |  |  |  | next if $component eq '.';
358 |  |  |  |  | pop(@curdir),next if $component eq '..';
359 |  |  |  |  | push(@curdir,$component);
360 |  |  |  |  | }
361 |  |  |  |  | $ENV{'PWD'} = join('/',@curdir) || '/';
362 |  |  |  |  | }
363 |  |  |  |  | 1;
364 |  |  |  |  | }
365 |  |  |  |  |
366 |  |  |  |  | sub _perl_abs_path
367 |  |  |  |  | {
368 |  |  |  |  | my $start = @_ ? shift : '.';
369 |  |  |  |  | my($dotdots, $cwd, @pst, @cst, $dir, @tst);
370 |  |  |  |  |
371 |  |  |  |  | unless (@cst = stat( $start ))
372 |  |  |  |  | {
373 |  |  |  |  | _carp("stat($start): $!");
374 |  |  |  |  | return '';
375 |  |  |  |  | }
376 |  |  |  |  |
377 |  |  |  |  | unless (-d _) {
378 |  |  |  |  | # Make sure we can be invoked on plain files, not just directories.
379 |  |  |  |  | # NOTE that this routine assumes that '/' is the only directory separator.
380 |  |  |  |  |
381 |  |  |  |  | my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
382 |  |  |  |  | or return cwd() . '/' . $start;
383 |  |  |  |  |
384 |  |  |  |  | # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
385 |  |  |  |  | if (-l $start) {
386 |  |  |  |  | my $link_target = readlink($start);
387 |  |  |  |  | die "Can't resolve link $start: $!" unless defined $link_target;
388 |  |  |  |  |
389 |  |  |  |  | require File::Spec;
390 |  |  |  |  | $link_target = $dir . '/' . $link_target
391 |  |  |  |  | unless File::Spec->file_name_is_absolute($link_target);
392 |  |  |  |  |
393 |  |  |  |  | return abs_path($link_target);
394 |  |  |  |  | }
395 |  |  |  |  |
396 |  |  |  |  | return $dir ? abs_path($dir) . "/$file" : "/$file";
397 |  |  |  |  | }
398 |  |  |  |  |
399 |  |  |  |  | $cwd = '';
400 |  |  |  |  | $dotdots = $start;
401 |  |  |  |  | do
402 |  |  |  |  | {
403 |  |  |  |  | $dotdots .= '/..';
404 |  |  |  |  | @pst = @cst;
405 |  |  |  |  | local *PARENT;
406 |  |  |  |  | unless (opendir(PARENT, $dotdots))
407 |  |  |  |  | {
408 |  |  |  |  | # probably a permissions issue. Try the native command.
409 |  |  |  |  | require File::Spec;
410 |  |  |  |  | return File::Spec->rel2abs( $start, _backtick_pwd() );
411 |  |  |  |  | }
412 |  |  |  |  | unless (@cst = stat($dotdots))
413 |  |  |  |  | {
414 |  |  |  |  | _carp("stat($dotdots): $!");
415 |  |  |  |  | closedir(PARENT);
416 |  |  |  |  | return '';
417 |  |  |  |  | }
418 |  |  |  |  | if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
419 |  |  |  |  | {
420 |  |  |  |  | $dir = undef;
421 |  |  |  |  | }
422 |  |  |  |  | else
423 |  |  |  |  | {
424 |  |  |  |  | do
425 |  |  |  |  | {
426 |  |  |  |  | unless (defined ($dir = readdir(PARENT)))
427 |  |  |  |  | {
428 |  |  |  |  | _carp("readdir($dotdots): $!");
429 |  |  |  |  | closedir(PARENT);
430 |  |  |  |  | return '';
431 |  |  |  |  | }
432 |  |  |  |  | $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
433 |  |  |  |  | }
434 |  |  |  |  | while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
435 |  |  |  |  | $tst[1] != $pst[1]);
436 |  |  |  |  | }
437 |  |  |  |  | $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
438 |  |  |  |  | closedir(PARENT);
439 |  |  |  |  | } while (defined $dir);
440 |  |  |  |  | chop($cwd) unless $cwd eq '/'; # drop the trailing /
441 |  |  |  |  | $cwd;
442 |  |  |  |  | }
443 |  |  |  |  |
444 | 1 | 0s |  |  | my $Curdir;
445 |  |  |  |  | sub fast_abs_path {
446 |  |  |  |  | local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
447 |  |  |  |  | my $cwd = getcwd();
448 |  |  |  |  | require File::Spec;
449 |  |  |  |  | my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
450 |  |  |  |  |
451 |  |  |  |  | # Detaint else we'll explode in taint mode. This is safe because
452 |  |  |  |  | # we're not doing anything dangerous with it.
453 |  |  |  |  | ($path) = $path =~ /(.*)/s;
454 |  |  |  |  | ($cwd) = $cwd =~ /(.*)/s;
455 |  |  |  |  |
456 |  |  |  |  | unless (-e $path) {
457 |  |  |  |  | _croak("$path: No such file or directory");
458 |  |  |  |  | }
459 |  |  |  |  |
460 |  |  |  |  | unless (-d _) {
461 |  |  |  |  | # Make sure we can be invoked on plain files, not just directories.
462 |  |  |  |  |
463 |  |  |  |  | my ($vol, $dir, $file) = File::Spec->splitpath($path);
464 |  |  |  |  | return File::Spec->catfile($cwd, $path) unless length $dir;
465 |  |  |  |  |
466 |  |  |  |  | if (-l $path) {
467 |  |  |  |  | my $link_target = readlink($path);
468 |  |  |  |  | die "Can't resolve link $path: $!" unless defined $link_target;
469 |  |  |  |  |
470 |  |  |  |  | $link_target = File::Spec->catpath($vol, $dir, $link_target)
471 |  |  |  |  | unless File::Spec->file_name_is_absolute($link_target);
472 |  |  |  |  |
473 |  |  |  |  | return fast_abs_path($link_target);
474 |  |  |  |  | }
475 |  |  |  |  |
476 |  |  |  |  | return $dir eq File::Spec->rootdir
477 |  |  |  |  | ? File::Spec->catpath($vol, $dir, $file)
478 |  |  |  |  | : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
479 |  |  |  |  | }
480 |  |  |  |  |
481 |  |  |  |  | if (!CORE::chdir($path)) {
482 |  |  |  |  | _croak("Cannot chdir to $path: $!");
483 |  |  |  |  | }
484 |  |  |  |  | my $realpath = getcwd();
485 |  |  |  |  | if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
486 |  |  |  |  | _croak("Cannot chdir back to $cwd: $!");
487 |  |  |  |  | }
488 |  |  |  |  | $realpath;
489 |  |  |  |  | }
490 |  |  |  |  |
491 |  |  |  |  | # added function alias to follow principle of least surprise
492 |  |  |  |  | # based on previous aliasing. --tchrist 27-Jan-00
493 | 1 | 200ns |  |  | *fast_realpath = \&fast_abs_path;
494 |  |  |  |  |
495 |  |  |  |  | # --- PORTING SECTION ---
496 |  |  |  |  |
497 |  |  |  |  | # VMS: $ENV{'DEFAULT'} points to default directory at all times
498 |  |  |  |  | # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
499 |  |  |  |  | # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
500 |  |  |  |  | # in the process logical name table as the default device and directory
501 |  |  |  |  | # seen by Perl. This may not be the same as the default device
502 |  |  |  |  | # and directory seen by DCL after Perl exits, since the effects
503 |  |  |  |  | # the CRTL chdir() function persist only until Perl exits.
504 |  |  |  |  |
505 |  |  |  |  | sub _vms_cwd {
506 |  |  |  |  | return $ENV{'DEFAULT'};
507 |  |  |  |  | }
508 |  |  |  |  |
509 |  |  |  |  | sub _vms_abs_path {
510 |  |  |  |  | return $ENV{'DEFAULT'} unless @_;
511 |  |  |  |  | my $path = shift;
512 |  |  |  |  |
513 |  |  |  |  | my $efs = _vms_efs;
514 |  |  |  |  | my $unix_rpt = _vms_unix_rpt;
515 |  |  |  |  |
516 |  |  |  |  | if (defined &VMS::Filespec::vmsrealpath) {
517 |  |  |  |  | my $path_unix = 0;
518 |  |  |  |  | my $path_vms = 0;
519 |  |  |  |  |
520 |  |  |  |  | $path_unix = 1 if ($path =~ m#(?<=\^)/#);
521 |  |  |  |  | $path_unix = 1 if ($path =~ /^\.\.?$/);
522 |  |  |  |  | $path_vms = 1 if ($path =~ m#[\[<\]]#);
523 |  |  |  |  | $path_vms = 1 if ($path =~ /^--?$/);
524 |  |  |  |  |
525 |  |  |  |  | my $unix_mode = $path_unix;
526 |  |  |  |  | if ($efs) {
527 |  |  |  |  | # In case of a tie, the Unix report mode decides.
528 |  |  |  |  | if ($path_vms == $path_unix) {
529 |  |  |  |  | $unix_mode = $unix_rpt;
530 |  |  |  |  | } else {
531 |  |  |  |  | $unix_mode = 0 if $path_vms;
532 |  |  |  |  | }
533 |  |  |  |  | }
534 |  |  |  |  |
535 |  |  |  |  | if ($unix_mode) {
536 |  |  |  |  | # Unix format
537 |  |  |  |  | return VMS::Filespec::unixrealpath($path);
538 |  |  |  |  | }
539 |  |  |  |  |
540 |  |  |  |  | # VMS format
541 |  |  |  |  |
542 |  |  |  |  | my $new_path = VMS::Filespec::vmsrealpath($path);
543 |  |  |  |  |
544 |  |  |  |  | # Perl expects directories to be in directory format
545 |  |  |  |  | $new_path = VMS::Filespec::pathify($new_path) if -d $path;
546 |  |  |  |  | return $new_path;
547 |  |  |  |  | }
548 |  |  |  |  |
549 |  |  |  |  | # Fallback to older algorithm if correct ones are not
550 |  |  |  |  | # available.
551 |  |  |  |  |
552 |  |  |  |  | if (-l $path) {
553 |  |  |  |  | my $link_target = readlink($path);
554 |  |  |  |  | die "Can't resolve link $path: $!" unless defined $link_target;
555 |  |  |  |  |
556 |  |  |  |  | return _vms_abs_path($link_target);
557 |  |  |  |  | }
558 |  |  |  |  |
559 |  |  |  |  | # may need to turn foo.dir into [.foo]
560 |  |  |  |  | my $pathified = VMS::Filespec::pathify($path);
561 |  |  |  |  | $path = $pathified if defined $pathified;
562 |  |  |  |  |
563 |  |  |  |  | return VMS::Filespec::rmsexpand($path);
564 |  |  |  |  | }
565 |  |  |  |  |
566 |  |  |  |  | sub _os2_cwd {
567 |  |  |  |  | $ENV{'PWD'} = `cmd /c cd`;
568 |  |  |  |  | chomp $ENV{'PWD'};
569 |  |  |  |  | $ENV{'PWD'} =~ s:\\:/:g ;
570 |  |  |  |  | return $ENV{'PWD'};
571 |  |  |  |  | }
572 |  |  |  |  |
573 |  |  |  |  | sub _win32_cwd_simple {
574 |  |  |  |  | $ENV{'PWD'} = `cd`;
575 |  |  |  |  | chomp $ENV{'PWD'};
576 |  |  |  |  | $ENV{'PWD'} =~ s:\\:/:g ;
577 |  |  |  |  | return $ENV{'PWD'};
578 |  |  |  |  | }
579 |  |  |  |  |
580 |  |  |  |  | sub _win32_cwd {
581 |  |  |  |  | # Need to avoid taking any sort of reference to the typeglob or the code in
582 |  |  |  |  | # the optree, so that this tests the runtime state of things, as the
583 |  |  |  |  | # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
584 |  |  |  |  | # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
585 |  |  |  |  | # lookup avoids needing a string eval, which has been reported to cause
586 |  |  |  |  | # problems (for reasons that we haven't been able to get to the bottom of -
587 |  |  |  |  | # rt.cpan.org #56225)
588 |  |  |  |  | if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
589 |  |  |  |  | $ENV{'PWD'} = Win32::GetCwd();
590 |  |  |  |  | }
591 |  |  |  |  | else { # miniperl
592 |  |  |  |  | chomp($ENV{'PWD'} = `cd`);
593 |  |  |  |  | }
594 |  |  |  |  | $ENV{'PWD'} =~ s:\\:/:g ;
595 |  |  |  |  | return $ENV{'PWD'};
596 |  |  |  |  | }
597 |  |  |  |  |
598 | 1 | 400ns |  |  | *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
599 |  |  |  |  |
600 |  |  |  |  | sub _dos_cwd {
601 |  |  |  |  | if (!defined &Dos::GetCwd) {
602 |  |  |  |  | $ENV{'PWD'} = `command /c cd`;
603 |  |  |  |  | chomp $ENV{'PWD'};
604 |  |  |  |  | $ENV{'PWD'} =~ s:\\:/:g ;
605 |  |  |  |  | } else {
606 |  |  |  |  | $ENV{'PWD'} = Dos::GetCwd();
607 |  |  |  |  | }
608 |  |  |  |  | return $ENV{'PWD'};
609 |  |  |  |  | }
610 |  |  |  |  |
611 |  |  |  |  | sub _qnx_cwd {
612 |  |  |  |  | local $ENV{PATH} = '';
613 |  |  |  |  | local $ENV{CDPATH} = '';
614 |  |  |  |  | local $ENV{ENV} = '';
615 |  |  |  |  | $ENV{'PWD'} = `/usr/bin/fullpath -t`;
616 |  |  |  |  | chomp $ENV{'PWD'};
617 |  |  |  |  | return $ENV{'PWD'};
618 |  |  |  |  | }
619 |  |  |  |  |
620 |  |  |  |  | sub _qnx_abs_path {
621 |  |  |  |  | local $ENV{PATH} = '';
622 |  |  |  |  | local $ENV{CDPATH} = '';
623 |  |  |  |  | local $ENV{ENV} = '';
624 |  |  |  |  | my $path = @_ ? shift : '.';
625 |  |  |  |  | local *REALPATH;
626 |  |  |  |  |
627 |  |  |  |  | defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
628 |  |  |  |  | die "Can't open /usr/bin/fullpath: $!";
629 |  |  |  |  | my $realpath = <REALPATH>;
630 |  |  |  |  | close REALPATH;
631 |  |  |  |  | chomp $realpath;
632 |  |  |  |  | return $realpath;
633 |  |  |  |  | }
634 |  |  |  |  |
635 |  |  |  |  | sub _epoc_cwd {
636 |  |  |  |  | $ENV{'PWD'} = EPOC::getcwd();
637 |  |  |  |  | return $ENV{'PWD'};
638 |  |  |  |  | }
639 |  |  |  |  |
640 |  |  |  |  | # Now that all the base-level functions are set up, alias the
641 |  |  |  |  | # user-level functions to the right places
642 |  |  |  |  |
643 | 1 | 600ns |  |  | if (exists $METHOD_MAP{$^O}) {
644 | 1 | 300ns |  |  | my $map = $METHOD_MAP{$^O};
645 | 1 | 2µs |  |  | foreach my $name (keys %$map) {
646 |  |  |  |  | local $^W = 0; # assignments trigger 'subroutine redefined' warning
647 | 2 | 93µs | 2 | 35µs | # spent 22µs (9+13) within Cwd::BEGIN@647 which was called: # once (9µs+13µs) by Module::Pluggable::Object::BEGIN@4 at line 647 no strict 'refs'; # spent 22µs making 1 call to Cwd::BEGIN@647 # spent 13µs making 1 call to strict::unimport
648 |  |  |  |  | *{$name} = \&{$map->{$name}};
649 |  |  |  |  | }
650 |  |  |  |  | }
651 |  |  |  |  |
652 |  |  |  |  | # In case the XS version doesn't load.
653 | 1 | 200ns |  |  | *abs_path = \&_perl_abs_path unless defined &abs_path;
654 | 1 | 100ns |  |  | *getcwd = \&_perl_getcwd unless defined &getcwd;
655 |  |  |  |  |
656 |  |  |  |  | # added function alias for those of us more
657 |  |  |  |  | # used to the libc function. --tchrist 27-Jan-00
658 | 1 | 400ns |  |  | *realpath = \&abs_path;
659 |  |  |  |  |
660 | 1 | 34µs |  |  | 1;
|  |  |  |  | # spent 9µs within Cwd::CORE:fteexec which was called: # once (9µs+0s) by Module::Pluggable::Object::BEGIN@4 at line 170 sub Cwd::CORE:fteexec; # opcode
|  |  |  |  | # spent 6µs within Cwd::CORE:regcomp which was called: # once (6µs+0s) by Module::Pluggable::Object::BEGIN@4 at line 211 sub Cwd::CORE:regcomp; # opcode
|  |  |  |  | # spent 15µs within Cwd::abs_path which was called 2 times, avg 8µs/call: # 2 times (15µs+0s) by File::Temp::_deferred_unlink at line 963 of File/Temp.pm, avg 8µs/call sub Cwd::abs_path; # xsub
|  |  |  |  | # spent 13µs within Cwd::getcwd which was called 5 times, avg 3µs/call: # 3 times (5µs+0s) by File::Spec::Unix::_cwd at line 260 of File/Spec/Unix.pm, avg 2µs/call # 2 times (8µs+0s) by File::Find::_find_opt at line 484 of File/Find.pm, avg 4µs/call sub Cwd::getcwd; # xsub