← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 03:38:15 2020
Reported on Wed Feb 12 04:56:35 2020

Filename/usr/share/perl/5.28/File/Path.pm
StatementsExecuted 848 statements in 97.2ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
91190.1ms90.1msFile::Path::::CORE:unlinkFile::Path::CORE:unlink (opcode)
1811827µs1.71msFile::Path::::mkpathFile::Path::mkpath
221723µs91.5msFile::Path::::_rmtreeFile::Path::_rmtree (recurses: max depth 1, inclusive time 90.9ms)
2821665µs665µsFile::Path::::CORE:ftdirFile::Path::CORE:ftdir (opcode)
1821235µs352µsFile::Path::::make_pathFile::Path::make_path
111233µs91.9msFile::Path::::rmtreeFile::Path::rmtree
1811159µs818µsFile::Path::::_mkpathFile::Path::_mkpath
3731153µs153µsFile::Path::::__is_argFile::Path::__is_arg
112198µs98µsFile::Path::::CORE:lstatFile::Path::CORE:lstat (opcode)
11173µs127µsFile::Path::::_is_subdirFile::Path::_is_subdir
11158µs58µsFile::Path::::CORE:rmdirFile::Path::CORE:rmdir (opcode)
11156µs56µsFile::Path::::CORE:open_dirFile::Path::CORE:open_dir (opcode)
11148µs48µsFile::Path::::CORE:readdirFile::Path::CORE:readdir (opcode)
181131µs31µsFile::Path::::CORE:sortFile::Path::CORE:sort (opcode)
11124µs24µsFile::Path::::BEGIN@3File::Path::BEGIN@3
11120µs20µsFile::Path::::BEGIN@27File::Path::BEGIN@27
22116µs16µsFile::Path::::CORE:statFile::Path::CORE:stat (opcode)
11110µs13µsFile::Path::::BEGIN@4File::Path::BEGIN@4
11110µs23µsFile::Path::::BEGIN@29File::Path::BEGIN@29
11110µs10µsFile::Path::::CORE:matchFile::Path::CORE:match (opcode)
2218µs8µsFile::Path::::CORE:chdirFile::Path::CORE:chdir (opcode)
1117µs29µsFile::Path::::BEGIN@6File::Path::BEGIN@6
1117µs60µsFile::Path::::BEGIN@20File::Path::BEGIN@20
1116µs6µsFile::Path::::CORE:closedirFile::Path::CORE:closedir (opcode)
1113µs3µsFile::Path::::BEGIN@7File::Path::BEGIN@7
1113µs3µsFile::Path::::BEGIN@10File::Path::BEGIN@10
1112µs2µsFile::Path::::BEGIN@19File::Path::BEGIN@19
1112µs2µsFile::Path::::BEGIN@8File::Path::BEGIN@8
1112µs2µsFile::Path::::CORE:substFile::Path::CORE:subst (opcode)
111500ns500nsFile::Path::::__ANON__File::Path::__ANON__ (xsub)
0000s0sFile::Path::::_carpFile::Path::_carp
0000s0sFile::Path::::_croakFile::Path::_croak
0000s0sFile::Path::::_errorFile::Path::_error
0000s0sFile::Path::::_slash_lcFile::Path::_slash_lc
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
3248µs124µs
# spent 24µs within File::Path::BEGIN@3 which was called: # once (24µs+0s) by Template::BEGIN@32 at line 3
use 5.005_04;
# spent 24µs making 1 call to File::Path::BEGIN@3
4273µs215µs
# spent 13µs (10+2) within File::Path::BEGIN@4 which was called: # once (10µs+2µs) by Template::BEGIN@32 at line 4
use strict;
# spent 13µs making 1 call to File::Path::BEGIN@4 # spent 2µs making 1 call to strict::import
5
6223µs251µs
# spent 29µs (7+22) within File::Path::BEGIN@6 which was called: # once (7µs+22µs) by Template::BEGIN@32 at line 6
use Cwd 'getcwd';
# spent 29µs making 1 call to File::Path::BEGIN@6 # spent 22µs making 1 call to Exporter::import
7215µs13µs
# spent 3µs within File::Path::BEGIN@7 which was called: # once (3µs+0s) by Template::BEGIN@32 at line 7
use File::Basename ();
# spent 3µs making 1 call to File::Path::BEGIN@7
8229µs12µs
# spent 2µs within File::Path::BEGIN@8 which was called: # once (2µs+0s) by Template::BEGIN@32 at line 8
use File::Spec ();
# spent 2µs making 1 call to File::Path::BEGIN@8
9
10
# spent 3µs within File::Path::BEGIN@10 which was called: # once (3µs+0s) by Template::BEGIN@32 at line 17
BEGIN {
1113µs if ( $] < 5.006 ) {
12
13 # can't say 'opendir my $dh, $dirname'
14 # need to initialise $dh
15 eval 'use Symbol';
16 }
17113µs13µs}
# spent 3µs making 1 call to File::Path::BEGIN@10
18
19219µs12µs
# spent 2µs within File::Path::BEGIN@19 which was called: # once (2µs+0s) by Template::BEGIN@32 at line 19
use Exporter ();
# spent 2µs making 1 call to File::Path::BEGIN@19
20262µs2114µs
# spent 60µs (7+54) within File::Path::BEGIN@20 which was called: # once (7µs+54µs) by Template::BEGIN@32 at line 20
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
# spent 60µs making 1 call to File::Path::BEGIN@20 # spent 54µs making 1 call to vars::import
211300ns$VERSION = '2.15';
22113µs$VERSION = eval $VERSION;
# spent 2µs executing statements in string eval
23111µs@ISA = qw(Exporter);
241600ns@EXPORT = qw(mkpath rmtree);
251300ns@EXPORT_OK = qw(make_path remove_tree);
26
27
# spent 20µs (20+500ns) within File::Path::BEGIN@27 which was called: # once (20µs+500ns) by Template::BEGIN@32 at line 42
BEGIN {
281500ns for (qw(VMS MacOS MSWin32 os2)) {
292143µs236µs
# spent 23µs (10+13) within File::Path::BEGIN@29 which was called: # once (10µs+13µs) by Template::BEGIN@32 at line 29
no strict 'refs';
# spent 23µs making 1 call to File::Path::BEGIN@29 # spent 13µs making 1 call to strict::unimport
3049µ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)
3712µ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.
4118µs1500ns *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
# spent 500ns making 1 call to File::Path::__ANON__
4212.82ms120µs}
# spent 20µ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 153µs within File::Path::__is_arg which was called 37 times, avg 4µs/call: # 18 times (117µs+0s) by File::Path::make_path at line 81, avg 6µs/call # 18 times (29µs+0s) by File::Path::mkpath at line 86, avg 2µs/call # once (7µs+0s) by File::Path::rmtree at line 271
sub __is_arg {
703749µ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
7737147µs return ( ref $arg eq 'HASH' );
78}
79
80
# spent 352µs (235+117) within File::Path::make_path which was called 18 times, avg 20µs/call: # 17 times (224µs+112µs) by RBM::get_tmp_dir at line 266 of /root/tor-browser-build/rbm/lib/RBM.pm, avg 20µs/call # once (11µs+4µs) by RBM::build_run at line 1066 of /root/tor-browser-build/rbm/lib/RBM.pm
sub make_path {
8118121µs18117µs push @_, {} unless @_ and __is_arg( $_[-1] );
# spent 117µs making 18 calls to File::Path::__is_arg, avg 6µs/call
8218148µs181.71ms goto &mkpath;
# spent 1.71ms making 18 calls to File::Path::mkpath, avg 95µs/call
83}
84
85
# spent 1.71ms (827µs+879µs) within File::Path::mkpath which was called 18 times, avg 95µs/call: # 18 times (827µs+879µs) by RBM::build_run or RBM::get_tmp_dir at line 82, avg 95µs/call
sub mkpath {
861855µs1829µs my $old_style = !( @_ and __is_arg( $_[-1] ) );
# spent 29µs making 18 calls to File::Path::__is_arg, avg 2µs/call
87
88186µs my $data;
89 my $paths;
90
911816µs 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 {
9918253µs 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 | );
1101876µs my %not_on_win32_args = map { $_ => 1 } ( qw|
111 group
112 owner
113 uid
114 user
115 | );
1161819µs my @bad_args = ();
1171812µs my @win32_implausible_args = ();
1181813µs my $arg = pop @_;
11918132µs1831µs for my $k (sort keys %{$arg}) {
# spent 31µs making 18 calls to File::Path::CORE:sort, avg 2µs/call
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 }
130188µs _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
131 if @bad_args;
132186µs _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
133 if @win32_implausible_args;
1341811µs $data->{mode} = delete $data->{mask} if exists $data->{mask};
1351827µs $data->{mode} = oct '777' unless exists $data->{mode};
136188µs ${ $data->{error} } = [] if exists $data->{error};
137188µs unless (@win32_implausible_args) {
138187µs $data->{owner} = delete $data->{user} if exists $data->{user};
139187µs $data->{owner} = delete $data->{uid} if exists $data->{uid};
140187µs 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 }
152187µs 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 }
164186µs if ( exists $data->{owner} and not exists $data->{group} ) {
165 $data->{group} = -1; # chown will leave group unchanged
166 }
1671810µs if ( exists $data->{group} and not exists $data->{owner} ) {
168 $data->{owner} = -1; # chown will leave owner unchanged
169 }
170 }
1711834µs $paths = [@_];
172 }
17318111µs18818µs return _mkpath( $data, $paths );
# spent 818µs making 18 calls to File::Path::_mkpath, avg 45µs/call
174}
175
176
# spent 818µs (159+660) within File::Path::_mkpath which was called 18 times, avg 45µs/call: # 18 times (159µs+660µs) by File::Path::mkpath at line 173, avg 45µs/call
sub _mkpath {
177188µs my $data = shift;
178189µs my $paths = shift;
179
180186µs my ( @created );
1811821µs foreach my $path ( @{$paths} ) {
1821811µs 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 }
19018723µs18660µs next if -d $path;
# spent 660µs making 18 calls to File::Path::CORE:ftdir, avg 37µs/call
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 }
2441855µs return @created;
245}
246
247sub remove_tree {
248 push @_, {} unless @_ and __is_arg( $_[-1] );
249 goto &rmtree;
250}
251
252
# spent 127µs (73+54) within File::Path::_is_subdir which was called: # once (73µs+54µs) by File::Path::rmtree at line 342
sub _is_subdir {
25312µs my ( $dir, $test ) = @_;
254
255119µs120µs my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
# spent 20µs making 1 call to File::Spec::Unix::splitpath
25614µs12µs my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
# spent 2µs making 1 call to File::Spec::Unix::splitpath
257
258 # not on same volume
2591700ns return 0 if $dv ne $tv;
260
26114µs125µs my @d = File::Spec->splitdir($dd);
# spent 25µs making 1 call to File::Spec::Unix::splitdir
26211µs16µs my @t = File::Spec->splitdir($td);
# spent 6µs making 1 call to File::Spec::Unix::splitdir
263
264 # @t can't be a subdir if it's shorter than @d
265117µs return 0 if @t < @d;
266
267 return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
268}
269
270
# spent 91.9ms (233µs+91.7) within File::Path::rmtree which was called: # once (233µs+91.7ms) by File::Temp::Dir::DESTROY at line 1583 of File/Temp.pm
sub rmtree {
27117µs17µs my $old_style = !( @_ and __is_arg( $_[-1] ) );
# spent 7µs making 1 call to File::Path::__is_arg
272
2731400ns my ($arg, $data, $paths);
274
2751900ns if ($old_style) {
2761400ns my ( $verbose, $safe );
27712µs ( $paths, $verbose, $safe ) = @_;
27816µs $data->{verbose} = $verbose;
27912µs $data->{safe} = defined $safe ? $safe : 0;
280
281128µs111µs if ( defined($paths) and length($paths) ) {
# spent 11µs making 1 call to UNIVERSAL::isa
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
32412µs $data->{prefix} = '';
32512µs $data->{depth} = 0;
326
3271200ns my @clean_path;
328149µs113µs $data->{cwd} = getcwd() or do {
# spent 13µs making 1 call to Cwd::getcwd
329 _error( $data, "cannot fetch initial working directory" );
330 return 0;
331 };
332344µs110µs for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
# spent 10µs making 1 call to File::Path::CORE:match
333
33411µs for my $p (@$paths) {
335
336 # need to fixup case and map \ to / on Windows
3371300ns my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
338 my $ortho_cwd =
3391700ns _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
3401800ns my $ortho_root_length = length($ortho_root);
341 $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
34212µs1127µs if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
# spent 127µs making 1 call to File::Path::_is_subdir
343 local $! = 0;
344 _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
345 next;
346 }
347
3481300ns 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 {
356139µs12µs $p =~ s{/\z}{};
# spent 2µs making 1 call to File::Path::CORE:subst
357 }
35811µs push @clean_path, $p;
359 }
360
361149µs111µs @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
# spent 11µs making 1 call to File::Path::CORE:lstat
362 _error( $data, "cannot stat initial working directory", $data->{cwd} );
363 return 0;
364 };
365
366114µs191.5ms return _rmtree( $data, \@clean_path );
# spent 91.5ms making 1 call to File::Path::_rmtree
367}
368
369
# spent 91.5ms (723µs+90.8) within File::Path::_rmtree which was called 2 times, avg 45.7ms/call: # once (415µs+91.1ms) by File::Path::rmtree at line 366 # once (308µs+-308µs) by File::Path::_rmtree at line 500
sub _rmtree {
3702700ns my $data = shift;
3712400ns my $paths = shift;
372
3732700ns my $count = 0;
374224µs26µs my $curdir = File::Spec->curdir();
# spent 6µs making 2 calls to File::Spec::Unix::curdir, avg 3µs/call
375212µs27µs my $updir = File::Spec->updir();
# spent 7µs making 2 calls to File::Spec::Unix::updir, avg 3µs/call
376
3772500ns my ( @files, $root );
378 ROOT_DIR:
37921µ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}
38910428µs36450µs ? File::Spec->catfile( $data->{prefix}, $root )
# spent 367µs making 9 calls to File::Spec::Unix::catfile, avg 41µs/call # spent 53µs making 9 calls to File::Spec::Unix::catdir, avg 6µs/call # spent 30µs making 18 calls to File::Spec::Unix::canonpath, avg 2µs/call
390 : $root;
391
39210225µs1087µs my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
# spent 87µs making 10 calls to File::Path::CORE:lstat, avg 9µs/call
393 or next ROOT_DIR;
394
3951047µs106µs if ( -d _ ) {
# spent 6µs making 10 calls to File::Path::CORE:ftdir, avg 550ns/call
396 $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
397 if _IS_VMS;
398
399136µs11µs if ( !chdir($root) ) {
# spent 1µs making 1 call to File::Path::CORE:chdir
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 ]
435143µs111µs or do {
# spent 11µs making 1 call to File::Path::CORE:stat
436 _error( $data, "cannot stat current working directory", $canon );
437 next ROOT_DIR;
438 };
439
44011µ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
4471400ns $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
4481700ns 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
45511µ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
4671300ns my $d;
4681900ns $d = gensym() if $] < 5.006;
469176µs156µs if ( !opendir $d, $curdir ) {
# spent 56µs making 1 call to File::Path::CORE:open_dir
470 _error( $data, "cannot opendir", $canon );
471 @files = ();
472 }
473 else {
47413µ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 {
479166µs148µs @files = readdir $d;
# spent 48µs making 1 call to File::Path::CORE:readdir
480 }
481124µs16µs closedir $d;
# spent 6µs making 1 call to File::Path::CORE:closedir
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
492115µs @files = grep { $_ ne $updir and $_ ne $curdir } @files;
493
4941700ns if (@files) {
495
496 # remove the contained files before the directory itself
49718µs my $narg = {%$data};
498 @{$narg}{qw(device inode cwd prefix depth)} =
49913µs ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
500135µs10s $count += _rmtree( $narg, \@files );
# spent 90.9ms making 1 call to File::Path::_rmtree, recursion: max depth 1, sum of overlapping time 90.9ms
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 '.'
5061700ns 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} )
512115µs17µs or
# spent 7µs making 1 call to File::Path::CORE:chdir
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)
517121µs14µs ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
# spent 4µs making 1 call to File::Path::CORE:stat
518 or _croak(
519 "cannot stat prior working directory $data->{cwd}: $!, aborting."
520 );
521
52214µ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
53116µs if ( $data->{depth} or !$data->{keep_root} ) {
53211µ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 }
54311µs print "rmdir $root\n" if $data->{verbose};
544177µs158µs if ( rmdir $root ) {
# spent 58µs making 1 call to File::Path::CORE:rmdir
5451400ns push @{ ${ $data->{result} } }, $root if $data->{result};
5461300ns ++$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
57498µ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
58796µ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 }
59494µs print "unlink $canon\n" if $data->{verbose};
595
596 # delete all versions under VMS
59792µs for ( ; ; ) {
598990.2ms990.1ms if ( unlink $root ) {
# spent 90.1ms making 9 calls to File::Path::CORE:unlink, avg 10.0ms/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 }
60993µs ++$count;
610910µs last unless _IS_VMS && lstat $root;
611 }
612 }
613 }
614241µ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 8µs within File::Path::CORE:chdir which was called 2 times, avg 4µs/call: # once (7µs+0s) by File::Path::_rmtree at line 512 # once (1µs+0s) by File::Path::_rmtree at line 399
sub File::Path::CORE:chdir; # opcode
# spent 6µs within File::Path::CORE:closedir which was called: # once (6µs+0s) by File::Path::_rmtree at line 481
sub File::Path::CORE:closedir; # opcode
# spent 665µs within File::Path::CORE:ftdir which was called 28 times, avg 24µs/call: # 18 times (660µs+0s) by File::Path::_mkpath at line 190, avg 37µs/call # 10 times (6µs+0s) by File::Path::_rmtree at line 395, avg 550ns/call
sub File::Path::CORE:ftdir; # opcode
# spent 98µs within File::Path::CORE:lstat which was called 11 times, avg 9µs/call: # 10 times (87µs+0s) by File::Path::_rmtree at line 392, avg 9µs/call # once (11µs+0s) by File::Path::rmtree at line 361
sub File::Path::CORE:lstat; # opcode
# spent 10µs within File::Path::CORE:match which was called: # once (10µs+0s) by File::Path::rmtree at line 332
sub File::Path::CORE:match; # opcode
# spent 56µs within File::Path::CORE:open_dir which was called: # once (56µs+0s) by File::Path::_rmtree at line 469
sub File::Path::CORE:open_dir; # opcode
# spent 48µs within File::Path::CORE:readdir which was called: # once (48µs+0s) by File::Path::_rmtree at line 479
sub File::Path::CORE:readdir; # opcode
# spent 58µs within File::Path::CORE:rmdir which was called: # once (58µs+0s) by File::Path::_rmtree at line 544
sub File::Path::CORE:rmdir; # opcode
# spent 31µs within File::Path::CORE:sort which was called 18 times, avg 2µs/call: # 18 times (31µs+0s) by File::Path::mkpath at line 119, avg 2µs/call
sub File::Path::CORE:sort; # opcode
# spent 16µs within File::Path::CORE:stat which was called 2 times, avg 8µs/call: # once (11µs+0s) by File::Path::_rmtree at line 435 # once (4µs+0s) by File::Path::_rmtree at line 517
sub File::Path::CORE:stat; # opcode
# spent 2µs within File::Path::CORE:subst which was called: # once (2µs+0s) by File::Path::rmtree at line 356
sub File::Path::CORE:subst; # opcode
# spent 90.1ms within File::Path::CORE:unlink which was called 9 times, avg 10.0ms/call: # 9 times (90.1ms+0s) by File::Path::_rmtree at line 598, avg 10.0ms/call
sub File::Path::CORE:unlink; # opcode
# spent 500ns within File::Path::__ANON__ which was called: # once (500ns+0s) by File::Path::BEGIN@27 at line 41
sub File::Path::__ANON__; # xsub
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.