local-lib5/lib/perl5/File/Remove.pm

   1 package File::Remove;
   2
   3 use 5.005;
   4 use strict;
   5
   6 use vars qw{$VERSION @ISA @EXPORT_OK};
   7 use vars qw{$debug $unlink $rmdir};
   8 BEGIN {
   9         $VERSION   = '1.42';
  10         @ISA       = qw{ Exporter};
  11         @EXPORT_OK = qw{ remove rm clear trash };
  12 }
  13
  14 # If we ever need a Mac::Glue object we will want to cache it.
  15 my $glue;
  16
  17 use File::Spec ();
  18 use File::Path ();
  19 use File::Glob ();
  20
  21 sub expand (@) {
  22         map { -e $_ ? $_ : File::Glob::bsd_glob($_) } @_;
  23 }
  24
  25 # $debug variable must be set before loading File::Remove.
  26 # Convert to a constant to allow debugging code to be pruned out.
  27 use constant DEBUG    => !! $debug;
  28
  29 # Are we on VMS?
  30 # If so copy File::Path and assume VMS::Filespec is loaded
  31 use constant IS_VMS   => !! ( $^O eq 'VMS' );
  32
  33 # Are we on Mac?
  34 # If so we'll need to do some special trash work
  35 use constant IS_MAC   => !! ( $^O eq 'darwin' );
  36
  37 # Are we on Win32?
  38 # If so write permissions does not imply deletion permissions
  39 use constant IS_WIN32 => !! ( $^O =~ /^MSWin/ or $^O eq 'cygwin' );
  40
  41
  42
  43
  44
  45 #####################################################################
  46 # Main Functions
  47
  48 my @END_DELETE = ();
  49
  50 sub clear (@) {
  51         my @files = expand( @_ );
  52
  53         # Do the initial deletion
  54         foreach my $file ( @files ) {
  55                 next unless -e $file;
  56                 remove( \1, $file );
  57         }
  58
  59         # Delete again at END-time
  60         push @END_DELETE, @files;
  61 }
  62
  63 END {
  64         foreach my $file ( @END_DELETE ) {
  65                 next unless -e $file;
  66                 remove( \1, $file );
  67         }
  68 }
  69
  70 # acts like unlink would until given a directory as an argument, then
  71 # it acts like rm -rf ;) unless the recursive arg is zero which it is by
  72 # default
  73 sub remove (@) {
  74         my $recursive = (ref $_[0] eq 'SCALAR') ? shift : \0;
  75         my @files     = expand(@_);
  76
  77         # Iterate over the files
  78         my @removes;
  79         foreach my $path ( @files ) {
  80                 # need to check for symlink first
  81                 # could be pointing to nonexisting/non-readable destination
  82                 if ( -l $path ) {
  83                         print "link: $path\n" if DEBUG;
  84                         if ( $unlink ? $unlink->($path) : unlink($path) ) {
  85                                 push @removes, $path;
  86                         }
  87                         next;
  88                 }
  89                 unless ( -e $path ) {
  90                         print "missing: $path\n" if DEBUG;
  91                         push @removes, $path; # Say we deleted it
  92                         next;
  93                 }
  94                 my $can_delete;
  95                 if ( IS_VMS ) {
  96                         $can_delete = VMS::Filespec::candelete($path);
  97                 } elsif ( IS_WIN32 ) {
  98                         # Assume we can delete it for the moment
  99                         $can_delete = 1;
 100                 } elsif ( -w $path ) {
 101                         # We have write permissions already
 102                         $can_delete = 1;
 103                 } elsif ( $< == 0 ) {
 104                         # Unixy and root
 105                         $can_delete = 1;
 106                 } elsif ( (lstat($path))[4] == $< ) {
 107                         # I own the file
 108                         $can_delete = 1;
 109                 } else {
 110                         # I don't think we can delete it
 111                         $can_delete = 0;
 112                 }
 113                 unless ( $can_delete ) {
 114                         print "nowrite: $path\n" if DEBUG;
 115                         next;
 116                 }
 117
 118                 if ( -f $path ) {
 119                         print "file: $path\n" if DEBUG;
 120                         unless ( -w $path ) {
 121                                 # Make the file writable (implementation from File::Path)
 122                                 (undef, undef, my $rp) = lstat $path or next;
 123                                 $rp &= 07777; # Don't forget setuid, setgid, sticky bits
 124                                 $rp |= 0600;  # Turn on user read/write
 125                                 chmod $rp, $path;
 126                         }
 127                         if ( $unlink ? $unlink->($path) : unlink($path) ) {
 128                                 # Failed to delete the file
 129                                 next if -e $path;
 130                                 push @removes, $path;
 131                         }
 132
 133                 } elsif ( -d $path ) {
 134                         print "dir: $path\n" if DEBUG;
 135                         my $dir = File::Spec->canonpath( $path );
 136                         if ( $$recursive ) {
 137                                 if ( File::Path::rmtree( [ $dir ], DEBUG, 0 ) ) {
 138                                         # Failed to delete the directory
 139                                         next if -e $path;
 140                                         push @removes, $path;
 141                                 }
 142
 143                         } else {
 144                                 my ($save_mode) = (stat $dir)[2];
 145                                 chmod $save_mode & 0777, $dir; # just in case we cannot remove it.
 146                                 if ( $rmdir ? $rmdir->($dir) : rmdir($dir) ) {
 147                                         # Failed to delete the directory
 148                                         next if -e $path;
 149                                         push @removes, $path;
 150                                 }
 151                         }
 152
 153                 } else {
 154                         print "???: $path\n" if DEBUG;
 155                 }
 156         }
 157
 158         return @removes;
 159 }
 160
 161 sub rm (@) {
 162         goto &remove;
 163 }
 164
 165 sub trash (@) {
 166         local $unlink = $unlink;
 167         local $rmdir  = $rmdir;
 168
 169         if ( ref $_[0] eq 'HASH' ) {
 170                 my %options = %{+shift @_};
 171                 $unlink = $options{unlink};
 172                 $rmdir  = $options{rmdir};
 173
 174         } elsif ( IS_WIN32 ) {
 175                 local $@;
 176                 eval 'use Win32::FileOp ();';
 177                 die "Can't load Win32::FileOp to support the Recycle Bin: \$@ = $@" if length $@;
 178                 $unlink = \&Win32::FileOp::Recycle;
 179                 $rmdir  = \&Win32::FileOp::Recycle;
 180
 181         } elsif ( IS_MAC ) {
 182                 unless ( $glue ) {
 183                         local $@;
 184                         eval 'use Mac::Glue ();';
 185                         die "Can't load Mac::Glue::Finder to support the Trash Can: \$@ = $@" if length $@;
 186                         $glue = Mac::Glue->new('Finder');
 187                 }
 188                 my $code = sub {
 189                         my @files = map {
 190                                 Mac::Glue::param_type(
 191                                         Mac::Glue::typeAlias() => $_
 192                                 )
 193                         } @_;
 194                         $glue->delete(\@files);
 195                 };
 196                 $unlink = $code;
 197                 $rmdir  = $code;
 198         } else {
 199                 die "Support for trash() on platform '$^O' not available at this time.\n";
 200         }
 201
 202         goto &remove;
 203 }
 204
 205 sub undelete (@) {
 206         goto &trash;
 207 }
 208
 209 1;
 210
 211 __END__
 212
 213 =pod
 214
 215 =head1 NAME
 216
 217 File::Remove - Remove files and directories
 218
 219 =head1 SYNOPSIS
 220
 221     use File::Remove 'remove';
 222
 223     # removes (without recursion) several files
 224     remove( '*.c', '*.pl' );
 225
 226     # removes (with recursion) several directories
 227     remove( \1, qw{directory1 directory2} );
 228
 229     # removes (with recursion) several files and directories
 230     remove( \1, qw{file1 file2 directory1 *~} );
 231
 232     # trashes (with support for undeleting later) several files
 233     trash( '*~' );
 234
 235 =head1 DESCRIPTION
 236
 237 B<File::Remove::remove> removes files and directories.  It acts like
 238 B</bin/rm>, for the most part.  Although C<unlink> can be given a list
 239 of files, it will not remove directories; this module remedies that.
 240 It also accepts wildcards, * and ?, as arguments for filenames.
 241
 242 B<File::Remove::trash> accepts the same arguments as B<remove>, with
 243 the addition of an optional, infrequently used "other platforms"
 244 hashref.
 245
 246 =head1 SUBROUTINES
 247
 248 =head2 remove
 249
 250 Removes files and directories.  Directories are removed recursively like
 251 in B<rm -rf> if the first argument is a reference to a scalar that
 252 evaluates to true.  If the first arguemnt is a reference to a scalar
 253 then it is used as the value of the recursive flag.  By default it's
 254 false so only pass \1 to it.
 255
 256 In list context it returns a list of files/directories removed, in
 257 scalar context it returns the number of files/directories removed.  The
 258 list/number should match what was passed in if everything went well.
 259
 260 =head2 rm
 261
 262 Just calls B<remove>.  It's there for people who get tired of typing
 263 B<remove>.
 264
 265 =head2 clear
 266
 267 The C<clear> function is a version of C<remove> designed for
 268 use in test scripts. It takes a list of paths that it will both
 269 initially delete during the current test run, and then further
 270 flag for deletion at END-time as a convenience for the next test
 271 run.
 272
 273 =head2 trash
 274
 275 Removes files and directories, with support for undeleting later.
 276 Accepts an optional "other platforms" hashref, passing the remaining
 277 arguments to B<remove>.
 278
 279 =over 4
 280
 281 =item Win32
 282
 283 Requires L<Win32::FileOp>.
 284
 285 Installation not actually enforced on Win32 yet, since L<Win32::FileOp>
 286 has badly failing dependencies at time of writing.
 287
 288 =item OS X
 289
 290 Requires L<Mac::Glue>.
 291
 292 =item Other platforms
 293
 294 The first argument to trash() must be a hashref with two keys,
 295 'rmdir' and 'unlink', each referencing a coderef.  The coderefs
 296 will be called with the filenames that are to be deleted.
 297
 298 =back
 299
 300 =head1 SUPPORT
 301
 302 Bugs should always be submitted via the CPAN bug tracker
 303
 304 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Remove>
 305
 306 For other issues, contact the maintainer.
 307
 308 =head1 AUTHOR
 309
 310 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 311
 312 =head1 COPYRIGHT
 313
 314 Some parts copyright 2006 - 2008 Adam Kennedy.
 315
 316 Taken over by Adam Kennedy E<lt>adamk@cpan.orgE<gt>, to fix the
 317 "deep readonly files" bug, and do some more cleaning up.
 318
 319 Some parts copyright 2004 - 2005 Richard Soderberg.
 320
 321 Taken over by Richard Soderberg E<lt>perl@crystalflame.netE<gt>, so as
 322 to port it to L<File::Spec> and add tests.
 323
 324 Original copyright: 1998 by Gabor Egressy, E<lt>gabor@vmunix.comE<gt>.
 325
 326 This program is free software; you can redistribute and/or modify it under
 327 the same terms as Perl itself.
 328
 329 =cut