File Coverage

bin/rm

Criterion	Covered	Total	%
statement	124	143	86.7
branch	44	68	64.7
condition	11	12	91.6
subroutine	26	30	86.6
pod			n/a
total	205	253	81.0

#!/usr/bin/perl

=encoding utf8

=begin metadata

Name: rm
Description: remove directory entries
Author: brian d foy, [e-mail]
License: artistic2

=end metadata

=cut

=head1 NAME

rm - remove directory entries

=head1 SYNOPSIS

	rm [-fiPrR] 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

=back

=head1 AUTHOR

Copyright (c) brian d foy, [e-mail]

The original version of this program was written by Steve Kemp,
[e-mail], 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 ) {
		$self->error( "$Program: missing argument\n" );
		exit EX_FAILURE;
	}

	my $errors = grep { $self->process_file( $_ ) } $self->files;
	$self->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 exit  { my $self = shift; exit(shift) }

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} }
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)];
		}

	# Expand clustering
	@new_args = map {
			if( /-(.+)/ ) {
				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;

	require Getopt::Long;

	my %opts;
	my $ret = Getopt::Long::GetOptionsFromArray(
		$self->{args},
		'f' => \$opts{'f'},
		'i' => \$opts{'i'},
		'P' => \$opts{'P'},
		'R' => \$opts{'r'},
		'r' => \$opts{'R'},
		'v' => \$opts{'v'},
		);

	$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( ! -w $filename && $self->is_interactive ) {
		$self->message( "$filename: Read-only ? " );
		return OP_SUCCEEDED if  =~ /^[Nn]/;
    }
    elsif( $self->is_interactive ) {
		$self->message( "$filename: ? " );
		return OP_SUCCEEDED if  =~ /^[Nn]/;
    }

    chmod '0777', $filename if $self->is_force;

    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 => 2,
		});
	}

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__;