← Index
NYTProf Performance Profile   « line view »
For /usr/sbin/pkg_info
  Run on Mon Aug 7 09:39:31 2017
Reported on Mon Aug 7 09:40:21 2017

Filename/usr/libdata/perl5/File/Path.pm
StatementsExecuted 5790 statements in 42.3ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1202110.1ms28.0msFile::Path::::_rmtreeFile::Path::_rmtree (recurses: max depth 1, inclusive time 13.2ms)
80116.56ms42.6msFile::Path::::rmtreeFile::Path::rmtree
1113.48ms4.84msFile::Path::::BEGIN@6File::Path::BEGIN@6
80113.46ms5.21msFile::Path::::_is_subdirFile::Path::_is_subdir
40113.28ms3.28msFile::Path::::CORE:readdirFile::Path::CORE:readdir (opcode)
1112.43ms2.95msFile::Path::::BEGIN@8File::Path::BEGIN@8
80112.27ms2.27msFile::Path::::CORE:unlinkFile::Path::CORE:unlink (opcode)
240211.77ms1.77msFile::Path::::CORE:lstatFile::Path::CORE:lstat (opcode)
40111.38ms1.38msFile::Path::::CORE:rmdirFile::Path::CORE:rmdir (opcode)
8021686µs686µsFile::Path::::CORE:chdirFile::Path::CORE:chdir (opcode)
4011678µs678µsFile::Path::::CORE:closedirFile::Path::CORE:closedir (opcode)
8011650µs650µsFile::Path::::CORE:matchFile::Path::CORE:match (opcode)
8011538µs538µsFile::Path::::__is_argFile::Path::__is_arg
4011480µs480µsFile::Path::::CORE:open_dirFile::Path::CORE:open_dir (opcode)
8011401µs401µsFile::Path::::CORE:substFile::Path::CORE:subst (opcode)
8021358µs358µsFile::Path::::CORE:statFile::Path::CORE:stat (opcode)
12011129µs129µsFile::Path::::CORE:ftdirFile::Path::CORE:ftdir (opcode)
11132µs33µsFile::Path::::BEGIN@27File::Path::BEGIN@27
11125µs25µsFile::Path::::BEGIN@3File::Path::BEGIN@3
11114µs20µsFile::Path::::BEGIN@4File::Path::BEGIN@4
1119µs81µsFile::Path::::BEGIN@20File::Path::BEGIN@20
1119µs27µsFile::Path::::BEGIN@29File::Path::BEGIN@29
1116µs6µsFile::Path::::BEGIN@19File::Path::BEGIN@19
1116µs6µsFile::Path::::BEGIN@10File::Path::BEGIN@10
1116µs6µsFile::Path::::BEGIN@7File::Path::BEGIN@7
1111µs1µsFile::Path::::__ANON__File::Path::__ANON__ (xsub)
0000s0sFile::Path::::_carpFile::Path::_carp
0000s0sFile::Path::::_croakFile::Path::_croak
0000s0sFile::Path::::_errorFile::Path::_error
0000s0sFile::Path::::_mkpathFile::Path::_mkpath
0000s0sFile::Path::::_slash_lcFile::Path::_slash_lc
0000s0sFile::Path::::make_pathFile::Path::make_path
0000s0sFile::Path::::mkpathFile::Path::mkpath
0000s0sFile::Path::::remove_treeFile::Path::remove_tree
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package File::Path;
2
3257µs125µs
# spent 25µs within File::Path::BEGIN@3 which was called: # once (25µs+0s) by OpenBSD::PackageRepository::wipe_info at line 3
use 5.005_04;
# spent 25µs making 1 call to File::Path::BEGIN@3
4234µs226µs
# spent 20µs (14+6) within File::Path::BEGIN@4 which was called: # once (14µs+6µs) by OpenBSD::PackageRepository::wipe_info at line 4
use strict;
# spent 20µs making 1 call to File::Path::BEGIN@4 # spent 6µs making 1 call to strict::import
5
62122µs24.91ms
# spent 4.84ms (3.48+1.36) within File::Path::BEGIN@6 which was called: # once (3.48ms+1.36ms) by OpenBSD::PackageRepository::wipe_info at line 6
use Cwd 'getcwd';
# spent 4.84ms making 1 call to File::Path::BEGIN@6 # spent 73µs making 1 call to Exporter::import
7224µs16µs
# spent 6µs within File::Path::BEGIN@7 which was called: # once (6µs+0s) by OpenBSD::PackageRepository::wipe_info at line 7
use File::Basename ();
# spent 6µs making 1 call to File::Path::BEGIN@7
82134µs12.95ms
# spent 2.95ms (2.43+516µs) within File::Path::BEGIN@8 which was called: # once (2.43ms+516µs) by OpenBSD::PackageRepository::wipe_info at line 8
use File::Spec ();
# spent 2.95ms making 1 call to File::Path::BEGIN@8
9
10
# spent 6µs within File::Path::BEGIN@10 which was called: # once (6µs+0s) by OpenBSD::PackageRepository::wipe_info at line 17
BEGIN {
1116µs if ( $] < 5.006 ) {
12
13 # can't say 'opendir my $dh, $dirname'
14 # need to initialise $dh
15 eval 'use Symbol';
16 }
17120µs16µs}
# spent 6µs making 1 call to File::Path::BEGIN@10
18
19227µs16µs
# spent 6µs within File::Path::BEGIN@19 which was called: # once (6µs+0s) by OpenBSD::PackageRepository::wipe_info at line 19
use Exporter ();
# spent 6µs making 1 call to File::Path::BEGIN@19
20258µs2152µs
# spent 81µs (9+72) within File::Path::BEGIN@20 which was called: # once (9µs+72µs) by OpenBSD::PackageRepository::wipe_info at line 20
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
# spent 81µs making 1 call to File::Path::BEGIN@20 # spent 72µs making 1 call to vars::import
211800ns$VERSION = '2.13';
22116µs$VERSION = eval $VERSION;
# spent 3µs executing statements in string eval
2316µs@ISA = qw(Exporter);
2411µs@EXPORT = qw(mkpath rmtree);
2511µs@EXPORT_OK = qw(make_path remove_tree);
26
27
# spent 33µs (32+1) within File::Path::BEGIN@27 which was called: # once (32µs+1µs) by OpenBSD::PackageRepository::wipe_info at line 42
BEGIN {
2812µs for (qw(VMS MacOS MSWin32 os2)) {
292124µs245µs
# spent 27µs (9+18) within File::Path::BEGIN@29 which was called: # once (9µs+18µs) by OpenBSD::PackageRepository::wipe_info at line 29
no strict 'refs';
# spent 27µs making 1 call to File::Path::BEGIN@29 # spent 18µs making 1 call to strict::unimport
30413µs *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
31 }
32
33 # These OSes complain if you want to remove a file that you have no
34 # write permission to:
35 *_FORCE_WRITABLE = (
36 grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
3713µs ) ? sub () { 1 } : sub () { 0 };
38
39 # Unix-like systems need to stat each directory in order to detect
40 # race condition. MS-Windows is immune to this particular attack.
41114µs11µs *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
# spent 1µs making 1 call to File::Path::__ANON__
4212.44ms133µs}
# spent 33µs making 1 call to File::Path::BEGIN@27
43
44sub _carp {
45 require Carp;
46 goto &Carp::carp;
47}
48
49sub _croak {
50 require Carp;
51 goto &Carp::croak;
52}
53
54sub _error {
55 my $arg = shift;
56 my $message = shift;
57 my $object = shift;
58
59 if ( $arg->{error} ) {
60 $object = '' unless defined $object;
61 $message .= ": $!" if $!;
62 push @{ ${ $arg->{error} } }, { $object => $message };
63 }
64 else {
65 _carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
66 }
67}
68
69
# spent 538µs within File::Path::__is_arg which was called 80 times, avg 7µs/call: # 80 times (538µs+0s) by File::Path::rmtree at line 271, avg 7µs/call
sub __is_arg {
708085µs my ($arg) = @_;
71
72 # If client code blessed an array ref to HASH, this will not work
73 # properly. We could have done $arg->isa() wrapped in eval, but
74 # that would be expensive. This implementation should suffice.
75 # We could have also used Scalar::Util:blessed, but we choose not
76 # to add this dependency
7780337µs return ( ref $arg eq 'HASH' );
78}
79
80sub make_path {
81 push @_, {} unless @_ and __is_arg( $_[-1] );
82 goto &mkpath;
83}
84
85sub mkpath {
86 my $old_style = !( @_ and __is_arg( $_[-1] ) );
87
88 my $data;
89 my $paths;
90
91 if ($old_style) {
92 my ( $verbose, $mode );
93 ( $paths, $verbose, $mode ) = @_;
94 $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
95 $data->{verbose} = $verbose;
96 $data->{mode} = defined $mode ? $mode : oct '777';
97 }
98 else {
99 my %args_permitted = map { $_ => 1 } ( qw|
100 chmod
101 error
102 group
103 mask
104 mode
105 owner
106 uid
107 user
108 verbose
109 | );
110 my %not_on_win32_args = map { $_ => 1 } ( qw|
111 group
112 owner
113 uid
114 user
115 | );
116 my @bad_args = ();
117 my @win32_implausible_args = ();
118 my $arg = pop @_;
119 for my $k (sort keys %{$arg}) {
120 if (! $args_permitted{$k}) {
121 push @bad_args, $k;
122 }
123 elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
124 push @win32_implausible_args, $k;
125 }
126 else {
127 $data->{$k} = $arg->{$k};
128 }
129 }
130 _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
131 if @bad_args;
132 _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
133 if @win32_implausible_args;
134 $data->{mode} = delete $data->{mask} if exists $data->{mask};
135 $data->{mode} = oct '777' unless exists $data->{mode};
136 ${ $data->{error} } = [] if exists $data->{error};
137 unless (@win32_implausible_args) {
138 $data->{owner} = delete $data->{user} if exists $data->{user};
139 $data->{owner} = delete $data->{uid} if exists $data->{uid};
140 if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
141 my $uid = ( getpwnam $data->{owner} )[2];
142 if ( defined $uid ) {
143 $data->{owner} = $uid;
144 }
145 else {
146 _error( $data,
147 "unable to map $data->{owner} to a uid, ownership not changed"
148 );
149 delete $data->{owner};
150 }
151 }
152 if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
153 my $gid = ( getgrnam $data->{group} )[2];
154 if ( defined $gid ) {
155 $data->{group} = $gid;
156 }
157 else {
158 _error( $data,
159 "unable to map $data->{group} to a gid, group ownership not changed"
160 );
161 delete $data->{group};
162 }
163 }
164 if ( exists $data->{owner} and not exists $data->{group} ) {
165 $data->{group} = -1; # chown will leave group unchanged
166 }
167 if ( exists $data->{group} and not exists $data->{owner} ) {
168 $data->{owner} = -1; # chown will leave owner unchanged
169 }
170 }
171 $paths = [@_];
172 }
173 return _mkpath( $data, $paths );
174}
175
176sub _mkpath {
177 my $data = shift;
178 my $paths = shift;
179
180 my ( @created );
181 foreach my $path ( @{$paths} ) {
182 next unless defined($path) and length($path);
183 $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
184
185 # Logic wants Unix paths, so go with the flow.
186 if (_IS_VMS) {
187 next if $path eq '/';
188 $path = VMS::Filespec::unixify($path);
189 }
190 next if -d $path;
191 my $parent = File::Basename::dirname($path);
192 # Coverage note: It's not clear how we would test the condition:
193 # '-d $parent or $path eq $parent'
194 unless ( -d $parent or $path eq $parent ) {
195 push( @created, _mkpath( $data, [$parent] ) );
196 }
197 print "mkdir $path\n" if $data->{verbose};
198 if ( mkdir( $path, $data->{mode} ) ) {
199 push( @created, $path );
200 if ( exists $data->{owner} ) {
201
202 # NB: $data->{group} guaranteed to be set during initialisation
203 if ( !chown $data->{owner}, $data->{group}, $path ) {
204 _error( $data,
205 "Cannot change ownership of $path to $data->{owner}:$data->{group}"
206 );
207 }
208 }
209 if ( exists $data->{chmod} ) {
210 # Coverage note: It's not clear how we would trigger the next
211 # 'if' block. Failure of 'chmod' might first result in a
212 # system error: "Permission denied".
213 if ( !chmod $data->{chmod}, $path ) {
214 _error( $data,
215 "Cannot change permissions of $path to $data->{chmod}" );
216 }
217 }
218 }
219 else {
220 my $save_bang = $!;
221
222 # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
223 # as:
224 # Error information specific to the current operating system. At the
225 # moment, this differs from "$!" under only VMS, OS/2, and Win32
226 # (and for MacPerl). On all other platforms, $^E is always just the
227 # same as $!.
228
229 my ( $e, $e1 ) = ( $save_bang, $^E );
230 $e .= "; $e1" if $e ne $e1;
231
232 # allow for another process to have created it meanwhile
233 if ( ! -d $path ) {
234 $! = $save_bang;
235 if ( $data->{error} ) {
236 push @{ ${ $data->{error} } }, { $path => $e };
237 }
238 else {
239 _croak("mkdir $path: $e");
240 }
241 }
242 }
243 }
244 return @created;
245}
246
247sub remove_tree {
248 push @_, {} unless @_ and __is_arg( $_[-1] );
249 goto &rmtree;
250}
251
252
# spent 5.21ms (3.46+1.74) within File::Path::_is_subdir which was called 80 times, avg 65µs/call: # 80 times (3.46ms+1.74ms) by File::Path::rmtree at line 342, avg 65µs/call
sub _is_subdir {
2538086µs my ( $dir, $test ) = @_;
254
255801.11ms80802µs my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
# spent 802µs making 80 calls to File::Spec::Unix::splitpath, avg 10µs/call
25680251µs80366µs my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
# spent 366µs making 80 calls to File::Spec::Unix::splitpath, avg 5µs/call
257
258 # not on same volume
2598080µs return 0 if $dv ne $tv;
260
26180692µs80365µs my @d = File::Spec->splitdir($dd);
# spent 365µs making 80 calls to File::Spec::Unix::splitdir, avg 5µs/call
26280367µs80212µs my @t = File::Spec->splitdir($td);
# spent 212µs making 80 calls to File::Spec::Unix::splitdir, avg 3µs/call
263
264 # @t can't be a subdir if it's shorter than @d
26580471µs return 0 if @t < @d;
266
267 return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
268}
269
270
# spent 42.6ms (6.56+36.0) within File::Path::rmtree which was called 80 times, avg 532µs/call: # 80 times (6.56ms+36.0ms) by OpenBSD::Error::rmtree at line 210 of OpenBSD/Error.pm, avg 532µs/call
sub rmtree {
27180538µs80538µs my $old_style = !( @_ and __is_arg( $_[-1] ) );
# spent 538µs making 80 calls to File::Path::__is_arg, avg 7µs/call
272
2738063µs my ($arg, $data, $paths);
274
27580129µs if ($old_style) {
2768062µs my ( $verbose, $safe );
2778077µs ( $paths, $verbose, $safe ) = @_;
27880271µs $data->{verbose} = $verbose;
27980246µs $data->{safe} = defined $safe ? $safe : 0;
280
28180840µs80413µs if ( defined($paths) and length($paths) ) {
# spent 413µs making 80 calls to UNIVERSAL::isa, avg 5µs/call
282 $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
283 }
284 else {
285 _carp("No root path(s) specified\n");
286 return 0;
287 }
288 }
289 else {
290 my %args_permitted = map { $_ => 1 } ( qw|
291 error
292 keep_root
293 result
294 safe
295 verbose
296 | );
297 my @bad_args = ();
298 my $arg = pop @_;
299 for my $k (sort keys %{$arg}) {
300 if (! $args_permitted{$k}) {
301 push @bad_args, $k;
302 }
303 else {
304 $data->{$k} = $arg->{$k};
305 }
306 }
307 _carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
308 if @bad_args;
309 ${ $data->{error} } = [] if exists $data->{error};
310 ${ $data->{result} } = [] if exists $data->{result};
311
312 # Wouldn't it make sense to do some validation on @_ before assigning
313 # to $paths here?
314 # In the $old_style case we guarantee that each path is both defined
315 # and non-empty. We don't check that here, which means we have to
316 # check it later in the first condition in this line:
317 # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
318 # Granted, that would be a change in behavior for the two
319 # non-old-style interfaces.
320
321 $paths = [@_];
322 }
323
32480228µs $data->{prefix} = '';
32580222µs $data->{depth} = 0;
326
3278067µs my @clean_path;
32880884µs80269µs $data->{cwd} = getcwd() or do {
# spent 269µs making 80 calls to Cwd::getcwd, avg 3µs/call
329 _error( $data, "cannot fetch initial working directory" );
330 return 0;
331 };
3322401.39ms80650µs for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
# spent 650µs making 80 calls to File::Path::CORE:match, avg 8µs/call
333
33480283µs for my $p (@$paths) {
335
336 # need to fixup case and map \ to / on Windows
3378071µs my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
338 my $ortho_cwd =
3398093µs _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
3408070µs my $ortho_root_length = length($ortho_root);
341 $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
34280381µs805.21ms if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
# spent 5.21ms making 80 calls to File::Path::_is_subdir, avg 65µs/call
343 local $! = 0;
344 _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
345 next;
346 }
347
34880118µs if (_IS_MACOS) {
349 $p = ":$p" unless $p =~ /:/;
350 $p .= ":" unless $p =~ /:\z/;
351 }
352 elsif ( _IS_MSWIN32 ) {
353 $p =~ s{[/\\]\z}{};
354 }
355 else {
35680670µs80401µs $p =~ s{/\z}{};
# spent 401µs making 80 calls to File::Path::CORE:subst, avg 5µs/call
357 }
35880189µs push @clean_path, $p;
359 }
360
36180934µs80484µs @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
# spent 484µs making 80 calls to File::Path::CORE:lstat, avg 6µs/call
362 _error( $data, "cannot stat initial working directory", $data->{cwd} );
363 return 0;
364 };
365
36680632µs8028.0ms return _rmtree( $data, \@clean_path );
# spent 28.0ms making 80 calls to File::Path::_rmtree, avg 351µs/call
367}
368
369
# spent 28.0ms (10.1+17.9) within File::Path::_rmtree which was called 120 times, avg 234µs/call: # 80 times (6.70ms+21.3ms) by File::Path::rmtree at line 366, avg 351µs/call # 40 times (3.44ms+-3.44ms) by File::Path::_rmtree at line 500, avg 0s/call
sub _rmtree {
370120109µs my $data = shift;
37112093µs my $paths = shift;
372
37312099µs my $count = 0;
374120967µs120569µs my $curdir = File::Spec->curdir();
# spent 569µs making 120 calls to File::Spec::Unix::curdir, avg 5µs/call
375120403µs120266µs my $updir = File::Spec->updir();
# spent 266µs making 120 calls to File::Spec::Unix::updir, avg 2µs/call
376
377120100µs my ( @files, $root );
378 ROOT_DIR:
379120487µs foreach my $root (@$paths) {
380
381 # since we chdir into each directory, it may not be obvious
382 # to figure out where we are if we generate a message about
383 # a file name. We therefore construct a semi-canonical
384 # filename, anchored from the directory being unlinked (as
385 # opposed to being truly canonical, anchored from the root (/).
386
387 my $canon =
388 $data->{prefix}
3891607.17ms3207.40ms ? File::Spec->catfile( $data->{prefix}, $root )
# spent 6.53ms making 80 calls to File::Spec::Unix::catfile, avg 82µs/call # spent 563µs making 80 calls to File::Spec::Unix::catdir, avg 7µs/call # spent 304µs making 160 calls to File::Spec::Unix::canonpath, avg 2µs/call
390 : $root;
391
3921601.99ms1601.28ms my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
# spent 1.28ms making 160 calls to File::Path::CORE:lstat, avg 8µs/call
393 or next ROOT_DIR;
394
395120743µs120129µs if ( -d _ ) {
# spent 129µs making 120 calls to File::Path::CORE:ftdir, avg 1µs/call
396 $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
397 if _IS_VMS;
398
39940539µs40259µs if ( !chdir($root) ) {
# spent 259µs making 40 calls to File::Path::CORE:chdir, avg 6µs/call
400
401 # see if we can escalate privileges to get in
402 # (e.g. funny protection mask such as -w- instead of rwx)
403 # This uses fchmod to avoid traversing outside of the proper
404 # location (CVE-2017-6512)
405 my $root_fh;
406 if (open($root_fh, '<', $root)) {
407 my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
408 $perm &= oct '7777';
409 my $nperm = $perm | oct '700';
410 local $@;
411 if (
412 !(
413 $data->{safe}
414 or $nperm == $perm
415 or !-d _
416 or $fh_dev ne $ldev
417 or $fh_inode ne $lino
418 or eval { chmod( $nperm, $root_fh ) }
419 )
420 )
421 {
422 _error( $data,
423 "cannot make child directory read-write-exec", $canon );
424 next ROOT_DIR;
425 }
426 close $root_fh;
427 }
428 if ( !chdir($root) ) {
429 _error( $data, "cannot chdir to child", $canon );
430 next ROOT_DIR;
431 }
432 }
433
434 my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
43540425µs40207µs or do {
# spent 207µs making 40 calls to File::Path::CORE:stat, avg 5µs/call
436 _error( $data, "cannot stat current working directory", $canon );
437 next ROOT_DIR;
438 };
439
4404091µs if (_NEED_STAT_CHECK) {
441 ( $ldev eq $cur_dev and $lino eq $cur_inode )
442 or _croak(
443"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
444 );
445 }
446
4474040µs $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
4484057µs my $nperm = $perm | oct '700';
449
450 # notabene: 0700 is for making readable in the first place,
451 # it's also intended to change it to writable in case we have
452 # to recurse in which case we are better than rm -rf for
453 # subtrees with strange permissions
454
4554060µs if (
456 !(
457 $data->{safe}
458 or $nperm == $perm
459 or chmod( $nperm, $curdir )
460 )
461 )
462 {
463 _error( $data, "cannot make directory read+writeable", $canon );
464 $nperm = $perm;
465 }
466
4674031µs my $d;
4684051µs $d = gensym() if $] < 5.006;
469401.14ms40480µs if ( !opendir $d, $curdir ) {
# spent 480µs making 40 calls to File::Path::CORE:open_dir, avg 12µs/call
470 _error( $data, "cannot opendir", $canon );
471 @files = ();
472 }
473 else {
47440338µs if ( !defined ${^TAINT} or ${^TAINT} ) {
475 # Blindly untaint dir names if taint mode is active
476 @files = map { /\A(.*)\z/s; $1 } readdir $d;
477 }
478 else {
479403.56ms403.28ms @files = readdir $d;
# spent 3.28ms making 40 calls to File::Path::CORE:readdir, avg 82µs/call
480 }
48140836µs40678µs closedir $d;
# spent 678µs making 40 calls to File::Path::CORE:closedir, avg 17µs/call
482 }
483
484 if (_IS_VMS) {
485
486 # Deleting large numbers of files from VMS Files-11
487 # filesystems is faster if done in reverse ASCIIbetical order.
488 # include '.' to '.;' from blead patch #31775
489 @files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
490 }
491
49240254µs @files = grep { $_ ne $updir and $_ ne $curdir } @files;
493
4944085µs if (@files) {
495
496 # remove the contained files before the directory itself
49740296µs my $narg = {%$data};
498 @{$narg}{qw(device inode cwd prefix depth)} =
49940184µs ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
50040399µs400s $count += _rmtree( $narg, \@files );
# spent 13.2ms making 40 calls to File::Path::_rmtree, avg 329µs/call, recursion: max depth 1, sum of overlapping time 13.2ms
501 }
502
503 # restore directory permissions of required now (in case the rmdir
504 # below fails), while we are still in the directory and may do so
505 # without a race via '.'
5064050µs if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
507 _error( $data, "cannot reset chmod", $canon );
508 }
509
510 # don't leave the client code in an unexpected directory
511 chdir( $data->{cwd} )
51240598µs40428µs or
# spent 428µs making 40 calls to File::Path::CORE:chdir, avg 11µs/call
513 _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
514
515 # ensure that a chdir upwards didn't take us somewhere other
516 # than we expected (see CVE-2002-0435)
51740354µs40151µs ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
# spent 151µs making 40 calls to File::Path::CORE:stat, avg 4µs/call
518 or _croak(
519 "cannot stat prior working directory $data->{cwd}: $!, aborting."
520 );
521
52240132µs if (_NEED_STAT_CHECK) {
523 ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
524 or _croak( "previous directory $data->{cwd} "
525 . "changed before entering $canon, "
526 . "expected dev=$ldev ino=$lino, "
527 . "actual dev=$cur_dev ino=$cur_inode, aborting."
528 );
529 }
530
53140193µs if ( $data->{depth} or !$data->{keep_root} ) {
5324039µs if ( $data->{safe}
533 && ( _IS_VMS
534 ? !&VMS::Filespec::candelete($root)
535 : !-w $root ) )
536 {
537 print "skipped $root\n" if $data->{verbose};
538 next ROOT_DIR;
539 }
540 if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
541 _error( $data, "cannot make directory writeable", $canon );
542 }
5434041µs print "rmdir $root\n" if $data->{verbose};
544401.60ms401.38ms if ( rmdir $root ) {
# spent 1.38ms making 40 calls to File::Path::CORE:rmdir, avg 35µs/call
5454038µs push @{ ${ $data->{result} } }, $root if $data->{result};
5464036µs ++$count;
547 }
548 else {
549 _error( $data, "cannot remove directory", $canon );
550 if (
551 _FORCE_WRITABLE
552 && !chmod( $perm,
553 ( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
554 )
555 )
556 {
557 _error(
558 $data,
559 sprintf( "cannot restore permissions to 0%o",
560 $perm ),
561 $canon
562 );
563 }
564 }
565 }
566 }
567 else {
568 # not a directory
569 $root = VMS::Filespec::vmsify("./$root")
570 if _IS_VMS
571 && !File::Spec->file_name_is_absolute($root)
572 && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
573
5748078µs if (
575 $data->{safe}
576 && (
577 _IS_VMS
578 ? !&VMS::Filespec::candelete($root)
579 : !( -l $root || -w $root )
580 )
581 )
582 {
583 print "skipped $root\n" if $data->{verbose};
584 next ROOT_DIR;
585 }
586
58780102µs my $nperm = $perm & oct '7777' | oct '600';
588 if ( _FORCE_WRITABLE
589 and $nperm != $perm
590 and not chmod $nperm, $root )
591 {
592 _error( $data, "cannot make file writeable", $canon );
593 }
5948085µs print "unlink $canon\n" if $data->{verbose};
595
596 # delete all versions under VMS
5978066µs for ( ; ; ) {
598802.62ms802.27ms if ( unlink $root ) {
# spent 2.27ms making 80 calls to File::Path::CORE:unlink, avg 28µs/call
599 push @{ ${ $data->{result} } }, $root if $data->{result};
600 }
601 else {
602 _error( $data, "cannot unlink file", $canon );
603 _FORCE_WRITABLE and chmod( $perm, $root )
604 or _error( $data,
605 sprintf( "cannot restore permissions to 0%o", $perm ),
606 $canon );
607 last;
608 }
6098069µs ++$count;
61080110µs last unless _IS_VMS && lstat $root;
611 }
612 }
613 }
614120492µs return $count;
615}
616
617sub _slash_lc {
618
619 # fix up slashes and case on MSWin32 so that we can determine that
620 # c:\path\to\dir is underneath C:/Path/To
621 my $path = shift;
622 $path =~ tr{\\}{/};
623 return lc($path);
624}
625
62615µs1;
627
628__END__
 
# spent 686µs within File::Path::CORE:chdir which was called 80 times, avg 9µs/call: # 40 times (428µs+0s) by File::Path::_rmtree at line 512, avg 11µs/call # 40 times (259µs+0s) by File::Path::_rmtree at line 399, avg 6µs/call
sub File::Path::CORE:chdir; # opcode
# spent 678µs within File::Path::CORE:closedir which was called 40 times, avg 17µs/call: # 40 times (678µs+0s) by File::Path::_rmtree at line 481, avg 17µs/call
sub File::Path::CORE:closedir; # opcode
# spent 129µs within File::Path::CORE:ftdir which was called 120 times, avg 1µs/call: # 120 times (129µs+0s) by File::Path::_rmtree at line 395, avg 1µs/call
sub File::Path::CORE:ftdir; # opcode
# spent 1.77ms within File::Path::CORE:lstat which was called 240 times, avg 7µs/call: # 160 times (1.28ms+0s) by File::Path::_rmtree at line 392, avg 8µs/call # 80 times (484µs+0s) by File::Path::rmtree at line 361, avg 6µs/call
sub File::Path::CORE:lstat; # opcode
# spent 650µs within File::Path::CORE:match which was called 80 times, avg 8µs/call: # 80 times (650µs+0s) by File::Path::rmtree at line 332, avg 8µs/call
sub File::Path::CORE:match; # opcode
# spent 480µs within File::Path::CORE:open_dir which was called 40 times, avg 12µs/call: # 40 times (480µs+0s) by File::Path::_rmtree at line 469, avg 12µs/call
sub File::Path::CORE:open_dir; # opcode
# spent 3.28ms within File::Path::CORE:readdir which was called 40 times, avg 82µs/call: # 40 times (3.28ms+0s) by File::Path::_rmtree at line 479, avg 82µs/call
sub File::Path::CORE:readdir; # opcode
# spent 1.38ms within File::Path::CORE:rmdir which was called 40 times, avg 35µs/call: # 40 times (1.38ms+0s) by File::Path::_rmtree at line 544, avg 35µs/call
sub File::Path::CORE:rmdir; # opcode
# spent 358µs within File::Path::CORE:stat which was called 80 times, avg 4µs/call: # 40 times (207µs+0s) by File::Path::_rmtree at line 435, avg 5µs/call # 40 times (151µs+0s) by File::Path::_rmtree at line 517, avg 4µs/call
sub File::Path::CORE:stat; # opcode
# spent 401µs within File::Path::CORE:subst which was called 80 times, avg 5µs/call: # 80 times (401µs+0s) by File::Path::rmtree at line 356, avg 5µs/call
sub File::Path::CORE:subst; # opcode
# spent 2.27ms within File::Path::CORE:unlink which was called 80 times, avg 28µs/call: # 80 times (2.27ms+0s) by File::Path::_rmtree at line 598, avg 28µs/call
sub File::Path::CORE:unlink; # opcode
# spent 1µs within File::Path::__ANON__ which was called: # once (1µs+0s) by File::Path::BEGIN@27 at line 41
sub File::Path::__ANON__; # xsub
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.