| Filename | /Users/ap13/perl5/lib/perl5/File/Path.pm |
| Statements | Executed 205 statements in 3.79ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 2.99ms | 3.22ms | File::Path::BEGIN@6 |
| 1 | 1 | 1 | 1.24ms | 1.38ms | File::Path::BEGIN@7 |
| 2 | 2 | 1 | 400µs | 1.01ms | File::Path::_rmtree (recurses: max depth 1, inclusive time 604µs) |
| 8 | 1 | 1 | 281µs | 281µs | File::Path::CORE:unlink (opcode) |
| 1 | 1 | 1 | 136µs | 1.29ms | File::Path::rmtree |
| 10 | 2 | 1 | 56µs | 56µs | File::Path::CORE:lstat (opcode) |
| 1 | 1 | 1 | 50µs | 83µs | File::Path::_is_subdir |
| 1 | 1 | 1 | 48µs | 48µs | File::Path::CORE:rmdir (opcode) |
| 1 | 1 | 1 | 43µs | 43µs | File::Path::CORE:readdir (opcode) |
| 1 | 1 | 1 | 17µs | 17µs | File::Path::BEGIN@3 |
| 1 | 1 | 1 | 17µs | 17µs | File::Path::CORE:open_dir (opcode) |
| 1 | 1 | 1 | 14µs | 14µs | File::Path::CORE:match (opcode) |
| 2 | 2 | 1 | 14µs | 14µs | File::Path::CORE:chdir (opcode) |
| 1 | 1 | 1 | 12µs | 12µs | File::Path::CORE:closedir (opcode) |
| 1 | 1 | 1 | 9µs | 22µs | File::Path::BEGIN@329 |
| 1 | 1 | 1 | 7µs | 19µs | File::Path::BEGIN@4 |
| 1 | 1 | 1 | 7µs | 63µs | File::Path::BEGIN@19 |
| 2 | 2 | 1 | 7µs | 7µs | File::Path::CORE:stat (opcode) |
| 1 | 1 | 1 | 4µs | 4µs | File::Path::BEGIN@8 |
| 1 | 1 | 1 | 4µs | 4µs | File::Path::BEGIN@10 |
| 1 | 1 | 1 | 3µs | 3µs | File::Path::BEGIN@18 |
| 9 | 1 | 1 | 3µs | 3µs | File::Path::CORE:ftdir (opcode) |
| 1 | 1 | 1 | 2µs | 2µs | File::Path::CORE:subst (opcode) |
| 0 | 0 | 0 | 0s | 0s | File::Path::_carp |
| 0 | 0 | 0 | 0s | 0s | File::Path::_croak |
| 0 | 0 | 0 | 0s | 0s | File::Path::_error |
| 0 | 0 | 0 | 0s | 0s | File::Path::_mkpath |
| 0 | 0 | 0 | 0s | 0s | File::Path::_slash_lc |
| 0 | 0 | 0 | 0s | 0s | File::Path::make_path |
| 0 | 0 | 0 | 0s | 0s | File::Path::mkpath |
| 0 | 0 | 0 | 0s | 0s | File::Path::remove_tree |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package File::Path; | ||||
| 2 | |||||
| 3 | 2 | 44µs | 1 | 17µs | # spent 17µs within File::Path::BEGIN@3 which was called:
# once (17µs+0s) by Bio::Root::IO::BEGIN@75 at line 3 # spent 17µs making 1 call to File::Path::BEGIN@3 |
| 4 | 2 | 23µs | 2 | 31µs | # spent 19µs (7+12) within File::Path::BEGIN@4 which was called:
# once (7µs+12µs) by Bio::Root::IO::BEGIN@75 at line 4 # spent 19µs making 1 call to File::Path::BEGIN@4
# spent 12µs making 1 call to strict::import |
| 5 | |||||
| 6 | 2 | 157µs | 2 | 3.26ms | # spent 3.22ms (2.99+228µs) within File::Path::BEGIN@6 which was called:
# once (2.99ms+228µs) by Bio::Root::IO::BEGIN@75 at line 6 # spent 3.22ms making 1 call to File::Path::BEGIN@6
# spent 44µs making 1 call to Exporter::import |
| 7 | 2 | 161µs | 1 | 1.38ms | # spent 1.38ms (1.24+141µs) within File::Path::BEGIN@7 which was called:
# once (1.24ms+141µs) by Bio::Root::IO::BEGIN@75 at line 7 # spent 1.38ms making 1 call to File::Path::BEGIN@7 |
| 8 | 2 | 30µs | 1 | 4µs | # spent 4µs within File::Path::BEGIN@8 which was called:
# once (4µs+0s) by Bio::Root::IO::BEGIN@75 at line 8 # spent 4µs making 1 call to File::Path::BEGIN@8 |
| 9 | |||||
| 10 | # spent 4µs within File::Path::BEGIN@10 which was called:
# once (4µs+0s) by Bio::Root::IO::BEGIN@75 at line 16 | ||||
| 11 | 1 | 4µs | if ($] < 5.006) { | ||
| 12 | # can't say 'opendir my $dh, $dirname' | ||||
| 13 | # need to initialise $dh | ||||
| 14 | eval "use Symbol"; | ||||
| 15 | } | ||||
| 16 | 1 | 14µs | 1 | 4µs | } # spent 4µs making 1 call to File::Path::BEGIN@10 |
| 17 | |||||
| 18 | 2 | 20µs | 1 | 3µs | # spent 3µs within File::Path::BEGIN@18 which was called:
# once (3µs+0s) by Bio::Root::IO::BEGIN@75 at line 18 # spent 3µs making 1 call to File::Path::BEGIN@18 |
| 19 | 2 | 1.48ms | 2 | 118µs | # spent 63µs (7+55) within File::Path::BEGIN@19 which was called:
# once (7µs+55µs) by Bio::Root::IO::BEGIN@75 at line 19 # spent 63µs making 1 call to File::Path::BEGIN@19
# spent 55µs making 1 call to vars::import |
| 20 | 1 | 700ns | $VERSION = '2.09'; | ||
| 21 | 1 | 6µs | @ISA = qw(Exporter); | ||
| 22 | 1 | 900ns | @EXPORT = qw(mkpath rmtree); | ||
| 23 | 1 | 400ns | @EXPORT_OK = qw(make_path remove_tree); | ||
| 24 | |||||
| 25 | 1 | 1µs | my $Is_VMS = $^O eq 'VMS'; | ||
| 26 | 1 | 400ns | my $Is_MacOS = $^O eq 'MacOS'; | ||
| 27 | |||||
| 28 | # These OSes complain if you want to remove a file that you have no | ||||
| 29 | # write permission to: | ||||
| 30 | 1 | 2µs | my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); | ||
| 31 | |||||
| 32 | # Unix-like systems need to stat each directory in order to detect | ||||
| 33 | # race condition. MS-Windows is immune to this particular attack. | ||||
| 34 | 1 | 400ns | my $Need_Stat_Check = !($^O eq 'MSWin32'); | ||
| 35 | |||||
| 36 | sub _carp { | ||||
| 37 | require Carp; | ||||
| 38 | goto &Carp::carp; | ||||
| 39 | } | ||||
| 40 | |||||
| 41 | sub _croak { | ||||
| 42 | require Carp; | ||||
| 43 | goto &Carp::croak; | ||||
| 44 | } | ||||
| 45 | |||||
| 46 | sub _error { | ||||
| 47 | my $arg = shift; | ||||
| 48 | my $message = shift; | ||||
| 49 | my $object = shift; | ||||
| 50 | |||||
| 51 | if ($arg->{error}) { | ||||
| 52 | $object = '' unless defined $object; | ||||
| 53 | $message .= ": $!" if $!; | ||||
| 54 | push @{${$arg->{error}}}, {$object => $message}; | ||||
| 55 | } | ||||
| 56 | else { | ||||
| 57 | _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); | ||||
| 58 | } | ||||
| 59 | } | ||||
| 60 | |||||
| 61 | sub make_path { | ||||
| 62 | push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); | ||||
| 63 | goto &mkpath; | ||||
| 64 | } | ||||
| 65 | |||||
| 66 | sub mkpath { | ||||
| 67 | my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); | ||||
| 68 | |||||
| 69 | my $arg; | ||||
| 70 | my $paths; | ||||
| 71 | |||||
| 72 | if ($old_style) { | ||||
| 73 | my ($verbose, $mode); | ||||
| 74 | ($paths, $verbose, $mode) = @_; | ||||
| 75 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); | ||||
| 76 | $arg->{verbose} = $verbose; | ||||
| 77 | $arg->{mode} = defined $mode ? $mode : 0777; | ||||
| 78 | } | ||||
| 79 | else { | ||||
| 80 | $arg = pop @_; | ||||
| 81 | $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; | ||||
| 82 | $arg->{mode} = 0777 unless exists $arg->{mode}; | ||||
| 83 | ${$arg->{error}} = [] if exists $arg->{error}; | ||||
| 84 | $arg->{owner} = delete $arg->{user} if exists $arg->{user}; | ||||
| 85 | $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; | ||||
| 86 | if (exists $arg->{owner} and $arg->{owner} =~ /\D/) { | ||||
| 87 | my $uid = (getpwnam $arg->{owner})[2]; | ||||
| 88 | if (defined $uid) { | ||||
| 89 | $arg->{owner} = $uid; | ||||
| 90 | } | ||||
| 91 | else { | ||||
| 92 | _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed"); | ||||
| 93 | delete $arg->{owner}; | ||||
| 94 | } | ||||
| 95 | } | ||||
| 96 | if (exists $arg->{group} and $arg->{group} =~ /\D/) { | ||||
| 97 | my $gid = (getgrnam $arg->{group})[2]; | ||||
| 98 | if (defined $gid) { | ||||
| 99 | $arg->{group} = $gid; | ||||
| 100 | } | ||||
| 101 | else { | ||||
| 102 | _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed"); | ||||
| 103 | delete $arg->{group}; | ||||
| 104 | } | ||||
| 105 | } | ||||
| 106 | if (exists $arg->{owner} and not exists $arg->{group}) { | ||||
| 107 | $arg->{group} = -1; # chown will leave group unchanged | ||||
| 108 | } | ||||
| 109 | if (exists $arg->{group} and not exists $arg->{owner}) { | ||||
| 110 | $arg->{owner} = -1; # chown will leave owner unchanged | ||||
| 111 | } | ||||
| 112 | $paths = [@_]; | ||||
| 113 | } | ||||
| 114 | return _mkpath($arg, $paths); | ||||
| 115 | } | ||||
| 116 | |||||
| 117 | sub _mkpath { | ||||
| 118 | my $arg = shift; | ||||
| 119 | my $paths = shift; | ||||
| 120 | |||||
| 121 | my(@created,$path); | ||||
| 122 | foreach $path (@$paths) { | ||||
| 123 | next unless defined($path) and length($path); | ||||
| 124 | $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT | ||||
| 125 | # Logic wants Unix paths, so go with the flow. | ||||
| 126 | if ($Is_VMS) { | ||||
| 127 | next if $path eq '/'; | ||||
| 128 | $path = VMS::Filespec::unixify($path); | ||||
| 129 | } | ||||
| 130 | next if -d $path; | ||||
| 131 | my $parent = File::Basename::dirname($path); | ||||
| 132 | unless (-d $parent or $path eq $parent) { | ||||
| 133 | push(@created,_mkpath($arg, [$parent])); | ||||
| 134 | } | ||||
| 135 | print "mkdir $path\n" if $arg->{verbose}; | ||||
| 136 | if (mkdir($path,$arg->{mode})) { | ||||
| 137 | push(@created, $path); | ||||
| 138 | if (exists $arg->{owner}) { | ||||
| 139 | # NB: $arg->{group} guaranteed to be set during initialisation | ||||
| 140 | if (!chown $arg->{owner}, $arg->{group}, $path) { | ||||
| 141 | _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}"); | ||||
| 142 | } | ||||
| 143 | } | ||||
| 144 | } | ||||
| 145 | else { | ||||
| 146 | my $save_bang = $!; | ||||
| 147 | my ($e, $e1) = ($save_bang, $^E); | ||||
| 148 | $e .= "; $e1" if $e ne $e1; | ||||
| 149 | # allow for another process to have created it meanwhile | ||||
| 150 | if (!-d $path) { | ||||
| 151 | $! = $save_bang; | ||||
| 152 | if ($arg->{error}) { | ||||
| 153 | push @{${$arg->{error}}}, {$path => $e}; | ||||
| 154 | } | ||||
| 155 | else { | ||||
| 156 | _croak("mkdir $path: $e"); | ||||
| 157 | } | ||||
| 158 | } | ||||
| 159 | } | ||||
| 160 | } | ||||
| 161 | return @created; | ||||
| 162 | } | ||||
| 163 | |||||
| 164 | sub remove_tree { | ||||
| 165 | push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); | ||||
| 166 | goto &rmtree; | ||||
| 167 | } | ||||
| 168 | |||||
| 169 | # spent 83µs (50+33) within File::Path::_is_subdir which was called:
# once (50µs+33µs) by File::Path::rmtree at line 230 | ||||
| 170 | 1 | 2µs | my($dir, $test) = @_; | ||
| 171 | |||||
| 172 | 1 | 22µs | 1 | 18µs | my($dv, $dd) = File::Spec->splitpath($dir, 1); # spent 18µs making 1 call to File::Spec::Unix::splitpath |
| 173 | 1 | 4µs | 1 | 3µs | my($tv, $td) = File::Spec->splitpath($test, 1); # spent 3µs making 1 call to File::Spec::Unix::splitpath |
| 174 | |||||
| 175 | # not on same volume | ||||
| 176 | 1 | 600ns | return 0 if $dv ne $tv; | ||
| 177 | |||||
| 178 | 1 | 5µs | 1 | 9µs | my @d = File::Spec->splitdir($dd); # spent 9µs making 1 call to File::Spec::Unix::splitdir |
| 179 | 1 | 3µs | 1 | 2µs | my @t = File::Spec->splitdir($td); # spent 2µs making 1 call to File::Spec::Unix::splitdir |
| 180 | |||||
| 181 | # @t can't be a subdir if it's shorter than @d | ||||
| 182 | 1 | 11µs | return 0 if @t < @d; | ||
| 183 | |||||
| 184 | return join('/', @d) eq join('/', splice @t, 0, +@d); | ||||
| 185 | } | ||||
| 186 | |||||
| 187 | # spent 1.29ms (136µs+1.16) within File::Path::rmtree which was called:
# once (136µs+1.16ms) by File::Temp::Dir::DESTROY at line 1616 of File/Temp.pm | ||||
| 188 | 1 | 10µs | 1 | 3µs | my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); # spent 3µs making 1 call to UNIVERSAL::isa |
| 189 | |||||
| 190 | 1 | 200ns | my $arg; | ||
| 191 | 1 | 300ns | my $paths; | ||
| 192 | |||||
| 193 | 1 | 600ns | if ($old_style) { | ||
| 194 | 1 | 300ns | my ($verbose, $safe); | ||
| 195 | 1 | 2µs | ($paths, $verbose, $safe) = @_; | ||
| 196 | 1 | 4µs | $arg->{verbose} = $verbose; | ||
| 197 | 1 | 4µs | $arg->{safe} = defined $safe ? $safe : 0; | ||
| 198 | |||||
| 199 | 1 | 11µs | 1 | 4µs | if (defined($paths) and length($paths)) { # spent 4µs making 1 call to UNIVERSAL::isa |
| 200 | $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); | ||||
| 201 | } | ||||
| 202 | else { | ||||
| 203 | _carp ("No root path(s) specified\n"); | ||||
| 204 | return 0; | ||||
| 205 | } | ||||
| 206 | } | ||||
| 207 | else { | ||||
| 208 | $arg = pop @_; | ||||
| 209 | ${$arg->{error}} = [] if exists $arg->{error}; | ||||
| 210 | ${$arg->{result}} = [] if exists $arg->{result}; | ||||
| 211 | $paths = [@_]; | ||||
| 212 | } | ||||
| 213 | |||||
| 214 | 1 | 1µs | $arg->{prefix} = ''; | ||
| 215 | 1 | 500ns | $arg->{depth} = 0; | ||
| 216 | |||||
| 217 | 1 | 700ns | my @clean_path; | ||
| 218 | 1 | 42µs | 1 | 26µs | $arg->{cwd} = getcwd() or do { # spent 26µs making 1 call to Cwd::getcwd |
| 219 | _error($arg, "cannot fetch initial working directory"); | ||||
| 220 | return 0; | ||||
| 221 | }; | ||||
| 222 | 3 | 29µs | 1 | 14µs | for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint # spent 14µs making 1 call to File::Path::CORE:match |
| 223 | |||||
| 224 | 1 | 4µs | for my $p (@$paths) { | ||
| 225 | # need to fixup case and map \ to / on Windows | ||||
| 226 | 1 | 7µs | my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p; | ||
| 227 | 1 | 2µs | my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd}; | ||
| 228 | 1 | 500ns | my $ortho_root_length = length($ortho_root); | ||
| 229 | 1 | 500ns | $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']' | ||
| 230 | 1 | 6µs | 1 | 83µs | if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) { # spent 83µs making 1 call to File::Path::_is_subdir |
| 231 | local $! = 0; | ||||
| 232 | _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p); | ||||
| 233 | next; | ||||
| 234 | } | ||||
| 235 | |||||
| 236 | 1 | 2µs | if ($Is_MacOS) { | ||
| 237 | $p = ":$p" unless $p =~ /:/; | ||||
| 238 | $p .= ":" unless $p =~ /:\z/; | ||||
| 239 | } | ||||
| 240 | elsif ($^O eq 'MSWin32') { | ||||
| 241 | $p =~ s{[/\\]\z}{}; | ||||
| 242 | } | ||||
| 243 | else { | ||||
| 244 | 1 | 8µs | 1 | 2µs | $p =~ s{/\z}{}; # spent 2µs making 1 call to File::Path::CORE:subst |
| 245 | } | ||||
| 246 | 1 | 2µs | push @clean_path, $p; | ||
| 247 | } | ||||
| 248 | |||||
| 249 | 1 | 30µs | 1 | 14µs | @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do { # spent 14µs making 1 call to File::Path::CORE:lstat |
| 250 | _error($arg, "cannot stat initial working directory", $arg->{cwd}); | ||||
| 251 | return 0; | ||||
| 252 | }; | ||||
| 253 | |||||
| 254 | 1 | 24µs | 1 | 1.01ms | return _rmtree($arg, \@clean_path); # spent 1.01ms making 1 call to File::Path::_rmtree |
| 255 | } | ||||
| 256 | |||||
| 257 | sub _rmtree { | ||||
| 258 | 2 | 1µs | my $arg = shift; | ||
| 259 | 2 | 400ns | my $paths = shift; | ||
| 260 | |||||
| 261 | 2 | 600ns | my $count = 0; | ||
| 262 | 2 | 16µs | 2 | 13µs | my $curdir = File::Spec->curdir(); # spent 13µs making 2 calls to File::Spec::Unix::curdir, avg 7µs/call |
| 263 | 2 | 28µs | 2 | 9µs | my $updir = File::Spec->updir(); # spent 9µs making 2 calls to File::Spec::Unix::updir, avg 5µs/call |
| 264 | |||||
| 265 | 2 | 700ns | my (@files, $root); | ||
| 266 | ROOT_DIR: | ||||
| 267 | 2 | 6µs | foreach $root (@$paths) { | ||
| 268 | # since we chdir into each directory, it may not be obvious | ||||
| 269 | # to figure out where we are if we generate a message about | ||||
| 270 | # a file name. We therefore construct a semi-canonical | ||||
| 271 | # filename, anchored from the directory being unlinked (as | ||||
| 272 | # opposed to being truly canonical, anchored from the root (/). | ||||
| 273 | |||||
| 274 | 9 | 161µs | 32 | 175µs | my $canon = $arg->{prefix} # spent 122µs making 8 calls to File::Spec::Unix::catfile, avg 15µs/call
# spent 38µs making 8 calls to File::Spec::Unix::catdir, avg 5µs/call
# spent 15µs making 16 calls to File::Spec::Unix::canonpath, avg 944ns/call |
| 275 | ? File::Spec->catfile($arg->{prefix}, $root) | ||||
| 276 | : $root | ||||
| 277 | ; | ||||
| 278 | |||||
| 279 | 9 | 72µs | 9 | 42µs | my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; # spent 42µs making 9 calls to File::Path::CORE:lstat, avg 5µs/call |
| 280 | |||||
| 281 | 9 | 30µs | 9 | 3µs | if ( -d _ ) { # spent 3µs making 9 calls to File::Path::CORE:ftdir, avg 311ns/call |
| 282 | 1 | 500ns | $root = VMS::Filespec::vmspath(VMS::Filespec::pathify($root)) if $Is_VMS; | ||
| 283 | |||||
| 284 | 1 | 24µs | 1 | 8µs | if (!chdir($root)) { # spent 8µs making 1 call to File::Path::CORE:chdir |
| 285 | # see if we can escalate privileges to get in | ||||
| 286 | # (e.g. funny protection mask such as -w- instead of rwx) | ||||
| 287 | $perm &= 07777; | ||||
| 288 | my $nperm = $perm | 0700; | ||||
| 289 | if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { | ||||
| 290 | _error($arg, "cannot make child directory read-write-exec", $canon); | ||||
| 291 | next ROOT_DIR; | ||||
| 292 | } | ||||
| 293 | elsif (!chdir($root)) { | ||||
| 294 | _error($arg, "cannot chdir to child", $canon); | ||||
| 295 | next ROOT_DIR; | ||||
| 296 | } | ||||
| 297 | } | ||||
| 298 | |||||
| 299 | 1 | 12µs | 1 | 3µs | my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do { # spent 3µs making 1 call to File::Path::CORE:stat |
| 300 | _error($arg, "cannot stat current working directory", $canon); | ||||
| 301 | next ROOT_DIR; | ||||
| 302 | }; | ||||
| 303 | |||||
| 304 | 1 | 3µs | if ($Need_Stat_Check) { | ||
| 305 | ($ldev eq $cur_dev and $lino eq $cur_inode) | ||||
| 306 | or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); | ||||
| 307 | } | ||||
| 308 | |||||
| 309 | 1 | 9µs | $perm &= 07777; # don't forget setuid, setgid, sticky bits | ||
| 310 | 1 | 800ns | my $nperm = $perm | 0700; | ||
| 311 | |||||
| 312 | # notabene: 0700 is for making readable in the first place, | ||||
| 313 | # it's also intended to change it to writable in case we have | ||||
| 314 | # to recurse in which case we are better than rm -rf for | ||||
| 315 | # subtrees with strange permissions | ||||
| 316 | |||||
| 317 | 1 | 900ns | if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { | ||
| 318 | _error($arg, "cannot make directory read+writeable", $canon); | ||||
| 319 | $nperm = $perm; | ||||
| 320 | } | ||||
| 321 | |||||
| 322 | 1 | 200ns | my $d; | ||
| 323 | 1 | 4µs | $d = gensym() if $] < 5.006; | ||
| 324 | 1 | 39µs | 1 | 17µs | if (!opendir $d, $curdir) { # spent 17µs making 1 call to File::Path::CORE:open_dir |
| 325 | _error($arg, "cannot opendir", $canon); | ||||
| 326 | @files = (); | ||||
| 327 | } | ||||
| 328 | else { | ||||
| 329 | 2 | 621µs | 2 | 34µs | # spent 22µs (9+13) within File::Path::BEGIN@329 which was called:
# once (9µs+13µs) by Bio::Root::IO::BEGIN@75 at line 329 # spent 22µs making 1 call to File::Path::BEGIN@329
# spent 13µs making 1 call to strict::unimport |
| 330 | 1 | 11µs | if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { | ||
| 331 | # Blindly untaint dir names if taint mode is | ||||
| 332 | # active, or any perl < 5.006 | ||||
| 333 | @files = map { /\A(.*)\z/s; $1 } readdir $d; | ||||
| 334 | } | ||||
| 335 | else { | ||||
| 336 | 1 | 54µs | 1 | 43µs | @files = readdir $d; # spent 43µs making 1 call to File::Path::CORE:readdir |
| 337 | } | ||||
| 338 | 1 | 18µs | 1 | 12µs | closedir $d; # spent 12µs making 1 call to File::Path::CORE:closedir |
| 339 | } | ||||
| 340 | |||||
| 341 | 1 | 400ns | if ($Is_VMS) { | ||
| 342 | # Deleting large numbers of files from VMS Files-11 | ||||
| 343 | # filesystems is faster if done in reverse ASCIIbetical order. | ||||
| 344 | # include '.' to '.;' from blead patch #31775 | ||||
| 345 | @files = map {$_ eq '.' ? '.;' : $_} reverse @files; | ||||
| 346 | } | ||||
| 347 | |||||
| 348 | 1 | 8µs | @files = grep {$_ ne $updir and $_ ne $curdir} @files; | ||
| 349 | |||||
| 350 | 1 | 900ns | if (@files) { | ||
| 351 | # remove the contained files before the directory itself | ||||
| 352 | 1 | 12µs | my $narg = {%$arg}; | ||
| 353 | 1 | 6µs | @{$narg}{qw(device inode cwd prefix depth)} | ||
| 354 | = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1); | ||||
| 355 | 1 | 19µs | 1 | 0s | $count += _rmtree($narg, \@files); # spent 604µs making 1 call to File::Path::_rmtree, recursion: max depth 1, sum of overlapping time 604µs |
| 356 | } | ||||
| 357 | |||||
| 358 | # restore directory permissions of required now (in case the rmdir | ||||
| 359 | # below fails), while we are still in the directory and may do so | ||||
| 360 | # without a race via '.' | ||||
| 361 | 1 | 600ns | if ($nperm != $perm and not chmod($perm, $curdir)) { | ||
| 362 | _error($arg, "cannot reset chmod", $canon); | ||||
| 363 | } | ||||
| 364 | |||||
| 365 | # don't leave the client code in an unexpected directory | ||||
| 366 | 1 | 12µs | 1 | 6µs | chdir($arg->{cwd}) # spent 6µs making 1 call to File::Path::CORE:chdir |
| 367 | or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); | ||||
| 368 | |||||
| 369 | # ensure that a chdir upwards didn't take us somewhere other | ||||
| 370 | # than we expected (see CVE-2002-0435) | ||||
| 371 | 1 | 9µs | 1 | 4µs | ($cur_dev, $cur_inode) = (stat $curdir)[0,1] # spent 4µs making 1 call to File::Path::CORE:stat |
| 372 | or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); | ||||
| 373 | |||||
| 374 | 1 | 3µs | if ($Need_Stat_Check) { | ||
| 375 | ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode) | ||||
| 376 | or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); | ||||
| 377 | } | ||||
| 378 | |||||
| 379 | 1 | 5µs | if ($arg->{depth} or !$arg->{keep_root}) { | ||
| 380 | 1 | 400ns | if ($arg->{safe} && | ||
| 381 | ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { | ||||
| 382 | print "skipped $root\n" if $arg->{verbose}; | ||||
| 383 | next ROOT_DIR; | ||||
| 384 | } | ||||
| 385 | 1 | 300ns | if ($Force_Writeable and !chmod $perm | 0700, $root) { | ||
| 386 | _error($arg, "cannot make directory writeable", $canon); | ||||
| 387 | } | ||||
| 388 | 1 | 400ns | print "rmdir $root\n" if $arg->{verbose}; | ||
| 389 | 1 | 59µs | 1 | 48µs | if (rmdir $root) { # spent 48µs making 1 call to File::Path::CORE:rmdir |
| 390 | 1 | 900ns | push @{${$arg->{result}}}, $root if $arg->{result}; | ||
| 391 | 1 | 500ns | ++$count; | ||
| 392 | } | ||||
| 393 | else { | ||||
| 394 | _error($arg, "cannot remove directory", $canon); | ||||
| 395 | if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) | ||||
| 396 | ) { | ||||
| 397 | _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); | ||||
| 398 | } | ||||
| 399 | } | ||||
| 400 | } | ||||
| 401 | } | ||||
| 402 | else { | ||||
| 403 | # not a directory | ||||
| 404 | 8 | 1µs | $root = VMS::Filespec::vmsify("./$root") | ||
| 405 | if $Is_VMS | ||||
| 406 | && !File::Spec->file_name_is_absolute($root) | ||||
| 407 | && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax | ||||
| 408 | |||||
| 409 | 8 | 3µs | if ($arg->{safe} && | ||
| 410 | ($Is_VMS ? !&VMS::Filespec::candelete($root) | ||||
| 411 | : !(-l $root || -w $root))) | ||||
| 412 | { | ||||
| 413 | print "skipped $root\n" if $arg->{verbose}; | ||||
| 414 | next ROOT_DIR; | ||||
| 415 | } | ||||
| 416 | |||||
| 417 | 8 | 3µs | my $nperm = $perm & 07777 | 0600; | ||
| 418 | 8 | 900ns | if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) { | ||
| 419 | _error($arg, "cannot make file writeable", $canon); | ||||
| 420 | } | ||||
| 421 | 8 | 1µs | print "unlink $canon\n" if $arg->{verbose}; | ||
| 422 | # delete all versions under VMS | ||||
| 423 | 8 | 1µs | for (;;) { | ||
| 424 | 8 | 308µs | 8 | 281µs | if (unlink $root) { # spent 281µs making 8 calls to File::Path::CORE:unlink, avg 35µs/call |
| 425 | push @{${$arg->{result}}}, $root if $arg->{result}; | ||||
| 426 | } | ||||
| 427 | else { | ||||
| 428 | _error($arg, "cannot unlink file", $canon); | ||||
| 429 | $Force_Writeable and chmod($perm, $root) or | ||||
| 430 | _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); | ||||
| 431 | last; | ||||
| 432 | } | ||||
| 433 | 8 | 1µs | ++$count; | ||
| 434 | 8 | 6µs | last unless $Is_VMS && lstat $root; | ||
| 435 | } | ||||
| 436 | } | ||||
| 437 | } | ||||
| 438 | 2 | 16µs | return $count; | ||
| 439 | } | ||||
| 440 | |||||
| 441 | sub _slash_lc { | ||||
| 442 | # fix up slashes and case on MSWin32 so that we can determine that | ||||
| 443 | # c:\path\to\dir is underneath C:/Path/To | ||||
| 444 | my $path = shift; | ||||
| 445 | $path =~ tr{\\}{/}; | ||||
| 446 | return lc($path); | ||||
| 447 | } | ||||
| 448 | |||||
| 449 | 1 | 13µs | 1; | ||
| 450 | __END__ | ||||
sub File::Path::CORE:chdir; # opcode | |||||
# spent 12µs within File::Path::CORE:closedir which was called:
# once (12µs+0s) by File::Path::_rmtree at line 338 | |||||
# spent 3µs within File::Path::CORE:ftdir which was called 9 times, avg 311ns/call:
# 9 times (3µs+0s) by File::Path::_rmtree at line 281, avg 311ns/call | |||||
sub File::Path::CORE:lstat; # opcode | |||||
# spent 14µs within File::Path::CORE:match which was called:
# once (14µs+0s) by File::Path::rmtree at line 222 | |||||
# spent 17µs within File::Path::CORE:open_dir which was called:
# once (17µs+0s) by File::Path::_rmtree at line 324 | |||||
# spent 43µs within File::Path::CORE:readdir which was called:
# once (43µs+0s) by File::Path::_rmtree at line 336 | |||||
# spent 48µs within File::Path::CORE:rmdir which was called:
# once (48µs+0s) by File::Path::_rmtree at line 389 | |||||
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 244 | |||||
# spent 281µs within File::Path::CORE:unlink which was called 8 times, avg 35µs/call:
# 8 times (281µs+0s) by File::Path::_rmtree at line 424, avg 35µs/call |