perl/vendor/lib/File/Remove.pm - chromium/deps/perl - Git at Google

 package File::Remove;

 use 5.00503;
 use strict;

 use vars qw{ $VERSION @ISA @EXPORT_OK };
 use vars qw{ $DEBUG $unlink $rmdir    };
 BEGIN {
 	$VERSION   = '1.52';
 	# $VERSION   = eval $VERSION;
 	@ISA       = qw{ Exporter };
 	@EXPORT_OK = qw{ remove rm clear trash };
 }

 use File::Path ();
 use File::Glob ();
 use File::Spec 3.29 ();
 use Cwd        3.29 ();

 # $debug variable must be set before loading File::Remove.
 # Convert to a constant to allow debugging code to be pruned out.
 use constant DEBUG    => !! $DEBUG;

 # Are we on VMS?
 # If so copy File::Path and assume VMS::Filespec is loaded
 use constant IS_VMS   => !! ( $^O eq 'VMS' );

 # Are we on Mac?
 # If so we'll need to do some special trash work
 use constant IS_MAC   => !! ( $^O eq 'darwin' );

 # Are we on Win32?
 # If so write permissions does not imply deletion permissions
 use constant IS_WIN32 => !! ( $^O =~ /^MSWin/ or $^O eq 'cygwin' );

 # If we ever need a Mac::Glue object we will want to cache it.
 my $glue;


 #####################################################################
 # Main Functions

 my @CLEANUP = ();

 sub clear (@) {
 	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 @files     = expand(@_);

 	# 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;
 }

 sub rm (@) {
 	goto &remove;
 }

 sub trash (@) {
 	local $unlink = $unlink;
 	local $rmdir  = $rmdir;

 	if ( ref $_[0] eq 'HASH' ) {
 		my %options = %{+shift @_};
 		$unlink = $options{unlink};
 		$rmdir  = $options{rmdir};

 	} elsif ( IS_WIN32 ) {
 		local $@;
 		eval 'use Win32::FileOp ();';
 		die "Can't load Win32::FileOp to support the Recycle Bin: \$@ = $@" if length $@;
 		$unlink = \&Win32::FileOp::Recycle;
 		$rmdir  = \&Win32::FileOp::Recycle;

 	} elsif ( IS_MAC ) {
 		unless ( $glue ) {
 			local $@;
 			eval 'use Mac::Glue ();';
 			die "Can't load Mac::Glue::Finder to support the Trash Can: \$@ = $@" if length $@;
 			$glue = Mac::Glue->new('Finder');
 		}
 		my $code = sub {
 			my @files = map {
 				Mac::Glue::param_type(
 					Mac::Glue::typeAlias() => $_
 				)
 			} @_;
 			$glue->delete(\@files);
 		};
 		$unlink = $code;
 		$rmdir  = $code;
 	} else {
 		die "Support for trash() on platform '$^O' not available at this time.\n";
 	}

 	remove(@_);
 }

 sub undelete (@) {
 	goto &trash;
 }


 ######################################################################
 # Support Functions

 sub expand (@) {
 	map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_;
 }

 # Do we need to move to a different directory to delete a directory,
 # and if so which.
 sub _moveto {
 	my $remove = File::Spec->rel2abs(shift);
 	my $cwd    = @_ ? shift : Cwd::cwd();

 	# Do everything in absolute terms
 	$remove = Cwd::abs_path( $remove );
 	$cwd    = Cwd::abs_path( $cwd    );

 	# If we are on a different volume we don't need to move
 	my ( $cv, $cd ) = File::Spec->splitpath( $cwd,    1 );
 	my ( $rv, $rd ) = File::Spec->splitpath( $remove, 1 );
 	return '' unless $cv eq $rv;

 	# If we have to move, it's to one level above the deletion
 	my @cd = File::Spec->splitdir($cd);
 	my @rd = File::Spec->splitdir($rd);

 	# Is the current directory the same as or inside the remove directory?
 	unless ( @cd >= @rd ) {
 		return '';
 	}
 	foreach ( 0 .. $#rd ) {
 		$cd[$_] eq $rd[$_] or return '';
 	}

 	# Confirmed, the current working dir is in the removal dir
 	pop @rd;
 	return File::Spec->catpath(
 		$rv,
 		File::Spec->catdir(@rd),
 		''
 	);
 }

 1;

 __END__

 =pod

 =head1 NAME

 File::Remove - Remove files and directories

 =head1 SYNOPSIS

     use File::Remove 'remove';

     # removes (without recursion) several files
     remove( '*.c', '*.pl' );

     # removes (with recursion) several directories
     remove( \1, qw{directory1 directory2} );

     # removes (with recursion) several files and directories
     remove( \1, qw{file1 file2 directory1 *~} );

     # trashes (with support for undeleting later) several files
     trash( '*~' );

 =head1 DESCRIPTION

 B<File::Remove::remove> removes files and directories.  It acts like
 B</bin/rm>, for the most part.  Although C<unlink> can be given a list
 of files, it will not remove directories; this module remedies that.
 It also accepts wildcards, * and ?, as arguments for filenames.

 B<File::Remove::trash> accepts the same arguments as B<remove>, with
 the addition of an optional, infrequently used "other platforms"
 hashref.

 =head1 SUBROUTINES

 =head2 remove

 Removes files and directories.  Directories are removed recursively like
 in B<rm -rf> if the first argument is a reference to a scalar that
 evaluates to true.  If the first arguemnt is a reference to a scalar
 then it is used as the value of the recursive flag.  By default it's
 false so only pass \1 to it.

 In list context it returns a list of files/directories removed, in
 scalar context it returns the number of files/directories removed.  The
 list/number should match what was passed in if everything went well.

 =head2 rm

 Just calls B<remove>.  It's there for people who get tired of typing
 B<remove>.

 =head2 clear

 The C<clear> function is a version of C<remove> designed for
 use in test scripts. It takes a list of paths that it will both
 initially delete during the current test run, and then further
 flag for deletion at END-time as a convenience for the next test
 run.

 =head2 trash

 Removes files and directories, with support for undeleting later.
 Accepts an optional "other platforms" hashref, passing the remaining
 arguments to B<remove>.

 =over 4

 =item Win32

 Requires L<Win32::FileOp>.

 Installation not actually enforced on Win32 yet, since L<Win32::FileOp>
 has badly failing dependencies at time of writing.

 =item OS X

 Requires L<Mac::Glue>.

 =item Other platforms

 The first argument to trash() must be a hashref with two keys,
 'rmdir' and 'unlink', each referencing a coderef.  The coderefs
 will be called with the filenames that are to be deleted.

 =back

 =head1 SUPPORT

 Bugs should always be submitted via the CPAN bug tracker

 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Remove>

 For other issues, contact the maintainer.

 =head1 AUTHOR

 Adam Kennedy E<lt>adamk@cpan.orgE<gt>

 =head1 COPYRIGHT

 Some parts copyright 2006 - 2012 Adam Kennedy.

 Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt> to fix the
 "deep readonly files" bug, and do some package cleaning.

 Some parts copyright 2004 - 2005 Richard Soderberg.

 Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt> to
 port it to L<File::Spec> and add tests.

 Original copyright: 1998 by Gabor Egressy, E<lt>gabor@vmunix.comE<gt>.

 This program is free software; you can redistribute and/or modify it under
 the same terms as Perl itself.

 =cut
	package File::Remove;

	use 5.00503;
	use strict;

	use vars qw{ $VERSION @ISA @EXPORT_OK };
	use vars qw{ $DEBUG $unlink $rmdir };
	BEGIN {
	$VERSION = '1.52';
	# $VERSION = eval $VERSION;
	@ISA = qw{ Exporter };
	@EXPORT_OK = qw{ remove rm clear trash };
	}

	use File::Path ();
	use File::Glob ();
	use File::Spec 3.29 ();
	use Cwd 3.29 ();

	# $debug variable must be set before loading File::Remove.
	# Convert to a constant to allow debugging code to be pruned out.
	use constant DEBUG => !! $DEBUG;

	# Are we on VMS?
	# If so copy File::Path and assume VMS::Filespec is loaded
	use constant IS_VMS => !! ( $^O eq 'VMS' );

	# Are we on Mac?
	# If so we'll need to do some special trash work
	use constant IS_MAC => !! ( $^O eq 'darwin' );

	# Are we on Win32?
	# If so write permissions does not imply deletion permissions
	use constant IS_WIN32 => !! ( $^O =~ /^MSWin/ or $^O eq 'cygwin' );

	# If we ever need a Mac::Glue object we will want to cache it.
	my $glue;





	#####################################################################
	# Main Functions

	my @CLEANUP = ();

	sub clear (@) {
	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 @files = expand(@_);

	# 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;
	}

	sub rm (@) {
	goto &remove;
	}

	sub trash (@) {
	local $unlink = $unlink;
	local $rmdir = $rmdir;

	if ( ref $_[0] eq 'HASH' ) {
	my %options = %{+shift @_};
	$unlink = $options{unlink};
	$rmdir = $options{rmdir};

	} elsif ( IS_WIN32 ) {
	local $@;
	eval 'use Win32::FileOp ();';
	die "Can't load Win32::FileOp to support the Recycle Bin: \$@ = $@" if length $@;
	$unlink = \&Win32::FileOp::Recycle;
	$rmdir = \&Win32::FileOp::Recycle;

	} elsif ( IS_MAC ) {
	unless ( $glue ) {
	local $@;
	eval 'use Mac::Glue ();';
	die "Can't load Mac::Glue::Finder to support the Trash Can: \$@ = $@" if length $@;
	$glue = Mac::Glue->new('Finder');
	}
	my $code = sub {
	my @files = map {
	Mac::Glue::param_type(
	Mac::Glue::typeAlias() => $_
	)
	} @_;
	$glue->delete(\@files);
	};
	$unlink = $code;
	$rmdir = $code;
	} else {
	die "Support for trash() on platform '$^O' not available at this time.\n";
	}

	remove(@_);
	}

	sub undelete (@) {
	goto &trash;
	}





	######################################################################
	# Support Functions

	sub expand (@) {
	map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_;
	}

	# Do we need to move to a different directory to delete a directory,
	# and if so which.
	sub _moveto {
	my $remove = File::Spec->rel2abs(shift);
	my $cwd = @_ ? shift : Cwd::cwd();

	# Do everything in absolute terms
	$remove = Cwd::abs_path( $remove );
	$cwd = Cwd::abs_path( $cwd );

	# If we are on a different volume we don't need to move
	my ( $cv, $cd ) = File::Spec->splitpath( $cwd, 1 );
	my ( $rv, $rd ) = File::Spec->splitpath( $remove, 1 );
	return '' unless $cv eq $rv;

	# If we have to move, it's to one level above the deletion
	my @cd = File::Spec->splitdir($cd);
	my @rd = File::Spec->splitdir($rd);

	# Is the current directory the same as or inside the remove directory?
	unless ( @cd >= @rd ) {
	return '';
	}
	foreach ( 0 .. $#rd ) {
	$cd[$_] eq $rd[$_] or return '';
	}

	# Confirmed, the current working dir is in the removal dir
	pop @rd;
	return File::Spec->catpath(
	$rv,
	File::Spec->catdir(@rd),
	''
	);
	}

	1;

	__END__

	=pod

	=head1 NAME

	File::Remove - Remove files and directories

	=head1 SYNOPSIS

	use File::Remove 'remove';

	# removes (without recursion) several files
	remove( '.c', '.pl' );

	# removes (with recursion) several directories
	remove( \1, qw{directory1 directory2} );

	# removes (with recursion) several files and directories
	remove( \1, qw{file1 file2 directory1 *~} );

	# trashes (with support for undeleting later) several files
	trash( '*~' );

	=head1 DESCRIPTION

	B<File::Remove::remove> removes files and directories. It acts like
	B</bin/rm>, for the most part. Although C<unlink> can be given a list
	of files, it will not remove directories; this module remedies that.
	It also accepts wildcards, * and ?, as arguments for filenames.

	B<File::Remove::trash> accepts the same arguments as B<remove>, with
	the addition of an optional, infrequently used "other platforms"
	hashref.

	=head1 SUBROUTINES

	=head2 remove

	Removes files and directories. Directories are removed recursively like
	in B<rm -rf> if the first argument is a reference to a scalar that
	evaluates to true. If the first arguemnt is a reference to a scalar
	then it is used as the value of the recursive flag. By default it's
	false so only pass \1 to it.

	In list context it returns a list of files/directories removed, in
	scalar context it returns the number of files/directories removed. The
	list/number should match what was passed in if everything went well.

	=head2 rm

	Just calls B<remove>. It's there for people who get tired of typing
	B<remove>.

	=head2 clear

	The C<clear> function is a version of C<remove> designed for
	use in test scripts. It takes a list of paths that it will both
	initially delete during the current test run, and then further
	flag for deletion at END-time as a convenience for the next test
	run.

	=head2 trash

	Removes files and directories, with support for undeleting later.
	Accepts an optional "other platforms" hashref, passing the remaining
	arguments to B<remove>.

	=over 4

	=item Win32

	Requires L<Win32::FileOp>.

	Installation not actually enforced on Win32 yet, since L<Win32::FileOp>
	has badly failing dependencies at time of writing.

	=item OS X

	Requires L<Mac::Glue>.

	=item Other platforms

	The first argument to trash() must be a hashref with two keys,
	'rmdir' and 'unlink', each referencing a coderef. The coderefs
	will be called with the filenames that are to be deleted.

	=back

	=head1 SUPPORT

	Bugs should always be submitted via the CPAN bug tracker

	L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Remove>

	For other issues, contact the maintainer.

	=head1 AUTHOR

	Adam Kennedy E<lt>adamk@cpan.orgE<gt>

	=head1 COPYRIGHT

	Some parts copyright 2006 - 2012 Adam Kennedy.

	Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt> to fix the
	"deep readonly files" bug, and do some package cleaning.

	Some parts copyright 2004 - 2005 Richard Soderberg.

	Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt> to
	port it to L<File::Spec> and add tests.

	Original copyright: 1998 by Gabor Egressy, E<lt>gabor@vmunix.comE<gt>.

	This program is free software; you can redistribute and/or modify it under
	the same terms as Perl itself.

	=cut