1b39c5158Smillertpackage File::Path; 2b39c5158Smillert 3b39c5158Smillertuse 5.005_04; 4b39c5158Smillertuse strict; 5b39c5158Smillert 6b39c5158Smillertuse Cwd 'getcwd'; 7b39c5158Smillertuse File::Basename (); 8b39c5158Smillertuse File::Spec (); 9b39c5158Smillert 10b39c5158SmillertBEGIN { 11b39c5158Smillert if ( $] < 5.006 ) { 12b8851fccSafresh1 13b39c5158Smillert # can't say 'opendir my $dh, $dirname' 14b39c5158Smillert # need to initialise $dh 15b8851fccSafresh1 eval 'use Symbol'; 16b39c5158Smillert } 17b39c5158Smillert} 18b39c5158Smillert 19b39c5158Smillertuse Exporter (); 20b39c5158Smillertuse vars qw($VERSION @ISA @EXPORT @EXPORT_OK); 21*eac174f2Safresh1$VERSION = '2.18'; 22b8851fccSafresh1$VERSION = eval $VERSION; 23b39c5158Smillert@ISA = qw(Exporter); 24b39c5158Smillert@EXPORT = qw(mkpath rmtree); 25b39c5158Smillert@EXPORT_OK = qw(make_path remove_tree); 26b39c5158Smillert 27b8851fccSafresh1BEGIN { 28b8851fccSafresh1 for (qw(VMS MacOS MSWin32 os2)) { 29b8851fccSafresh1 no strict 'refs'; 30b8851fccSafresh1 *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 }; 31b8851fccSafresh1 } 32b39c5158Smillert 33b39c5158Smillert # These OSes complain if you want to remove a file that you have no 34b39c5158Smillert # write permission to: 35b8851fccSafresh1 *_FORCE_WRITABLE = ( 36b8851fccSafresh1 grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2) 37b8851fccSafresh1 ) ? sub () { 1 } : sub () { 0 }; 38b39c5158Smillert 39b39c5158Smillert # Unix-like systems need to stat each directory in order to detect 40b39c5158Smillert # race condition. MS-Windows is immune to this particular attack. 41b8851fccSafresh1 *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 }; 42b8851fccSafresh1} 43b39c5158Smillert 44b39c5158Smillertsub _carp { 45b39c5158Smillert require Carp; 46b39c5158Smillert goto &Carp::carp; 47b39c5158Smillert} 48b39c5158Smillert 49b39c5158Smillertsub _croak { 50b39c5158Smillert require Carp; 51b39c5158Smillert goto &Carp::croak; 52b39c5158Smillert} 53b39c5158Smillert 54b39c5158Smillertsub _error { 55b39c5158Smillert my $arg = shift; 56b39c5158Smillert my $message = shift; 57b39c5158Smillert my $object = shift; 58b39c5158Smillert 59b39c5158Smillert if ( $arg->{error} ) { 60b39c5158Smillert $object = '' unless defined $object; 61b39c5158Smillert $message .= ": $!" if $!; 62b39c5158Smillert push @{ ${ $arg->{error} } }, { $object => $message }; 63b39c5158Smillert } 64b39c5158Smillert else { 65b39c5158Smillert _carp( defined($object) ? "$message for $object: $!" : "$message: $!" ); 66b39c5158Smillert } 67b39c5158Smillert} 68b39c5158Smillert 69b8851fccSafresh1sub __is_arg { 70b8851fccSafresh1 my ($arg) = @_; 71b8851fccSafresh1 72b8851fccSafresh1 # If client code blessed an array ref to HASH, this will not work 73b8851fccSafresh1 # properly. We could have done $arg->isa() wrapped in eval, but 74b8851fccSafresh1 # that would be expensive. This implementation should suffice. 75b8851fccSafresh1 # We could have also used Scalar::Util:blessed, but we choose not 76b8851fccSafresh1 # to add this dependency 77b8851fccSafresh1 return ( ref $arg eq 'HASH' ); 78b8851fccSafresh1} 79b8851fccSafresh1 80b39c5158Smillertsub make_path { 81b8851fccSafresh1 push @_, {} unless @_ and __is_arg( $_[-1] ); 82b39c5158Smillert goto &mkpath; 83b39c5158Smillert} 84b39c5158Smillert 85b39c5158Smillertsub mkpath { 86b8851fccSafresh1 my $old_style = !( @_ and __is_arg( $_[-1] ) ); 87b39c5158Smillert 882e109fb9Safresh1 my $data; 89b39c5158Smillert my $paths; 90b39c5158Smillert 91b39c5158Smillert if ($old_style) { 92b39c5158Smillert my ( $verbose, $mode ); 93b39c5158Smillert ( $paths, $verbose, $mode ) = @_; 94b39c5158Smillert $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); 952e109fb9Safresh1 $data->{verbose} = $verbose; 962e109fb9Safresh1 $data->{mode} = defined $mode ? $mode : oct '777'; 97b39c5158Smillert } 98b39c5158Smillert else { 99b8851fccSafresh1 my %args_permitted = map { $_ => 1 } ( qw| 100b8851fccSafresh1 chmod 101b8851fccSafresh1 error 102b8851fccSafresh1 group 103b8851fccSafresh1 mask 104b8851fccSafresh1 mode 105b8851fccSafresh1 owner 106b8851fccSafresh1 uid 107b8851fccSafresh1 user 108b8851fccSafresh1 verbose 109b8851fccSafresh1 | ); 1102e109fb9Safresh1 my %not_on_win32_args = map { $_ => 1 } ( qw| 1112e109fb9Safresh1 group 1122e109fb9Safresh1 owner 1132e109fb9Safresh1 uid 1142e109fb9Safresh1 user 1152e109fb9Safresh1 | ); 116b8851fccSafresh1 my @bad_args = (); 1172e109fb9Safresh1 my @win32_implausible_args = (); 1182e109fb9Safresh1 my $arg = pop @_; 119b8851fccSafresh1 for my $k (sort keys %{$arg}) { 1202e109fb9Safresh1 if (! $args_permitted{$k}) { 1212e109fb9Safresh1 push @bad_args, $k; 122b8851fccSafresh1 } 1232e109fb9Safresh1 elsif ($not_on_win32_args{$k} and _IS_MSWIN32) { 1242e109fb9Safresh1 push @win32_implausible_args, $k; 1252e109fb9Safresh1 } 1262e109fb9Safresh1 else { 1272e109fb9Safresh1 $data->{$k} = $arg->{$k}; 1282e109fb9Safresh1 } 1292e109fb9Safresh1 } 1302e109fb9Safresh1 _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args") 131b8851fccSafresh1 if @bad_args; 1322e109fb9Safresh1 _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args") 1332e109fb9Safresh1 if @win32_implausible_args; 1342e109fb9Safresh1 $data->{mode} = delete $data->{mask} if exists $data->{mask}; 1352e109fb9Safresh1 $data->{mode} = oct '777' unless exists $data->{mode}; 1362e109fb9Safresh1 ${ $data->{error} } = [] if exists $data->{error}; 1372e109fb9Safresh1 unless (@win32_implausible_args) { 1382e109fb9Safresh1 $data->{owner} = delete $data->{user} if exists $data->{user}; 1392e109fb9Safresh1 $data->{owner} = delete $data->{uid} if exists $data->{uid}; 1402e109fb9Safresh1 if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) { 1412e109fb9Safresh1 my $uid = ( getpwnam $data->{owner} )[2]; 142b39c5158Smillert if ( defined $uid ) { 1432e109fb9Safresh1 $data->{owner} = $uid; 144b39c5158Smillert } 145b39c5158Smillert else { 1462e109fb9Safresh1 _error( $data, 1472e109fb9Safresh1 "unable to map $data->{owner} to a uid, ownership not changed" 148b8851fccSafresh1 ); 1492e109fb9Safresh1 delete $data->{owner}; 150b39c5158Smillert } 151b39c5158Smillert } 1522e109fb9Safresh1 if ( exists $data->{group} and $data->{group} =~ /\D/ ) { 1532e109fb9Safresh1 my $gid = ( getgrnam $data->{group} )[2]; 154b39c5158Smillert if ( defined $gid ) { 1552e109fb9Safresh1 $data->{group} = $gid; 156b39c5158Smillert } 157b39c5158Smillert else { 1582e109fb9Safresh1 _error( $data, 1592e109fb9Safresh1 "unable to map $data->{group} to a gid, group ownership not changed" 160b8851fccSafresh1 ); 1612e109fb9Safresh1 delete $data->{group}; 162b39c5158Smillert } 163b39c5158Smillert } 1642e109fb9Safresh1 if ( exists $data->{owner} and not exists $data->{group} ) { 1652e109fb9Safresh1 $data->{group} = -1; # chown will leave group unchanged 166b39c5158Smillert } 1672e109fb9Safresh1 if ( exists $data->{group} and not exists $data->{owner} ) { 1682e109fb9Safresh1 $data->{owner} = -1; # chown will leave owner unchanged 1692e109fb9Safresh1 } 170b39c5158Smillert } 171b39c5158Smillert $paths = [@_]; 172b39c5158Smillert } 1732e109fb9Safresh1 return _mkpath( $data, $paths ); 174b39c5158Smillert} 175b39c5158Smillert 176b39c5158Smillertsub _mkpath { 1772e109fb9Safresh1 my $data = shift; 178b39c5158Smillert my $paths = shift; 179b39c5158Smillert 180b8851fccSafresh1 my ( @created ); 181b8851fccSafresh1 foreach my $path ( @{$paths} ) { 182b39c5158Smillert next unless defined($path) and length($path); 183b8851fccSafresh1 $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT 184b8851fccSafresh1 185b39c5158Smillert # Logic wants Unix paths, so go with the flow. 186b8851fccSafresh1 if (_IS_VMS) { 187b39c5158Smillert next if $path eq '/'; 188b39c5158Smillert $path = VMS::Filespec::unixify($path); 189b39c5158Smillert } 190b39c5158Smillert next if -d $path; 191b39c5158Smillert my $parent = File::Basename::dirname($path); 1922e109fb9Safresh1 # Coverage note: It's not clear how we would test the condition: 1932e109fb9Safresh1 # '-d $parent or $path eq $parent' 194b39c5158Smillert unless ( -d $parent or $path eq $parent ) { 1952e109fb9Safresh1 push( @created, _mkpath( $data, [$parent] ) ); 196b39c5158Smillert } 1972e109fb9Safresh1 print "mkdir $path\n" if $data->{verbose}; 1982e109fb9Safresh1 if ( mkdir( $path, $data->{mode} ) ) { 199b39c5158Smillert push( @created, $path ); 2002e109fb9Safresh1 if ( exists $data->{owner} ) { 201b8851fccSafresh1 2022e109fb9Safresh1 # NB: $data->{group} guaranteed to be set during initialisation 2032e109fb9Safresh1 if ( !chown $data->{owner}, $data->{group}, $path ) { 2042e109fb9Safresh1 _error( $data, 2052e109fb9Safresh1 "Cannot change ownership of $path to $data->{owner}:$data->{group}" 206b8851fccSafresh1 ); 207b8851fccSafresh1 } 208b8851fccSafresh1 } 2092e109fb9Safresh1 if ( exists $data->{chmod} ) { 2102e109fb9Safresh1 # Coverage note: It's not clear how we would trigger the next 2112e109fb9Safresh1 # 'if' block. Failure of 'chmod' might first result in a 2122e109fb9Safresh1 # system error: "Permission denied". 2132e109fb9Safresh1 if ( !chmod $data->{chmod}, $path ) { 2142e109fb9Safresh1 _error( $data, 2152e109fb9Safresh1 "Cannot change permissions of $path to $data->{chmod}" ); 216b39c5158Smillert } 217b39c5158Smillert } 218b39c5158Smillert } 219b39c5158Smillert else { 220b39c5158Smillert my $save_bang = $!; 2212e109fb9Safresh1 2222e109fb9Safresh1 # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented 2232e109fb9Safresh1 # as: 2242e109fb9Safresh1 # Error information specific to the current operating system. At the 2252e109fb9Safresh1 # moment, this differs from "$!" under only VMS, OS/2, and Win32 2262e109fb9Safresh1 # (and for MacPerl). On all other platforms, $^E is always just the 2272e109fb9Safresh1 # same as $!. 2282e109fb9Safresh1 229b39c5158Smillert my ( $e, $e1 ) = ( $save_bang, $^E ); 230b39c5158Smillert $e .= "; $e1" if $e ne $e1; 231b8851fccSafresh1 232b39c5158Smillert # allow for another process to have created it meanwhile 233b39c5158Smillert if ( ! -d $path ) { 234b39c5158Smillert $! = $save_bang; 2352e109fb9Safresh1 if ( $data->{error} ) { 2362e109fb9Safresh1 push @{ ${ $data->{error} } }, { $path => $e }; 237b39c5158Smillert } 238b39c5158Smillert else { 239b39c5158Smillert _croak("mkdir $path: $e"); 240b39c5158Smillert } 241b39c5158Smillert } 242b39c5158Smillert } 243b39c5158Smillert } 244b39c5158Smillert return @created; 245b39c5158Smillert} 246b39c5158Smillert 247b39c5158Smillertsub remove_tree { 248b8851fccSafresh1 push @_, {} unless @_ and __is_arg( $_[-1] ); 249b39c5158Smillert goto &rmtree; 250b39c5158Smillert} 251b39c5158Smillert 252b39c5158Smillertsub _is_subdir { 253b39c5158Smillert my ( $dir, $test ) = @_; 254b39c5158Smillert 255b39c5158Smillert my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 ); 256b39c5158Smillert my ( $tv, $td ) = File::Spec->splitpath( $test, 1 ); 257b39c5158Smillert 258b39c5158Smillert # not on same volume 259b39c5158Smillert return 0 if $dv ne $tv; 260b39c5158Smillert 261b39c5158Smillert my @d = File::Spec->splitdir($dd); 262b39c5158Smillert my @t = File::Spec->splitdir($td); 263b39c5158Smillert 264b39c5158Smillert # @t can't be a subdir if it's shorter than @d 265b39c5158Smillert return 0 if @t < @d; 266b39c5158Smillert 267b39c5158Smillert return join( '/', @d ) eq join( '/', splice @t, 0, +@d ); 268b39c5158Smillert} 269b39c5158Smillert 270b39c5158Smillertsub rmtree { 271b8851fccSafresh1 my $old_style = !( @_ and __is_arg( $_[-1] ) ); 272b39c5158Smillert 2732e109fb9Safresh1 my ($arg, $data, $paths); 274b39c5158Smillert 275b39c5158Smillert if ($old_style) { 276b39c5158Smillert my ( $verbose, $safe ); 277b39c5158Smillert ( $paths, $verbose, $safe ) = @_; 2782e109fb9Safresh1 $data->{verbose} = $verbose; 2792e109fb9Safresh1 $data->{safe} = defined $safe ? $safe : 0; 280b39c5158Smillert 281b39c5158Smillert if ( defined($paths) and length($paths) ) { 282b39c5158Smillert $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); 283b39c5158Smillert } 284b39c5158Smillert else { 285b39c5158Smillert _carp("No root path(s) specified\n"); 286b39c5158Smillert return 0; 287b39c5158Smillert } 288b39c5158Smillert } 289b39c5158Smillert else { 290b8851fccSafresh1 my %args_permitted = map { $_ => 1 } ( qw| 291b8851fccSafresh1 error 292b8851fccSafresh1 keep_root 293b8851fccSafresh1 result 294b8851fccSafresh1 safe 295b8851fccSafresh1 verbose 296b8851fccSafresh1 | ); 297b8851fccSafresh1 my @bad_args = (); 2982e109fb9Safresh1 my $arg = pop @_; 299b8851fccSafresh1 for my $k (sort keys %{$arg}) { 3002e109fb9Safresh1 if (! $args_permitted{$k}) { 3012e109fb9Safresh1 push @bad_args, $k; 3022e109fb9Safresh1 } 3032e109fb9Safresh1 else { 3042e109fb9Safresh1 $data->{$k} = $arg->{$k}; 3052e109fb9Safresh1 } 306b8851fccSafresh1 } 307b8851fccSafresh1 _carp("Unrecognized option(s) passed to remove_tree(): @bad_args") 308b8851fccSafresh1 if @bad_args; 3092e109fb9Safresh1 ${ $data->{error} } = [] if exists $data->{error}; 3102e109fb9Safresh1 ${ $data->{result} } = [] if exists $data->{result}; 3112e109fb9Safresh1 3122e109fb9Safresh1 # Wouldn't it make sense to do some validation on @_ before assigning 3132e109fb9Safresh1 # to $paths here? 3142e109fb9Safresh1 # In the $old_style case we guarantee that each path is both defined 3152e109fb9Safresh1 # and non-empty. We don't check that here, which means we have to 3162e109fb9Safresh1 # check it later in the first condition in this line: 3172e109fb9Safresh1 # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { 3182e109fb9Safresh1 # Granted, that would be a change in behavior for the two 3192e109fb9Safresh1 # non-old-style interfaces. 3202e109fb9Safresh1 321b39c5158Smillert $paths = [@_]; 322b39c5158Smillert } 323b39c5158Smillert 3242e109fb9Safresh1 $data->{prefix} = ''; 3252e109fb9Safresh1 $data->{depth} = 0; 326b39c5158Smillert 327b39c5158Smillert my @clean_path; 3282e109fb9Safresh1 $data->{cwd} = getcwd() or do { 3292e109fb9Safresh1 _error( $data, "cannot fetch initial working directory" ); 330b39c5158Smillert return 0; 331b39c5158Smillert }; 3322e109fb9Safresh1 for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint 333b39c5158Smillert 334b39c5158Smillert for my $p (@$paths) { 335b8851fccSafresh1 336b39c5158Smillert # need to fixup case and map \ to / on Windows 337b8851fccSafresh1 my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; 338b8851fccSafresh1 my $ortho_cwd = 3392e109fb9Safresh1 _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd}; 340b39c5158Smillert my $ortho_root_length = length($ortho_root); 341b8851fccSafresh1 $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' 342b39c5158Smillert if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { 343b39c5158Smillert local $! = 0; 3442e109fb9Safresh1 _error( $data, "cannot remove path when cwd is $data->{cwd}", $p ); 345b39c5158Smillert next; 346b39c5158Smillert } 347b39c5158Smillert 348b8851fccSafresh1 if (_IS_MACOS) { 349b39c5158Smillert $p = ":$p" unless $p =~ /:/; 350b39c5158Smillert $p .= ":" unless $p =~ /:\z/; 351b39c5158Smillert } 352b8851fccSafresh1 elsif ( _IS_MSWIN32 ) { 353b39c5158Smillert $p =~ s{[/\\]\z}{}; 354b39c5158Smillert } 355b39c5158Smillert else { 356b39c5158Smillert $p =~ s{/\z}{}; 357b39c5158Smillert } 358b39c5158Smillert push @clean_path, $p; 359b39c5158Smillert } 360b39c5158Smillert 3612e109fb9Safresh1 @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do { 3622e109fb9Safresh1 _error( $data, "cannot stat initial working directory", $data->{cwd} ); 363b39c5158Smillert return 0; 364b39c5158Smillert }; 365b39c5158Smillert 3662e109fb9Safresh1 return _rmtree( $data, \@clean_path ); 367b39c5158Smillert} 368b39c5158Smillert 369b39c5158Smillertsub _rmtree { 3702e109fb9Safresh1 my $data = shift; 371b39c5158Smillert my $paths = shift; 372b39c5158Smillert 373b39c5158Smillert my $count = 0; 374b39c5158Smillert my $curdir = File::Spec->curdir(); 375b39c5158Smillert my $updir = File::Spec->updir(); 376b39c5158Smillert 377b39c5158Smillert my ( @files, $root ); 378b39c5158Smillert ROOT_DIR: 379b8851fccSafresh1 foreach my $root (@$paths) { 380b8851fccSafresh1 381b39c5158Smillert # since we chdir into each directory, it may not be obvious 382b39c5158Smillert # to figure out where we are if we generate a message about 383b39c5158Smillert # a file name. We therefore construct a semi-canonical 384b39c5158Smillert # filename, anchored from the directory being unlinked (as 385b39c5158Smillert # opposed to being truly canonical, anchored from the root (/). 386b39c5158Smillert 387b8851fccSafresh1 my $canon = 3882e109fb9Safresh1 $data->{prefix} 3892e109fb9Safresh1 ? File::Spec->catfile( $data->{prefix}, $root ) 390b8851fccSafresh1 : $root; 391b39c5158Smillert 392b8851fccSafresh1 my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] 393b8851fccSafresh1 or next ROOT_DIR; 394b39c5158Smillert 395b39c5158Smillert if ( -d _ ) { 396b8851fccSafresh1 $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) ) 397b8851fccSafresh1 if _IS_VMS; 398b39c5158Smillert 399b39c5158Smillert if ( !chdir($root) ) { 400b8851fccSafresh1 401b39c5158Smillert # see if we can escalate privileges to get in 402b39c5158Smillert # (e.g. funny protection mask such as -w- instead of rwx) 4032e109fb9Safresh1 # This uses fchmod to avoid traversing outside of the proper 4042e109fb9Safresh1 # location (CVE-2017-6512) 4052e109fb9Safresh1 my $root_fh; 4062e109fb9Safresh1 if (open($root_fh, '<', $root)) { 4072e109fb9Safresh1 my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1]; 408b8851fccSafresh1 $perm &= oct '7777'; 409b8851fccSafresh1 my $nperm = $perm | oct '700'; 4102e109fb9Safresh1 local $@; 411b8851fccSafresh1 if ( 412b8851fccSafresh1 !( 4132e109fb9Safresh1 $data->{safe} 414b8851fccSafresh1 or $nperm == $perm 4152e109fb9Safresh1 or !-d _ 4162e109fb9Safresh1 or $fh_dev ne $ldev 4172e109fb9Safresh1 or $fh_inode ne $lino 4182e109fb9Safresh1 or eval { chmod( $nperm, $root_fh ) } 419b8851fccSafresh1 ) 420b8851fccSafresh1 ) 421b8851fccSafresh1 { 4222e109fb9Safresh1 _error( $data, 423b8851fccSafresh1 "cannot make child directory read-write-exec", $canon ); 424b39c5158Smillert next ROOT_DIR; 425b39c5158Smillert } 4262e109fb9Safresh1 close $root_fh; 4272e109fb9Safresh1 } 4282e109fb9Safresh1 if ( !chdir($root) ) { 4292e109fb9Safresh1 _error( $data, "cannot chdir to child", $canon ); 430b39c5158Smillert next ROOT_DIR; 431b39c5158Smillert } 432b39c5158Smillert } 433b39c5158Smillert 434b8851fccSafresh1 my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ] 435b8851fccSafresh1 or do { 4362e109fb9Safresh1 _error( $data, "cannot stat current working directory", $canon ); 437b39c5158Smillert next ROOT_DIR; 438b39c5158Smillert }; 439b39c5158Smillert 440b8851fccSafresh1 if (_NEED_STAT_CHECK) { 441b39c5158Smillert ( $ldev eq $cur_dev and $lino eq $cur_inode ) 442b8851fccSafresh1 or _croak( 443b8851fccSafresh1"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting." 444b8851fccSafresh1 ); 445b39c5158Smillert } 446b39c5158Smillert 447b8851fccSafresh1 $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits 448b8851fccSafresh1 my $nperm = $perm | oct '700'; 449b39c5158Smillert 450b39c5158Smillert # notabene: 0700 is for making readable in the first place, 451b39c5158Smillert # it's also intended to change it to writable in case we have 452b39c5158Smillert # to recurse in which case we are better than rm -rf for 453b39c5158Smillert # subtrees with strange permissions 454b39c5158Smillert 455b8851fccSafresh1 if ( 456b8851fccSafresh1 !( 4572e109fb9Safresh1 $data->{safe} 458b8851fccSafresh1 or $nperm == $perm 459b8851fccSafresh1 or chmod( $nperm, $curdir ) 460b8851fccSafresh1 ) 461b8851fccSafresh1 ) 462b8851fccSafresh1 { 4632e109fb9Safresh1 _error( $data, "cannot make directory read+writeable", $canon ); 464b39c5158Smillert $nperm = $perm; 465b39c5158Smillert } 466b39c5158Smillert 467b39c5158Smillert my $d; 468b39c5158Smillert $d = gensym() if $] < 5.006; 469b39c5158Smillert if ( !opendir $d, $curdir ) { 4702e109fb9Safresh1 _error( $data, "cannot opendir", $canon ); 471b39c5158Smillert @files = (); 472b39c5158Smillert } 473b39c5158Smillert else { 474b8851fccSafresh1 if ( !defined ${^TAINT} or ${^TAINT} ) { 475b8851fccSafresh1 # Blindly untaint dir names if taint mode is active 476b39c5158Smillert @files = map { /\A(.*)\z/s; $1 } readdir $d; 477b39c5158Smillert } 478b39c5158Smillert else { 479b39c5158Smillert @files = readdir $d; 480b39c5158Smillert } 481b39c5158Smillert closedir $d; 482b39c5158Smillert } 483b39c5158Smillert 484b8851fccSafresh1 if (_IS_VMS) { 485b8851fccSafresh1 486b39c5158Smillert # Deleting large numbers of files from VMS Files-11 487b39c5158Smillert # filesystems is faster if done in reverse ASCIIbetical order. 488b39c5158Smillert # include '.' to '.;' from blead patch #31775 489b39c5158Smillert @files = map { $_ eq '.' ? '.;' : $_ } reverse @files; 490b39c5158Smillert } 491b39c5158Smillert 492b39c5158Smillert @files = grep { $_ ne $updir and $_ ne $curdir } @files; 493b39c5158Smillert 494b39c5158Smillert if (@files) { 495b8851fccSafresh1 496b39c5158Smillert # remove the contained files before the directory itself 4972e109fb9Safresh1 my $narg = {%$data}; 498b8851fccSafresh1 @{$narg}{qw(device inode cwd prefix depth)} = 4992e109fb9Safresh1 ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 ); 500b39c5158Smillert $count += _rmtree( $narg, \@files ); 501b39c5158Smillert } 502b39c5158Smillert 503b39c5158Smillert # restore directory permissions of required now (in case the rmdir 504b39c5158Smillert # below fails), while we are still in the directory and may do so 505b39c5158Smillert # without a race via '.' 506b39c5158Smillert if ( $nperm != $perm and not chmod( $perm, $curdir ) ) { 5072e109fb9Safresh1 _error( $data, "cannot reset chmod", $canon ); 508b39c5158Smillert } 509b39c5158Smillert 510b39c5158Smillert # don't leave the client code in an unexpected directory 5112e109fb9Safresh1 chdir( $data->{cwd} ) 512b8851fccSafresh1 or 5132e109fb9Safresh1 _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting."); 514b39c5158Smillert 515b39c5158Smillert # ensure that a chdir upwards didn't take us somewhere other 516b39c5158Smillert # than we expected (see CVE-2002-0435) 517b39c5158Smillert ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] 518b8851fccSafresh1 or _croak( 5192e109fb9Safresh1 "cannot stat prior working directory $data->{cwd}: $!, aborting." 520b8851fccSafresh1 ); 521b39c5158Smillert 522b8851fccSafresh1 if (_NEED_STAT_CHECK) { 5232e109fb9Safresh1 ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode ) 5242e109fb9Safresh1 or _croak( "previous directory $data->{cwd} " 525b8851fccSafresh1 . "changed before entering $canon, " 526b8851fccSafresh1 . "expected dev=$ldev ino=$lino, " 527b8851fccSafresh1 . "actual dev=$cur_dev ino=$cur_inode, aborting." 528b8851fccSafresh1 ); 529b39c5158Smillert } 530b39c5158Smillert 5312e109fb9Safresh1 if ( $data->{depth} or !$data->{keep_root} ) { 5322e109fb9Safresh1 if ( $data->{safe} 533b8851fccSafresh1 && ( _IS_VMS 534b8851fccSafresh1 ? !&VMS::Filespec::candelete($root) 535b8851fccSafresh1 : !-w $root ) ) 536b8851fccSafresh1 { 5372e109fb9Safresh1 print "skipped $root\n" if $data->{verbose}; 538b39c5158Smillert next ROOT_DIR; 539b39c5158Smillert } 540b8851fccSafresh1 if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) { 5412e109fb9Safresh1 _error( $data, "cannot make directory writeable", $canon ); 542b39c5158Smillert } 5432e109fb9Safresh1 print "rmdir $root\n" if $data->{verbose}; 544b39c5158Smillert if ( rmdir $root ) { 5452e109fb9Safresh1 push @{ ${ $data->{result} } }, $root if $data->{result}; 546b39c5158Smillert ++$count; 547b39c5158Smillert } 548b39c5158Smillert else { 5492e109fb9Safresh1 _error( $data, "cannot remove directory", $canon ); 550b8851fccSafresh1 if ( 551b8851fccSafresh1 _FORCE_WRITABLE 552b8851fccSafresh1 && !chmod( $perm, 553b8851fccSafresh1 ( _IS_VMS ? VMS::Filespec::fileify($root) : $root ) 554b8851fccSafresh1 ) 555b8851fccSafresh1 ) 556b8851fccSafresh1 { 557b8851fccSafresh1 _error( 5582e109fb9Safresh1 $data, 559b8851fccSafresh1 sprintf( "cannot restore permissions to 0%o", 560b8851fccSafresh1 $perm ), 561b8851fccSafresh1 $canon 562b8851fccSafresh1 ); 563b39c5158Smillert } 564b39c5158Smillert } 565b39c5158Smillert } 566b39c5158Smillert } 567b39c5158Smillert else { 568b39c5158Smillert # not a directory 569b39c5158Smillert $root = VMS::Filespec::vmsify("./$root") 570b8851fccSafresh1 if _IS_VMS 571b39c5158Smillert && !File::Spec->file_name_is_absolute($root) 572b39c5158Smillert && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax 573b39c5158Smillert 574b8851fccSafresh1 if ( 5752e109fb9Safresh1 $data->{safe} 576b8851fccSafresh1 && ( 577b8851fccSafresh1 _IS_VMS 578b8851fccSafresh1 ? !&VMS::Filespec::candelete($root) 579b8851fccSafresh1 : !( -l $root || -w $root ) 580b8851fccSafresh1 ) 581b8851fccSafresh1 ) 582b39c5158Smillert { 5832e109fb9Safresh1 print "skipped $root\n" if $data->{verbose}; 584b39c5158Smillert next ROOT_DIR; 585b39c5158Smillert } 586b39c5158Smillert 587b8851fccSafresh1 my $nperm = $perm & oct '7777' | oct '600'; 588b8851fccSafresh1 if ( _FORCE_WRITABLE 589b8851fccSafresh1 and $nperm != $perm 590b8851fccSafresh1 and not chmod $nperm, $root ) 591b8851fccSafresh1 { 5922e109fb9Safresh1 _error( $data, "cannot make file writeable", $canon ); 593b39c5158Smillert } 5942e109fb9Safresh1 print "unlink $canon\n" if $data->{verbose}; 595b8851fccSafresh1 596b39c5158Smillert # delete all versions under VMS 597b39c5158Smillert for ( ; ; ) { 598b39c5158Smillert if ( unlink $root ) { 5992e109fb9Safresh1 push @{ ${ $data->{result} } }, $root if $data->{result}; 600b39c5158Smillert } 601b39c5158Smillert else { 6022e109fb9Safresh1 _error( $data, "cannot unlink file", $canon ); 603b8851fccSafresh1 _FORCE_WRITABLE and chmod( $perm, $root ) 6042e109fb9Safresh1 or _error( $data, 605b8851fccSafresh1 sprintf( "cannot restore permissions to 0%o", $perm ), 606b8851fccSafresh1 $canon ); 607b39c5158Smillert last; 608b39c5158Smillert } 609b39c5158Smillert ++$count; 610b8851fccSafresh1 last unless _IS_VMS && lstat $root; 611b39c5158Smillert } 612b39c5158Smillert } 613b39c5158Smillert } 614b39c5158Smillert return $count; 615b39c5158Smillert} 616b39c5158Smillert 617b39c5158Smillertsub _slash_lc { 618b8851fccSafresh1 619b39c5158Smillert # fix up slashes and case on MSWin32 so that we can determine that 620b39c5158Smillert # c:\path\to\dir is underneath C:/Path/To 621b39c5158Smillert my $path = shift; 622b39c5158Smillert $path =~ tr{\\}{/}; 623b39c5158Smillert return lc($path); 624b39c5158Smillert} 625b39c5158Smillert 626b39c5158Smillert1; 627b8851fccSafresh1 628b39c5158Smillert__END__ 629b39c5158Smillert 630b39c5158Smillert=head1 NAME 631b39c5158Smillert 632b39c5158SmillertFile::Path - Create or remove directory trees 633b39c5158Smillert 634b39c5158Smillert=head1 VERSION 635b39c5158Smillert 636*eac174f2Safresh12.18 - released November 4 2020. 637b39c5158Smillert 638b39c5158Smillert=head1 SYNOPSIS 639b39c5158Smillert 640b39c5158Smillert use File::Path qw(make_path remove_tree); 641b39c5158Smillert 642b8851fccSafresh1 @created = make_path('foo/bar/baz', '/zug/zwang'); 643b8851fccSafresh1 @created = make_path('foo/bar/baz', '/zug/zwang', { 644b39c5158Smillert verbose => 1, 645b39c5158Smillert mode => 0711, 646b39c5158Smillert }); 647b8851fccSafresh1 make_path('foo/bar/baz', '/zug/zwang', { 648b8851fccSafresh1 chmod => 0777, 649b8851fccSafresh1 }); 650b39c5158Smillert 651b8851fccSafresh1 $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', { 652b39c5158Smillert verbose => 1, 653b39c5158Smillert error => \my $err_list, 6542e109fb9Safresh1 safe => 1, 655b39c5158Smillert }); 656b39c5158Smillert 657b39c5158Smillert # legacy (interface promoted before v2.00) 658b8851fccSafresh1 @created = mkpath('/foo/bar/baz'); 659b8851fccSafresh1 @created = mkpath('/foo/bar/baz', 1, 0711); 660b8851fccSafresh1 @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); 661b8851fccSafresh1 $removed_count = rmtree('foo/bar/baz', 1, 1); 662b8851fccSafresh1 $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); 663b39c5158Smillert 664b39c5158Smillert # legacy (interface promoted before v2.06) 665b8851fccSafresh1 @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); 666b8851fccSafresh1 $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); 667b39c5158Smillert 668b39c5158Smillert=head1 DESCRIPTION 669b39c5158Smillert 6702e109fb9Safresh1This module provides a convenient way to create directories of 671b39c5158Smillertarbitrary depth and to delete an entire directory subtree from the 672b39c5158Smillertfilesystem. 673b39c5158Smillert 674b39c5158SmillertThe following functions are provided: 675b39c5158Smillert 676b39c5158Smillert=over 677b39c5158Smillert 678b39c5158Smillert=item make_path( $dir1, $dir2, .... ) 679b39c5158Smillert 680b39c5158Smillert=item make_path( $dir1, $dir2, ...., \%opts ) 681b39c5158Smillert 682b39c5158SmillertThe C<make_path> function creates the given directories if they don't 6832e109fb9Safresh1exist before, much like the Unix command C<mkdir -p>. 684b39c5158Smillert 685b39c5158SmillertThe function accepts a list of directories to be created. Its 686b39c5158Smillertbehaviour may be tuned by an optional hashref appearing as the last 687b39c5158Smillertparameter on the call. 688b39c5158Smillert 689b39c5158SmillertThe function returns the list of directories actually created during 690b39c5158Smillertthe call; in scalar context the number of directories created. 691b39c5158Smillert 692b39c5158SmillertThe following keys are recognised in the option hash: 693b39c5158Smillert 694b39c5158Smillert=over 695b39c5158Smillert 696b39c5158Smillert=item mode => $num 697b39c5158Smillert 698b39c5158SmillertThe numeric permissions mode to apply to each created directory 6992e109fb9Safresh1(defaults to C<0777>), to be modified by the current C<umask>. If the 700b39c5158Smillertdirectory already exists (and thus does not need to be created), 701b39c5158Smillertthe permissions will not be modified. 702b39c5158Smillert 703b39c5158SmillertC<mask> is recognised as an alias for this parameter. 704b39c5158Smillert 705b8851fccSafresh1=item chmod => $num 706b8851fccSafresh1 707b8851fccSafresh1Takes a numeric mode to apply to each created directory (not 708b8851fccSafresh1modified by the current C<umask>). If the directory already exists 709b8851fccSafresh1(and thus does not need to be created), the permissions will 710b8851fccSafresh1not be modified. 711b8851fccSafresh1 712b39c5158Smillert=item verbose => $bool 713b39c5158Smillert 714b39c5158SmillertIf present, will cause C<make_path> to print the name of each directory 715b39c5158Smillertas it is created. By default nothing is printed. 716b39c5158Smillert 717b39c5158Smillert=item error => \$err 718b39c5158Smillert 719b39c5158SmillertIf present, it should be a reference to a scalar. 720b39c5158SmillertThis scalar will be made to reference an array, which will 721b39c5158Smillertbe used to store any errors that are encountered. See the L</"ERROR 722b39c5158SmillertHANDLING"> section for more information. 723b39c5158Smillert 724b39c5158SmillertIf this parameter is not used, certain error conditions may raise 725b8851fccSafresh1a fatal error that will cause the program to halt, unless trapped 726b39c5158Smillertin an C<eval> block. 727b39c5158Smillert 728b39c5158Smillert=item owner => $owner 729b39c5158Smillert 730b39c5158Smillert=item user => $owner 731b39c5158Smillert 732b39c5158Smillert=item uid => $owner 733b39c5158Smillert 734b39c5158SmillertIf present, will cause any created directory to be owned by C<$owner>. 7352e109fb9Safresh1If the value is numeric, it will be interpreted as a uid; otherwise a 7362e109fb9Safresh1username is assumed. An error will be issued if the username cannot be 7372e109fb9Safresh1mapped to a uid, the uid does not exist or the process lacks the 738b39c5158Smillertprivileges to change ownership. 739b39c5158Smillert 740b8851fccSafresh1Ownership of directories that already exist will not be changed. 741b39c5158Smillert 742b39c5158SmillertC<user> and C<uid> are aliases of C<owner>. 743b39c5158Smillert 744b39c5158Smillert=item group => $group 745b39c5158Smillert 7462e109fb9Safresh1If present, will cause any created directory to be owned by the group 7472e109fb9Safresh1C<$group>. If the value is numeric, it will be interpreted as a gid; 7482e109fb9Safresh1otherwise a group name is assumed. An error will be issued if the 7492e109fb9Safresh1group name cannot be mapped to a gid, the gid does not exist or the 7502e109fb9Safresh1process lacks the privileges to change group ownership. 751b39c5158Smillert 752b8851fccSafresh1Group ownership of directories that already exist will not be changed. 753b39c5158Smillert 754b39c5158Smillert make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'}; 755b39c5158Smillert 756b39c5158Smillert=back 757b39c5158Smillert 758b39c5158Smillert=item mkpath( $dir ) 759b39c5158Smillert 760b39c5158Smillert=item mkpath( $dir, $verbose, $mode ) 761b39c5158Smillert 762b39c5158Smillert=item mkpath( [$dir1, $dir2,...], $verbose, $mode ) 763b39c5158Smillert 764b39c5158Smillert=item mkpath( $dir1, $dir2,..., \%opt ) 765b39c5158Smillert 7662e109fb9Safresh1The C<mkpath()> function provide the legacy interface of 7672e109fb9Safresh1C<make_path()> with a different interpretation of the arguments 7682e109fb9Safresh1passed. The behaviour and return value of the function is otherwise 7692e109fb9Safresh1identical to C<make_path()>. 770b39c5158Smillert 771b39c5158Smillert=item remove_tree( $dir1, $dir2, .... ) 772b39c5158Smillert 773b39c5158Smillert=item remove_tree( $dir1, $dir2, ...., \%opts ) 774b39c5158Smillert 775b39c5158SmillertThe C<remove_tree> function deletes the given directories and any 776b39c5158Smillertfiles and subdirectories they might contain, much like the Unix 7779f11ffb7Safresh1command C<rm -rf> or the Windows commands C<rmdir /s> and C<rd /s>. 778b39c5158Smillert 7799f11ffb7Safresh1The function accepts a list of directories to be removed. (In point of fact, 7809f11ffb7Safresh1it will also accept filesystem entries which are not directories, such as 7819f11ffb7Safresh1regular files and symlinks. But, as its name suggests, its intent is to 7829f11ffb7Safresh1remove trees rather than individual files.) 7839f11ffb7Safresh1 7849f11ffb7Safresh1C<remove_tree()>'s behaviour may be tuned by an optional hashref 785b8851fccSafresh1appearing as the last parameter on the call. If an empty string is 786b8851fccSafresh1passed to C<remove_tree>, an error will occur. 787b39c5158Smillert 7882e109fb9Safresh1B<NOTE:> For security reasons, we strongly advise use of the 7892e109fb9Safresh1hashref-as-final-argument syntax -- specifically, with a setting of the C<safe> 7902e109fb9Safresh1element to a true value. 7912e109fb9Safresh1 7922e109fb9Safresh1 remove_tree( $dir1, $dir2, ...., 7932e109fb9Safresh1 { 7942e109fb9Safresh1 safe => 1, 7952e109fb9Safresh1 ... # other key-value pairs 7962e109fb9Safresh1 }, 7972e109fb9Safresh1 ); 7982e109fb9Safresh1 7992e109fb9Safresh1The function returns the number of files successfully deleted. 800b39c5158Smillert 801b39c5158SmillertThe following keys are recognised in the option hash: 802b39c5158Smillert 803b39c5158Smillert=over 804b39c5158Smillert 805b39c5158Smillert=item verbose => $bool 806b39c5158Smillert 807b39c5158SmillertIf present, will cause C<remove_tree> to print the name of each file as 808b39c5158Smillertit is unlinked. By default nothing is printed. 809b39c5158Smillert 810b39c5158Smillert=item safe => $bool 811b39c5158Smillert 812b39c5158SmillertWhen set to a true value, will cause C<remove_tree> to skip the files 813b39c5158Smillertfor which the process lacks the required privileges needed to delete 814b39c5158Smillertfiles, such as delete privileges on VMS. In other words, the code 815b39c5158Smillertwill make no attempt to alter file permissions. Thus, if the process 816b39c5158Smillertis interrupted, no filesystem object will be left in a more 817b39c5158Smillertpermissive mode. 818b39c5158Smillert 819b39c5158Smillert=item keep_root => $bool 820b39c5158Smillert 821b39c5158SmillertWhen set to a true value, will cause all files and subdirectories 822b39c5158Smillertto be removed, except the initially specified directories. This comes 823b39c5158Smillertin handy when cleaning out an application's scratch directory. 824b39c5158Smillert 825b39c5158Smillert remove_tree( '/tmp', {keep_root => 1} ); 826b39c5158Smillert 827b39c5158Smillert=item result => \$res 828b39c5158Smillert 829b39c5158SmillertIf present, it should be a reference to a scalar. 830b39c5158SmillertThis scalar will be made to reference an array, which will 831b39c5158Smillertbe used to store all files and directories unlinked 832b39c5158Smillertduring the call. If nothing is unlinked, the array will be empty. 833b39c5158Smillert 834b39c5158Smillert remove_tree( '/tmp', {result => \my $list} ); 835b39c5158Smillert print "unlinked $_\n" for @$list; 836b39c5158Smillert 837b39c5158SmillertThis is a useful alternative to the C<verbose> key. 838b39c5158Smillert 839b39c5158Smillert=item error => \$err 840b39c5158Smillert 841b39c5158SmillertIf present, it should be a reference to a scalar. 842b39c5158SmillertThis scalar will be made to reference an array, which will 843b39c5158Smillertbe used to store any errors that are encountered. See the L</"ERROR 844b39c5158SmillertHANDLING"> section for more information. 845b39c5158Smillert 846b39c5158SmillertRemoving things is a much more dangerous proposition than 847b39c5158Smillertcreating things. As such, there are certain conditions that 848b39c5158SmillertC<remove_tree> may encounter that are so dangerous that the only 849b39c5158Smillertsane action left is to kill the program. 850b39c5158Smillert 851b39c5158SmillertUse C<error> to trap all that is reasonable (problems with 852b39c5158Smillertpermissions and the like), and let it die if things get out 853b39c5158Smillertof hand. This is the safest course of action. 854b39c5158Smillert 855b39c5158Smillert=back 856b39c5158Smillert 857b39c5158Smillert=item rmtree( $dir ) 858b39c5158Smillert 859b39c5158Smillert=item rmtree( $dir, $verbose, $safe ) 860b39c5158Smillert 861b39c5158Smillert=item rmtree( [$dir1, $dir2,...], $verbose, $safe ) 862b39c5158Smillert 863b39c5158Smillert=item rmtree( $dir1, $dir2,..., \%opt ) 864b39c5158Smillert 8652e109fb9Safresh1The C<rmtree()> function provide the legacy interface of 8662e109fb9Safresh1C<remove_tree()> with a different interpretation of the arguments 8672e109fb9Safresh1passed. The behaviour and return value of the function is otherwise 8682e109fb9Safresh1identical to C<remove_tree()>. 8692e109fb9Safresh1 8702e109fb9Safresh1B<NOTE:> For security reasons, we strongly advise use of the 8712e109fb9Safresh1hashref-as-final-argument syntax, specifically with a setting of the C<safe> 8722e109fb9Safresh1element to a true value. 8732e109fb9Safresh1 8742e109fb9Safresh1 rmtree( $dir1, $dir2, ...., 8752e109fb9Safresh1 { 8762e109fb9Safresh1 safe => 1, 8772e109fb9Safresh1 ... # other key-value pairs 8782e109fb9Safresh1 }, 8792e109fb9Safresh1 ); 880b39c5158Smillert 881b39c5158Smillert=back 882b39c5158Smillert 883b39c5158Smillert=head2 ERROR HANDLING 884b39c5158Smillert 885b39c5158Smillert=over 4 886b39c5158Smillert 887b39c5158Smillert=item B<NOTE:> 888b39c5158Smillert 889b8851fccSafresh1The following error handling mechanism is consistent throughout all 890b8851fccSafresh1code paths EXCEPT in cases where the ROOT node is nonexistent. In 891b8851fccSafresh1version 2.11 the maintainers attempted to rectify this inconsistency 892b8851fccSafresh1but too many downstream modules encountered problems. In such case, 893b8851fccSafresh1if you require root node evaluation or error checking prior to calling 894b8851fccSafresh1C<make_path> or C<remove_tree>, you should take additional precautions. 895b39c5158Smillert 896b39c5158Smillert=back 897b39c5158Smillert 8982e109fb9Safresh1If C<make_path> or C<remove_tree> encounters an error, a diagnostic 899b39c5158Smillertmessage will be printed to C<STDERR> via C<carp> (for non-fatal 9002e109fb9Safresh1errors) or via C<croak> (for fatal errors). 901b39c5158Smillert 902b39c5158SmillertIf this behaviour is not desirable, the C<error> attribute may be 903b39c5158Smillertused to hold a reference to a variable, which will be used to store 904b39c5158Smillertthe diagnostics. The variable is made a reference to an array of hash 905b39c5158Smillertreferences. Each hash contain a single key/value pair where the key 906b39c5158Smillertis the name of the file, and the value is the error message (including 907b39c5158Smillertthe contents of C<$!> when appropriate). If a general error is 908b39c5158Smillertencountered the diagnostic key will be empty. 909b39c5158Smillert 910b39c5158SmillertAn example usage looks like: 911b39c5158Smillert 912b39c5158Smillert remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); 9132e109fb9Safresh1 if ($err && @$err) { 914b39c5158Smillert for my $diag (@$err) { 915b39c5158Smillert my ($file, $message) = %$diag; 916b39c5158Smillert if ($file eq '') { 917b39c5158Smillert print "general error: $message\n"; 918b39c5158Smillert } 919b39c5158Smillert else { 920b39c5158Smillert print "problem unlinking $file: $message\n"; 921b39c5158Smillert } 922b39c5158Smillert } 923b39c5158Smillert } 924b39c5158Smillert else { 925b39c5158Smillert print "No error encountered\n"; 926b39c5158Smillert } 927b39c5158Smillert 928b39c5158SmillertNote that if no errors are encountered, C<$err> will reference an 929b39c5158Smillertempty array. This means that C<$err> will always end up TRUE; so you 930b8851fccSafresh1need to test C<@$err> to determine if errors occurred. 931b39c5158Smillert 932b39c5158Smillert=head2 NOTES 933b39c5158Smillert 934b39c5158SmillertC<File::Path> blindly exports C<mkpath> and C<rmtree> into the 935b39c5158Smillertcurrent namespace. These days, this is considered bad style, but 936b39c5158Smillertto change it now would break too much code. Nonetheless, you are 937b39c5158Smillertinvited to specify what it is you are expecting to use: 938b39c5158Smillert 939b39c5158Smillert use File::Path 'rmtree'; 940b39c5158Smillert 941b39c5158SmillertThe routines C<make_path> and C<remove_tree> are B<not> exported 942b39c5158Smillertby default. You must specify which ones you want to use. 943b39c5158Smillert 944b39c5158Smillert use File::Path 'remove_tree'; 945b39c5158Smillert 946b39c5158SmillertNote that a side-effect of the above is that C<mkpath> and C<rmtree> 947b39c5158Smillertare no longer exported at all. This is due to the way the C<Exporter> 948b39c5158Smillertmodule works. If you are migrating a codebase to use the new 949b39c5158Smillertinterface, you will have to list everything explicitly. But that's 950b39c5158Smillertjust good practice anyway. 951b39c5158Smillert 952b39c5158Smillert use File::Path qw(remove_tree rmtree); 953b39c5158Smillert 954b39c5158Smillert=head3 API CHANGES 955b39c5158Smillert 956b39c5158SmillertThe API was changed in the 2.0 branch. For a time, C<mkpath> and 957b39c5158SmillertC<rmtree> tried, unsuccessfully, to deal with the two different 958b39c5158Smillertcalling mechanisms. This approach was considered a failure. 959b39c5158Smillert 960b39c5158SmillertThe new semantics are now only available with C<make_path> and 961b39c5158SmillertC<remove_tree>. The old semantics are only available through 962b39c5158SmillertC<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade 963b39c5158Smillertto at least 2.08 in order to avoid surprises. 964b39c5158Smillert 965b39c5158Smillert=head3 SECURITY CONSIDERATIONS 966b39c5158Smillert 9672e109fb9Safresh1There were race conditions in the 1.x implementations of File::Path's 968b39c5158SmillertC<rmtree> function (although sometimes patched depending on the OS 969b39c5158Smillertdistribution or platform). The 2.0 version contains code to avoid the 970b39c5158Smillertproblem mentioned in CVE-2002-0435. 971b39c5158Smillert 972b39c5158SmillertSee the following pages for more information: 973b39c5158Smillert 974b39c5158Smillert http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 975b39c5158Smillert http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html 976b39c5158Smillert http://www.debian.org/security/2005/dsa-696 977b39c5158Smillert 978b39c5158SmillertAdditionally, unless the C<safe> parameter is set (or the 979b39c5158Smillertthird parameter in the traditional interface is TRUE), should a 980b39c5158SmillertC<remove_tree> be interrupted, files that were originally in read-only 981b39c5158Smillertmode may now have their permissions set to a read-write (or "delete 982b39c5158SmillertOK") mode. 983b39c5158Smillert 9842e109fb9Safresh1The following CVE reports were previously filed against File-Path and are 9852e109fb9Safresh1believed to have been addressed: 9862e109fb9Safresh1 9872e109fb9Safresh1=over 4 9882e109fb9Safresh1 9892e109fb9Safresh1=item * L<http://cve.circl.lu/cve/CVE-2004-0452> 9902e109fb9Safresh1 9912e109fb9Safresh1=item * L<http://cve.circl.lu/cve/CVE-2005-0448> 9922e109fb9Safresh1 9932e109fb9Safresh1=back 9942e109fb9Safresh1 9952e109fb9Safresh1In February 2017 the cPanel Security Team reported an additional vulnerability 9962e109fb9Safresh1in File-Path. The C<chmod()> logic to make directories traversable can be 9972e109fb9Safresh1abused to set the mode on an attacker-chosen file to an attacker-chosen value. 9982e109fb9Safresh1This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition 9992e109fb9Safresh1(L<https://en.wikipedia.org/wiki/Time_of_check_to_time_of_use>) between the 10002e109fb9Safresh1C<stat()> that decides the inode is a directory and the C<chmod()> that tries 10012e109fb9Safresh1to make it user-rwx. CPAN versions 2.13 and later incorporate a patch 10022e109fb9Safresh1provided by John Lightsey to address this problem. This vulnerability has 10032e109fb9Safresh1been reported as CVE-2017-6512. 10042e109fb9Safresh1 1005b39c5158Smillert=head1 DIAGNOSTICS 1006b39c5158Smillert 1007b39c5158SmillertFATAL errors will cause the program to halt (C<croak>), since the 1008b39c5158Smillertproblem is so severe that it would be dangerous to continue. (This 1009b39c5158Smillertcan always be trapped with C<eval>, but it's not a good idea. Under 1010b39c5158Smillertthe circumstances, dying is the best thing to do). 1011b39c5158Smillert 1012b39c5158SmillertSEVERE errors may be trapped using the modern interface. If the 10132e109fb9Safresh1they are not trapped, or if the old interface is used, such an error 1014b39c5158Smillertwill cause the program will halt. 1015b39c5158Smillert 1016b39c5158SmillertAll other errors may be trapped using the modern interface, otherwise 1017b39c5158Smillertthey will be C<carp>ed about. Program execution will not be halted. 1018b39c5158Smillert 1019b39c5158Smillert=over 4 1020b39c5158Smillert 1021b39c5158Smillert=item mkdir [path]: [errmsg] (SEVERE) 1022b39c5158Smillert 1023b39c5158SmillertC<make_path> was unable to create the path. Probably some sort of 10242e109fb9Safresh1permissions error at the point of departure or insufficient resources 1025b39c5158Smillert(such as free inodes on Unix). 1026b39c5158Smillert 1027b39c5158Smillert=item No root path(s) specified 1028b39c5158Smillert 1029b39c5158SmillertC<make_path> was not given any paths to create. This message is only 1030b39c5158Smillertemitted if the routine is called with the traditional interface. 1031b39c5158SmillertThe modern interface will remain silent if given nothing to do. 1032b39c5158Smillert 1033b39c5158Smillert=item No such file or directory 1034b39c5158Smillert 1035b39c5158SmillertOn Windows, if C<make_path> gives you this warning, it may mean that 1036b39c5158Smillertyou have exceeded your filesystem's maximum path length. 1037b39c5158Smillert 1038b39c5158Smillert=item cannot fetch initial working directory: [errmsg] 1039b39c5158Smillert 1040b39c5158SmillertC<remove_tree> attempted to determine the initial directory by calling 1041b39c5158SmillertC<Cwd::getcwd>, but the call failed for some reason. No attempt 1042b39c5158Smillertwill be made to delete anything. 1043b39c5158Smillert 1044b39c5158Smillert=item cannot stat initial working directory: [errmsg] 1045b39c5158Smillert 1046b39c5158SmillertC<remove_tree> attempted to stat the initial directory (after having 1047b39c5158Smillertsuccessfully obtained its name via C<getcwd>), however, the call 1048b39c5158Smillertfailed for some reason. No attempt will be made to delete anything. 1049b39c5158Smillert 1050b39c5158Smillert=item cannot chdir to [dir]: [errmsg] 1051b39c5158Smillert 1052b39c5158SmillertC<remove_tree> attempted to set the working directory in order to 1053b39c5158Smillertbegin deleting the objects therein, but was unsuccessful. This is 1054b39c5158Smillertusually a permissions issue. The routine will continue to delete 1055b39c5158Smillertother things, but this directory will be left intact. 1056b39c5158Smillert 1057b39c5158Smillert=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) 1058b39c5158Smillert 1059b39c5158SmillertC<remove_tree> recorded the device and inode of a directory, and then 1060b39c5158Smillertmoved into it. It then performed a C<stat> on the current directory 1061b39c5158Smillertand detected that the device and inode were no longer the same. As 1062b39c5158Smillertthis is at the heart of the race condition problem, the program 1063b39c5158Smillertwill die at this point. 1064b39c5158Smillert 1065b39c5158Smillert=item cannot make directory [dir] read+writeable: [errmsg] 1066b39c5158Smillert 1067b39c5158SmillertC<remove_tree> attempted to change the permissions on the current directory 1068b39c5158Smillertto ensure that subsequent unlinkings would not run into problems, 1069b39c5158Smillertbut was unable to do so. The permissions remain as they were, and 1070b39c5158Smillertthe program will carry on, doing the best it can. 1071b39c5158Smillert 1072b39c5158Smillert=item cannot read [dir]: [errmsg] 1073b39c5158Smillert 1074b39c5158SmillertC<remove_tree> tried to read the contents of the directory in order 1075b39c5158Smillertto acquire the names of the directory entries to be unlinked, but 1076b39c5158Smillertwas unsuccessful. This is usually a permissions issue. The 1077b39c5158Smillertprogram will continue, but the files in this directory will remain 1078b39c5158Smillertafter the call. 1079b39c5158Smillert 1080b39c5158Smillert=item cannot reset chmod [dir]: [errmsg] 1081b39c5158Smillert 1082b39c5158SmillertC<remove_tree>, after having deleted everything in a directory, attempted 1083b39c5158Smillertto restore its permissions to the original state but failed. The 1084b39c5158Smillertdirectory may wind up being left behind. 1085b39c5158Smillert 1086b39c5158Smillert=item cannot remove [dir] when cwd is [dir] 1087b39c5158Smillert 1088b39c5158SmillertThe current working directory of the program is F</some/path/to/here> 1089b39c5158Smillertand you are attempting to remove an ancestor, such as F</some/path>. 1090b39c5158SmillertThe directory tree is left untouched. 1091b39c5158Smillert 1092b39c5158SmillertThe solution is to C<chdir> out of the child directory to a place 1093b39c5158Smillertoutside the directory tree to be removed. 1094b39c5158Smillert 1095b39c5158Smillert=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) 1096b39c5158Smillert 1097b39c5158SmillertC<remove_tree>, after having deleted everything and restored the permissions 1098b39c5158Smillertof a directory, was unable to chdir back to the parent. The program 1099b39c5158Smillerthalts to avoid a race condition from occurring. 1100b39c5158Smillert 1101b39c5158Smillert=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) 1102b39c5158Smillert 11032e109fb9Safresh1C<remove_tree> was unable to stat the parent directory after having returned 1104b39c5158Smillertfrom the child. Since there is no way of knowing if we returned to 1105b39c5158Smillertwhere we think we should be (by comparing device and inode) the only 1106b39c5158Smillertway out is to C<croak>. 1107b39c5158Smillert 1108b39c5158Smillert=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) 1109b39c5158Smillert 1110b39c5158SmillertWhen C<remove_tree> returned from deleting files in a child directory, a 1111b39c5158Smillertcheck revealed that the parent directory it returned to wasn't the one 1112b39c5158Smillertit started out from. This is considered a sign of malicious activity. 1113b39c5158Smillert 1114b39c5158Smillert=item cannot make directory [dir] writeable: [errmsg] 1115b39c5158Smillert 1116b39c5158SmillertJust before removing a directory (after having successfully removed 1117b39c5158Smillerteverything it contained), C<remove_tree> attempted to set the permissions 1118b39c5158Smillerton the directory to ensure it could be removed and failed. Program 1119b39c5158Smillertexecution continues, but the directory may possibly not be deleted. 1120b39c5158Smillert 1121b39c5158Smillert=item cannot remove directory [dir]: [errmsg] 1122b39c5158Smillert 11232e109fb9Safresh1C<remove_tree> attempted to remove a directory, but failed. This may be because 1124b39c5158Smillertsome objects that were unable to be removed remain in the directory, or 11252e109fb9Safresh1it could be a permissions issue. The directory will be left behind. 1126b39c5158Smillert 1127b39c5158Smillert=item cannot restore permissions of [dir] to [0nnn]: [errmsg] 1128b39c5158Smillert 1129b39c5158SmillertAfter having failed to remove a directory, C<remove_tree> was unable to 1130b39c5158Smillertrestore its permissions from a permissive state back to a possibly 1131b39c5158Smillertmore restrictive setting. (Permissions given in octal). 1132b39c5158Smillert 1133b39c5158Smillert=item cannot make file [file] writeable: [errmsg] 1134b39c5158Smillert 1135b39c5158SmillertC<remove_tree> attempted to force the permissions of a file to ensure it 1136b39c5158Smillertcould be deleted, but failed to do so. It will, however, still attempt 1137b39c5158Smillertto unlink the file. 1138b39c5158Smillert 1139b39c5158Smillert=item cannot unlink file [file]: [errmsg] 1140b39c5158Smillert 1141b39c5158SmillertC<remove_tree> failed to remove a file. Probably a permissions issue. 1142b39c5158Smillert 1143b39c5158Smillert=item cannot restore permissions of [file] to [0nnn]: [errmsg] 1144b39c5158Smillert 1145b39c5158SmillertAfter having failed to remove a file, C<remove_tree> was also unable 1146b39c5158Smillertto restore the permissions on the file to a possibly less permissive 1147b39c5158Smillertsetting. (Permissions given in octal). 1148b39c5158Smillert 1149b39c5158Smillert=item unable to map [owner] to a uid, ownership not changed"); 1150b39c5158Smillert 1151b39c5158SmillertC<make_path> was instructed to give the ownership of created 1152b39c5158Smillertdirectories to the symbolic name [owner], but C<getpwnam> did 1153b39c5158Smillertnot return the corresponding numeric uid. The directory will 1154b39c5158Smillertbe created, but ownership will not be changed. 1155b39c5158Smillert 1156b39c5158Smillert=item unable to map [group] to a gid, group ownership not changed 1157b39c5158Smillert 1158b39c5158SmillertC<make_path> was instructed to give the group ownership of created 1159b39c5158Smillertdirectories to the symbolic name [group], but C<getgrnam> did 1160b39c5158Smillertnot return the corresponding numeric gid. The directory will 1161b39c5158Smillertbe created, but group ownership will not be changed. 1162b39c5158Smillert 1163b39c5158Smillert=back 1164b39c5158Smillert 1165b39c5158Smillert=head1 SEE ALSO 1166b39c5158Smillert 1167b39c5158Smillert=over 4 1168b39c5158Smillert 1169b39c5158Smillert=item * 1170b39c5158Smillert 1171b39c5158SmillertL<File::Remove> 1172b39c5158Smillert 1173b39c5158SmillertAllows files and directories to be moved to the Trashcan/Recycle 1174b39c5158SmillertBin (where they may later be restored if necessary) if the operating 1175b39c5158Smillertsystem supports such functionality. This feature may one day be 1176b39c5158Smillertmade available directly in C<File::Path>. 1177b39c5158Smillert 1178b39c5158Smillert=item * 1179b39c5158Smillert 1180b39c5158SmillertL<File::Find::Rule> 1181b39c5158Smillert 1182b39c5158SmillertWhen removing directory trees, if you want to examine each file to 1183b39c5158Smillertdecide whether to delete it (and possibly leaving large swathes 1184b39c5158Smillertalone), F<File::Find::Rule> offers a convenient and flexible approach 1185b39c5158Smillertto examining directory trees. 1186b39c5158Smillert 1187b39c5158Smillert=back 1188b39c5158Smillert 1189b8851fccSafresh1=head1 BUGS AND LIMITATIONS 1190b39c5158Smillert 1191b8851fccSafresh1The following describes F<File::Path> limitations and how to report bugs. 1192b8851fccSafresh1 11932e109fb9Safresh1=head2 MULTITHREADED APPLICATIONS 1194b8851fccSafresh1 11952e109fb9Safresh1F<File::Path> C<rmtree> and C<remove_tree> will not work with 11962e109fb9Safresh1multithreaded applications due to its use of C<chdir>. At this time, 11972e109fb9Safresh1no warning or error is generated in this situation. You will 11982e109fb9Safresh1certainly encounter unexpected results. 1199b8851fccSafresh1 12002e109fb9Safresh1The implementation that surfaces this limitation will not be changed. See the 12012e109fb9Safresh1F<File::Path::Tiny> module for functionality similar to F<File::Path> but which does 12022e109fb9Safresh1not C<chdir>. 1203b8851fccSafresh1 1204b8851fccSafresh1=head2 NFS Mount Points 1205b8851fccSafresh1 1206b8851fccSafresh1F<File::Path> is not responsible for triggering the automounts, mirror mounts, 1207b8851fccSafresh1and the contents of network mounted filesystems. If your NFS implementation 1208b8851fccSafresh1requires an action to be performed on the filesystem in order for 1209b8851fccSafresh1F<File::Path> to perform operations, it is strongly suggested you assure 1210b8851fccSafresh1filesystem availability by reading the root of the mounted filesystem. 1211b8851fccSafresh1 1212b8851fccSafresh1=head2 REPORTING BUGS 1213b8851fccSafresh1 1214b8851fccSafresh1Please report all bugs on the RT queue, either via the web interface: 1215b39c5158Smillert 1216b39c5158SmillertL<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> 1217b39c5158Smillert 1218b8851fccSafresh1or by email: 1219b8851fccSafresh1 1220b8851fccSafresh1 bug-File-Path@rt.cpan.org 1221b8851fccSafresh1 1222b8851fccSafresh1In either case, please B<attach> patches to the bug report rather than 1223b8851fccSafresh1including them inline in the web post or the body of the email. 1224b8851fccSafresh1 122591f110e0Safresh1You can also send pull requests to the Github repository: 122691f110e0Safresh1 1227b8851fccSafresh1L<https://github.com/rpcme/File-Path> 122891f110e0Safresh1 1229b39c5158Smillert=head1 ACKNOWLEDGEMENTS 1230b39c5158Smillert 1231b39c5158SmillertPaul Szabo identified the race condition originally, and Brendan 1232b39c5158SmillertO'Dea wrote an implementation for Debian that addressed the problem. 1233b39c5158SmillertThat code was used as a basis for the current code. Their efforts 1234b39c5158Smillertare greatly appreciated. 1235b39c5158Smillert 1236b39c5158SmillertGisle Aas made a number of improvements to the documentation for 1237b39c5158Smillert2.07 and his advice and assistance is also greatly appreciated. 1238b39c5158Smillert 1239b39c5158Smillert=head1 AUTHORS 1240b39c5158Smillert 1241b8851fccSafresh1Prior authors and maintainers: Tim Bunce, Charles Bailey, and 1242b8851fccSafresh1David Landgren <F<david@landgren.net>>. 1243b8851fccSafresh1 1244b8851fccSafresh1Current maintainers are Richard Elberger <F<riche@cpan.org>> and 1245b8851fccSafresh1James (Jim) Keenan <F<jkeenan@cpan.org>>. 1246b8851fccSafresh1 1247b8851fccSafresh1=head1 CONTRIBUTORS 1248b8851fccSafresh1 12499f11ffb7Safresh1Contributors to File::Path, in alphabetical order by first name. 1250b8851fccSafresh1 1251b8851fccSafresh1=over 1 1252b8851fccSafresh1 1253b8851fccSafresh1=item <F<bulkdd@cpan.org>> 1254b8851fccSafresh1 12552e109fb9Safresh1=item Charlie Gonzalez <F<itcharlie@cpan.org>> 12562e109fb9Safresh1 1257b8851fccSafresh1=item Craig A. Berry <F<craigberry@mac.com>> 1258b8851fccSafresh1 12592e109fb9Safresh1=item James E Keenan <F<jkeenan@cpan.org>> 12602e109fb9Safresh1 12612e109fb9Safresh1=item John Lightsey <F<john@perlsec.org>> 12622e109fb9Safresh1 12639f11ffb7Safresh1=item Nigel Horne <F<njh@bandsman.co.uk>> 12649f11ffb7Safresh1 1265b8851fccSafresh1=item Richard Elberger <F<riche@cpan.org>> 1266b8851fccSafresh1 1267b8851fccSafresh1=item Ryan Yee <F<ryee@cpan.org>> 1268b8851fccSafresh1 1269b8851fccSafresh1=item Skye Shaw <F<shaw@cpan.org>> 1270b8851fccSafresh1 1271b8851fccSafresh1=item Tom Lutz <F<tommylutz@gmail.com>> 1272b8851fccSafresh1 12732e109fb9Safresh1=item Will Sheppard <F<willsheppard@github>> 12742e109fb9Safresh1 1275b8851fccSafresh1=back 1276b39c5158Smillert 1277b39c5158Smillert=head1 COPYRIGHT 1278b39c5158Smillert 1279b8851fccSafresh1This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren, 1280*eac174f2Safresh1James Keenan and Richard Elberger 1995-2020. All rights reserved. 1281b39c5158Smillert 1282b39c5158Smillert=head1 LICENSE 1283b39c5158Smillert 1284b39c5158SmillertThis library is free software; you can redistribute it and/or modify 1285b39c5158Smillertit under the same terms as Perl itself. 1286b39c5158Smillert 1287b39c5158Smillert=cut 1288