—

              
#!/usr/bin/perl
HideShow 54 lines of Pod
=encoding utf8
=begin metadata
Name: rm
Description: remove directory entries
Author: brian d foy, bdfoy@cpan.org
License: artistic2
=end metadata
=cut
=head1 NAME
rm - remove directory entries
=head1 SYNOPSIS
        rm [-fiPrRv] file ...
=head1 DESCRIPTION
=head1 OPTIONS
=over 4
=item * -f - do not prompt the user for each file, and do not consider it an error if a file cannot be removed
=item * -i - prompt the user for each file.
=item * -P - a no-op, for compatibility. So implementations would overwrite files with random data
=item * -r - same as -R
=item * -R - remove directories recursively
=item * -v - show the name of each file after it is removed
=back
=head1 AUTHOR
Copyright (c) brian d foy, bdfoy@cpan.org
The original version of this program was written by Steve Kemp,
steve@steve.org.uk, but almost none of that remains.
=head1 LICENCE
This program is licensed under the Artistic License 2.0.
=cut
package PerlPowerTools::rm;
use strict;
use File::Basename;
use File::Spec::Functions;
use Storable qw(dclone);
use constant EX_SUCCESS   => 0;
use constant EX_FAILURE   => 1;
use constant EX_USAGE     => 2;
use constant OP_SUCCEEDED => 0;
use constant OP_FAILED    => 1;
my $Program = basename($0);
__PACKAGE__->run( args => \@ARGV ) unless caller;
sub run {
        my $class = shift;
        my %args = @_;
        my $args = delete $args{args};
        # This looks funny because the other args are filehandles, which
        # we can't dupe. We want to play with the command-line args such
        # that we don't mess up anything that called us.
        my $self = $class->new( { args => dclone($args), %args } )->process_options;
        $self->error( "$Program: -P ignored\n" ) if $self->is_overwrite;
        unless ( () = $self->files ) {
                exit(EX_SUCCESS) if $self->is_force;
                $self->error( "$Program: missing argument\n" );
                usage();
        }
        my $errors = grep { $self->process_file( $_ ) } $self->files;
        exit( $errors ? EX_FAILURE : EX_SUCCESS );
}
sub new {
        my( $class, $args ) = @_;
        bless {
                $class->defaults,
                %$args
                }, $class;
        }
sub defaults {
        my %hash = (
                args         => [],
                error_fh     => \*STDERR,
                output_fh    => \*STDOUT,
                );
}
sub files { my $self = shift; @{ $self->{files} } }
sub is_force       { my $self = shift; $self->{options}{f} }
sub is_interactive { my $self = shift; $self->{options}{i} }
sub is_overwrite   { my $self = shift; $self->{options}{P} }
sub is_recursive   { my $self = shift; $self->{options}{R} || $self->{options}{r} }
sub is_verbose     { my $self = shift; $self->{options}{v} }
sub options { my $self = shift; $self->{options} }
sub preprocess_options {
        my( $self ) = @_;
        my @new_args = @{ $self->{args} };
        my %args = map { $new_args[$_], $_ } 0 .. $#new_args;
        my @rest;
        if( exists $args{'--'} ) {
                @rest = @new_args[ $args{'--'} .. $#new_args ];
                @new_args = @new_args[0 .. ($args{'--'} - 1)];
                }
        foreach (@new_args) {
                if (m/\A\-\-/) {
                        warn "unknown option: '$_'\n";
                        usage();
                }
        }
        # Expand clustering
        @new_args = map {
                        if( /\A\-(.+)/ ) {
                                my $cluster = $1;
                                map { "-$_" } split //, $cluster;
                        }
                        else {
                                $_;
                        }
                } @new_args;
        # this is rm particular processing: -f and -i turn off each
        # other, and the last one wins. Figure out which one is last
        # then filter out all earlier of the other.
        if( exists $args{'-f'} && exists $args{'-i'} ) {
                my $last;
                foreach ( reverse @new_args ) {
                        next unless /\A-[fi]\z/;
                        $last = $_;
                        last;
                }
                @new_args = map {
                        (
                                ( $last eq '-f' and $_ eq '-i')   # f wins
                                ||
                                ( $last ne '-f' and $_ eq '-f' )  # i wins
                        ) ? () : $_;
                } @new_args;
        }
        $self->{original_args} = $self->{args};
        $self->{args} = $self->{preprocessed_args} = [ @new_args, @rest ];
        return $self;
}
sub process_options {
        my( $self ) = @_;
        $self->preprocess_options;
        use Getopt::Long qw(:config no_ignore_case);
        my %opts;
        my $ret = Getopt::Long::GetOptionsFromArray(
                $self->{args},
                'f' => \$opts{'f'},
                'i' => \$opts{'i'},
                'P' => \$opts{'P'},
                'R' => \$opts{'R'},  # both of these are recursive
                'r' => \$opts{'r'},
                'v' => \$opts{'v'},
                );
        usage() unless $ret;
        $self->{options} = { map { defined $_ ? $_ : 0 } %opts };
        $self->{files}   = $self->{args};
        return $self;
        }
sub process_file {
    my( $self, $filename ) = @_;
        my $method = do {
                if( -d $filename ) {
                        if( ! $self->is_recursive ) {
                                $self->error( "$Program: '$filename': is a directory\n" ) unless $self->is_force;
                                return $self->is_force ? OP_SUCCEEDED : OP_FAILED;
                        }
                        'remove_directory';
                }
                else {
                        'remove_file';
                }
        };
    my $result = $self->$method( $filename );
        return $self->is_force ? OP_SUCCEEDED : $result;
}
sub remove_directory {
    my( $self, $dirname ) = @_;
        my $dh;
    unless( opendir( $dh, $dirname ) ) {
                $self->error( "$Program: cannot open '$dirname': $!\n" ) unless $self->is_force;
                return $self->is_force ? OP_SUCCEEDED : OP_FAILED;
        }
    foreach my $file ( readdir($dh) ) {
                next if $file eq '.' || $file eq '..';
                my $path = catfile( $dirname, $file );
                my $method = -d $path ? 'remove_directory' : 'remove_file';
            my $result = $self->$method($path);
    }
    closedir $dh;
    unless( rmdir $dirname ) {
                $self->error( "$Program: cannot remove directory '$dirname': $!\n" ) unless $self->is_force;
                return $self->is_force ? OP_SUCCEEDED : OP_FAILED;
    }
        $self->message( "$dirname\n" ) if $self->is_verbose;
    return OP_SUCCEEDED;
}
sub remove_file {
    my( $self, $filename ) = @_;
        # Answering no to skip a file is not an error
    if( $self->is_interactive ) {
                $self->message( "$filename: ? " );
                return OP_SUCCEEDED if <STDIN> =~ /^[Nn]/;
    }
    elsif( !$self->is_force && ! -w $filename ) {
                $self->message( "$filename: Read-only ? " );
                return OP_SUCCEEDED if <STDIN> =~ /^[Nn]/;
    }
    unless( unlink $filename ) {
                $self->error( "$Program: cannot remove '$filename': $!\n" ) unless $self->is_force;
                return $self->is_force ? OP_SUCCEEDED : OP_FAILED;
    }
        $self->message( "$filename\n" ) if $self->is_verbose;
    return OP_SUCCEEDED;
}
sub usage {
        require Pod::Usage;
        Pod::Usage::pod2usage({
                -exitval => EX_USAGE,
                -verbose => 1,
                });
        }
sub error_fh { my $self = shift; $self->{error_fh} }
sub error {
        my $self = shift;
        print { $self->error_fh || *STDERR } @_;
        }
sub output_fh { my $self = shift; $self->{output_fh} }
sub message {
        my $self = shift;
        print { $self->output_fh || *STDOUT } @_;
        }
__PACKAGE__;