| Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/File/Path.pm |
| Statements | Executed 30 statements in 2.08ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 946µs | 1.03ms | File::Path::BEGIN@7 |
| 1 | 1 | 1 | 12µs | 12µs | File::Path::BEGIN@27 |
| 1 | 1 | 1 | 10µs | 10µs | File::Path::BEGIN@3 |
| 1 | 1 | 1 | 5µs | 29µs | File::Path::BEGIN@6 |
| 1 | 1 | 1 | 4µs | 8µs | File::Path::BEGIN@29 |
| 1 | 1 | 1 | 4µs | 5µs | File::Path::BEGIN@4 |
| 1 | 1 | 1 | 4µs | 31µs | File::Path::BEGIN@20 |
| 1 | 1 | 1 | 2µs | 2µs | File::Path::BEGIN@8 |
| 1 | 1 | 1 | 2µs | 2µs | File::Path::BEGIN@10 |
| 1 | 1 | 1 | 1µs | 1µs | File::Path::BEGIN@19 |
| 1 | 1 | 1 | 400ns | 400ns | File::Path::__ANON__ (xsub) |
| 0 | 0 | 0 | 0s | 0s | File::Path::__is_arg |
| 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::_is_subdir |
| 0 | 0 | 0 | 0s | 0s | File::Path::_mkpath |
| 0 | 0 | 0 | 0s | 0s | File::Path::_rmtree |
| 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 |
| 0 | 0 | 0 | 0s | 0s | File::Path::rmtree |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package File::Path; | ||||
| 2 | |||||
| 3 | 2 | 33µs | 1 | 10µs | # spent 10µs within File::Path::BEGIN@3 which was called:
# once (10µs+0s) by File::Temp::BEGIN@149 at line 3 # spent 10µs making 1 call to File::Path::BEGIN@3 |
| 4 | 2 | 15µs | 2 | 7µs | # spent 5µs (4+1) within File::Path::BEGIN@4 which was called:
# once (4µs+1µs) by File::Temp::BEGIN@149 at line 4 # spent 5µs making 1 call to File::Path::BEGIN@4
# spent 1µs making 1 call to strict::import |
| 5 | |||||
| 6 | 2 | 14µs | 2 | 53µs | # spent 29µs (5+24) within File::Path::BEGIN@6 which was called:
# once (5µs+24µs) by File::Temp::BEGIN@149 at line 6 # spent 29µs making 1 call to File::Path::BEGIN@6
# spent 24µs making 1 call to Exporter::import |
| 7 | 2 | 112µs | 1 | 1.03ms | # spent 1.03ms (946µs+84µs) within File::Path::BEGIN@7 which was called:
# once (946µs+84µs) by File::Temp::BEGIN@149 at line 7 # spent 1.03ms making 1 call to File::Path::BEGIN@7 |
| 8 | 2 | 22µs | 1 | 2µs | # spent 2µs within File::Path::BEGIN@8 which was called:
# once (2µs+0s) by File::Temp::BEGIN@149 at line 8 # spent 2µs making 1 call to File::Path::BEGIN@8 |
| 9 | |||||
| 10 | # spent 2µs within File::Path::BEGIN@10 which was called:
# once (2µs+0s) by File::Temp::BEGIN@149 at line 17 | ||||
| 11 | 1 | 2µs | if ( $] < 5.006 ) { | ||
| 12 | |||||
| 13 | # can't say 'opendir my $dh, $dirname' | ||||
| 14 | # need to initialise $dh | ||||
| 15 | eval 'use Symbol'; | ||||
| 16 | } | ||||
| 17 | 1 | 9µs | 1 | 2µs | } # spent 2µs making 1 call to File::Path::BEGIN@10 |
| 18 | |||||
| 19 | 2 | 12µs | 1 | 1µs | # spent 1µs within File::Path::BEGIN@19 which was called:
# once (1µs+0s) by File::Temp::BEGIN@149 at line 19 # spent 1µs making 1 call to File::Path::BEGIN@19 |
| 20 | 2 | 34µs | 2 | 58µs | # spent 31µs (4+27) within File::Path::BEGIN@20 which was called:
# once (4µs+27µs) by File::Temp::BEGIN@149 at line 20 # spent 31µs making 1 call to File::Path::BEGIN@20
# spent 27µs making 1 call to vars::import |
| 21 | 1 | 400ns | $VERSION = '2.18'; | ||
| 22 | 1 | 11µs | $VERSION = eval $VERSION; # spent 2µs executing statements in string eval | ||
| 23 | 1 | 5µs | @ISA = qw(Exporter); | ||
| 24 | 1 | 500ns | @EXPORT = qw(mkpath rmtree); | ||
| 25 | 1 | 200ns | @EXPORT_OK = qw(make_path remove_tree); | ||
| 26 | |||||
| 27 | # spent 12µs (12+400ns) within File::Path::BEGIN@27 which was called:
# once (12µs+400ns) by File::Temp::BEGIN@149 at line 42 | ||||
| 28 | 1 | 300ns | for (qw(VMS MacOS MSWin32 os2)) { | ||
| 29 | 2 | 80µs | 2 | 12µs | # spent 8µs (4+4) within File::Path::BEGIN@29 which was called:
# once (4µs+4µs) by File::Temp::BEGIN@149 at line 29 # spent 8µs making 1 call to File::Path::BEGIN@29
# spent 4µs making 1 call to strict::unimport |
| 30 | 4 | 5µ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) | ||||
| 37 | 1 | 1µ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. | ||||
| 41 | 1 | 5µs | 1 | 400ns | *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; # spent 400ns making 1 call to File::Path::__ANON__ |
| 42 | 1 | 1.71ms | 1 | 12µs | } # spent 12µs making 1 call to File::Path::BEGIN@27 |
| 43 | |||||
| 44 | sub _carp { | ||||
| 45 | require Carp; | ||||
| 46 | goto &Carp::carp; | ||||
| 47 | } | ||||
| 48 | |||||
| 49 | sub _croak { | ||||
| 50 | require Carp; | ||||
| 51 | goto &Carp::croak; | ||||
| 52 | } | ||||
| 53 | |||||
| 54 | sub _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 | sub __is_arg { | ||||
| 70 | 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 | ||||
| 77 | return ( ref $arg eq 'HASH' ); | ||||
| 78 | } | ||||
| 79 | |||||
| 80 | sub make_path { | ||||
| 81 | push @_, {} unless @_ and __is_arg( $_[-1] ); | ||||
| 82 | goto &mkpath; | ||||
| 83 | } | ||||
| 84 | |||||
| 85 | sub 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 | |||||
| 176 | sub _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 | |||||
| 247 | sub remove_tree { | ||||
| 248 | push @_, {} unless @_ and __is_arg( $_[-1] ); | ||||
| 249 | goto &rmtree; | ||||
| 250 | } | ||||
| 251 | |||||
| 252 | sub _is_subdir { | ||||
| 253 | my ( $dir, $test ) = @_; | ||||
| 254 | |||||
| 255 | my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 ); | ||||
| 256 | my ( $tv, $td ) = File::Spec->splitpath( $test, 1 ); | ||||
| 257 | |||||
| 258 | # not on same volume | ||||
| 259 | return 0 if $dv ne $tv; | ||||
| 260 | |||||
| 261 | my @d = File::Spec->splitdir($dd); | ||||
| 262 | my @t = File::Spec->splitdir($td); | ||||
| 263 | |||||
| 264 | # @t can't be a subdir if it's shorter than @d | ||||
| 265 | return 0 if @t < @d; | ||||
| 266 | |||||
| 267 | return join( '/', @d ) eq join( '/', splice @t, 0, +@d ); | ||||
| 268 | } | ||||
| 269 | |||||
| 270 | sub rmtree { | ||||
| 271 | my $old_style = !( @_ and __is_arg( $_[-1] ) ); | ||||
| 272 | |||||
| 273 | my ($arg, $data, $paths); | ||||
| 274 | |||||
| 275 | if ($old_style) { | ||||
| 276 | my ( $verbose, $safe ); | ||||
| 277 | ( $paths, $verbose, $safe ) = @_; | ||||
| 278 | $data->{verbose} = $verbose; | ||||
| 279 | $data->{safe} = defined $safe ? $safe : 0; | ||||
| 280 | |||||
| 281 | if ( defined($paths) and length($paths) ) { | ||||
| 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 | |||||
| 324 | $data->{prefix} = ''; | ||||
| 325 | $data->{depth} = 0; | ||||
| 326 | |||||
| 327 | my @clean_path; | ||||
| 328 | $data->{cwd} = getcwd() or do { | ||||
| 329 | _error( $data, "cannot fetch initial working directory" ); | ||||
| 330 | return 0; | ||||
| 331 | }; | ||||
| 332 | for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint | ||||
| 333 | |||||
| 334 | for my $p (@$paths) { | ||||
| 335 | |||||
| 336 | # need to fixup case and map \ to / on Windows | ||||
| 337 | my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; | ||||
| 338 | my $ortho_cwd = | ||||
| 339 | _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd}; | ||||
| 340 | my $ortho_root_length = length($ortho_root); | ||||
| 341 | $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' | ||||
| 342 | if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { | ||||
| 343 | local $! = 0; | ||||
| 344 | _error( $data, "cannot remove path when cwd is $data->{cwd}", $p ); | ||||
| 345 | next; | ||||
| 346 | } | ||||
| 347 | |||||
| 348 | 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 { | ||||
| 356 | $p =~ s{/\z}{}; | ||||
| 357 | } | ||||
| 358 | push @clean_path, $p; | ||||
| 359 | } | ||||
| 360 | |||||
| 361 | @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do { | ||||
| 362 | _error( $data, "cannot stat initial working directory", $data->{cwd} ); | ||||
| 363 | return 0; | ||||
| 364 | }; | ||||
| 365 | |||||
| 366 | return _rmtree( $data, \@clean_path ); | ||||
| 367 | } | ||||
| 368 | |||||
| 369 | sub _rmtree { | ||||
| 370 | my $data = shift; | ||||
| 371 | my $paths = shift; | ||||
| 372 | |||||
| 373 | my $count = 0; | ||||
| 374 | my $curdir = File::Spec->curdir(); | ||||
| 375 | my $updir = File::Spec->updir(); | ||||
| 376 | |||||
| 377 | my ( @files, $root ); | ||||
| 378 | ROOT_DIR: | ||||
| 379 | 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} | ||||
| 389 | ? File::Spec->catfile( $data->{prefix}, $root ) | ||||
| 390 | : $root; | ||||
| 391 | |||||
| 392 | my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] | ||||
| 393 | or next ROOT_DIR; | ||||
| 394 | |||||
| 395 | if ( -d _ ) { | ||||
| 396 | $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) ) | ||||
| 397 | if _IS_VMS; | ||||
| 398 | |||||
| 399 | if ( !chdir($root) ) { | ||||
| 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 ] | ||||
| 435 | or do { | ||||
| 436 | _error( $data, "cannot stat current working directory", $canon ); | ||||
| 437 | next ROOT_DIR; | ||||
| 438 | }; | ||||
| 439 | |||||
| 440 | 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 | |||||
| 447 | $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits | ||||
| 448 | 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 | |||||
| 455 | 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 | |||||
| 467 | my $d; | ||||
| 468 | $d = gensym() if $] < 5.006; | ||||
| 469 | if ( !opendir $d, $curdir ) { | ||||
| 470 | _error( $data, "cannot opendir", $canon ); | ||||
| 471 | @files = (); | ||||
| 472 | } | ||||
| 473 | else { | ||||
| 474 | 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 { | ||||
| 479 | @files = readdir $d; | ||||
| 480 | } | ||||
| 481 | closedir $d; | ||||
| 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 | |||||
| 492 | @files = grep { $_ ne $updir and $_ ne $curdir } @files; | ||||
| 493 | |||||
| 494 | if (@files) { | ||||
| 495 | |||||
| 496 | # remove the contained files before the directory itself | ||||
| 497 | my $narg = {%$data}; | ||||
| 498 | @{$narg}{qw(device inode cwd prefix depth)} = | ||||
| 499 | ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 ); | ||||
| 500 | $count += _rmtree( $narg, \@files ); | ||||
| 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 '.' | ||||
| 506 | 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} ) | ||||
| 512 | or | ||||
| 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) | ||||
| 517 | ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] | ||||
| 518 | or _croak( | ||||
| 519 | "cannot stat prior working directory $data->{cwd}: $!, aborting." | ||||
| 520 | ); | ||||
| 521 | |||||
| 522 | 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 | |||||
| 531 | if ( $data->{depth} or !$data->{keep_root} ) { | ||||
| 532 | 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 | } | ||||
| 543 | print "rmdir $root\n" if $data->{verbose}; | ||||
| 544 | if ( rmdir $root ) { | ||||
| 545 | push @{ ${ $data->{result} } }, $root if $data->{result}; | ||||
| 546 | ++$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 | |||||
| 574 | 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 | |||||
| 587 | 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 | } | ||||
| 594 | print "unlink $canon\n" if $data->{verbose}; | ||||
| 595 | |||||
| 596 | # delete all versions under VMS | ||||
| 597 | for ( ; ; ) { | ||||
| 598 | if ( unlink $root ) { | ||||
| 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 | } | ||||
| 609 | ++$count; | ||||
| 610 | last unless _IS_VMS && lstat $root; | ||||
| 611 | } | ||||
| 612 | } | ||||
| 613 | } | ||||
| 614 | return $count; | ||||
| 615 | } | ||||
| 616 | |||||
| 617 | sub _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 | |||||
| 626 | 1 | 3µs | 1; | ||
| 627 | |||||
| 628 | __END__ | ||||
# spent 400ns within File::Path::__ANON__ which was called:
# once (400ns+0s) by File::Path::BEGIN@27 at line 41 |