diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Remove.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/File/Remove.pm | 329 |
1 files changed, 329 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Remove.pm b/Master/tlpkg/tlperl/lib/File/Remove.pm new file mode 100755 index 00000000000..15df470cf47 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/File/Remove.pm @@ -0,0 +1,329 @@ +package File::Remove; + +use 5.005; +use strict; + +use vars qw{$VERSION @ISA @EXPORT_OK}; +use vars qw{$debug $unlink $rmdir}; +BEGIN { + $VERSION = '1.42'; + @ISA = qw{ Exporter}; + @EXPORT_OK = qw{ remove rm clear trash }; +} + +# If we ever need a Mac::Glue object we will want to cache it. +my $glue; + +use File::Spec (); +use File::Path (); +use File::Glob (); + +sub expand (@) { + map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_; +} + +# $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' ); + + + + + +##################################################################### +# Main Functions + +my @END_DELETE = (); + +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 + push @END_DELETE, @files; +} + +END { + foreach my $file ( @END_DELETE ) { + next unless -e $file; + remove( \1, $file ); + } +} + +# 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 ); + 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"; + } + + goto &remove; +} + +sub undelete (@) { + goto &trash; +} + +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 - 2008 Adam Kennedy. + +Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt>, to fix the +"deep readonly files" bug, and do some more cleaning up. + +Some parts copyright 2004 - 2005 Richard Soderberg. + +Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt>, so as +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 |