view release on metacpan or  search on metacpan

local/lib/perl5/File/Remove.pm  view on Meta::CPAN

	my @files = expand( @_ );

	# Do the initial deletion
	foreach my $file ( @files ) {
		next unless -e $file;
		remove( \1, $file );
	}

	# Delete again at END-time.
	# Save the current PID so that forked children
	# won't delete things that the parent expects to
	# live until their end-time.
	push @CLEANUP, map { [ $$, $_ ] } @files;
}

END {
	foreach my $file ( @CLEANUP ) {
		next unless $file->[0] == $$;
		next unless -e $file->[1];
		remove( \1, $file->[1] );
	}
}

# Acts like unlink would until given a directory as an argument, then
# it acts like rm -rf ;) unless the recursive arg is zero which it is by
# default
sub remove (@) {
	my $recursive = (ref $_[0] eq 'SCALAR') ? shift : \0;
    my $opts = (ref $_[0] eq 'HASH') ? shift : { glob => 1 };
	my @files     = _expand_with_opts ($opts, @_);

	# Iterate over the files
	my @removes;
	foreach my $path ( @files ) {
		# need to check for symlink first
		# could be pointing to nonexisting/non-readable destination
		if ( -l $path ) {
			print "link: $path\n" if DEBUG;
			if ( $unlink ? $unlink->($path) : unlink($path) ) {
				push @removes, $path;
			}
			next;
		}
		unless ( -e $path ) {
			print "missing: $path\n" if DEBUG;
			push @removes, $path; # Say we deleted it
			next;
		}
		my $can_delete;
		if ( IS_VMS ) {
			$can_delete = VMS::Filespec::candelete($path);
		} elsif ( IS_WIN32 ) {
			# Assume we can delete it for the moment
			$can_delete = 1;
		} elsif ( -w $path ) {
			# We have write permissions already
			$can_delete = 1;
		} elsif ( $< == 0 ) {
			# Unixy and root
			$can_delete = 1;
		} elsif ( (lstat($path))[4] == $< ) {
			# I own the file
			$can_delete = 1;
		} else {
			# I don't think we can delete it
			$can_delete = 0;
		}
		unless ( $can_delete ) {
			print "nowrite: $path\n" if DEBUG;
			next;
		}

		if ( -f $path ) {
			print "file: $path\n" if DEBUG;
			unless ( -w $path ) {
				# Make the file writable (implementation from File::Path)
				(undef, undef, my $rp) = lstat $path or next;
				$rp &= 07777; # Don't forget setuid, setgid, sticky bits
				$rp |= 0600;  # Turn on user read/write
				chmod $rp, $path;
			}
			if ( $unlink ? $unlink->($path) : unlink($path) ) {
				# Failed to delete the file
				next if -e $path;
				push @removes, $path;
			}

		} elsif ( -d $path ) {
			print "dir: $path\n" if DEBUG;
			my $dir = File::Spec->canonpath($path);

			# Do we need to move our cwd out of the location
			# we are planning to delete?
			my $chdir = _moveto($dir);
			if ( length $chdir ) {
				chdir($chdir) or next;
			}

			if ( $$recursive ) {
				if ( File::Path::rmtree( [ $dir ], DEBUG, 0 ) ) {
					# Failed to delete the directory
					next if -e $path;
					push @removes, $path;
				}

			} else {
				my ($save_mode) = (stat $dir)[2];
				chmod $save_mode & 0777, $dir; # just in case we cannot remove it.
				if ( $rmdir ? $rmdir->($dir) : rmdir($dir) ) {
					# Failed to delete the directory
					next if -e $path;
					push @removes, $path;
				}
			}

		} else {
			print "???: $path\n" if DEBUG;
		}
	}

	return @removes;