#!/usr/bin/perl -w 
#emacs note: the '#<' and '#>' marks are folding marks for folding.el.
#            you may find reading the code with folding more pleasant.

# COPYING: This source may be modified, copied, and distributed under
#          the terms of any license meeting the Open Source Definition:
#          http://basiclinux.hypermart.net/opensource/perens.html
#          If you want to be particular, you may distribute it in
#          accordance with the the distribution rules of GNU rm.

use strict;

my $Version = q|$Id: rmv,v 1.5 2000/11/20 04:07:49 gmarton Exp $|;

#< documentation
=pod

=head1 NAME

rmv - remove files and directories, with a trash can

=head1 SYNOPSIS

rmv [OPTIONS]... FILES...

=head1 DESCRIPTION

rmv is intended to replace GNU rm for the average user.  It 
should not generally be used by root or by suid programs 
because it is insecure.  It attempts to mimic and extend 
GNU rm's functionality and interface.  

By default, rmv does not remove directories.  If a file is not
writeable, and the standard input is a tty, and the C<-f> or C<--force>
option has not been specified, then rmv will prompt the user about
removing the file anyway.

rmv, like every program that uses Getopt::Long to parse its arguments,
lets you use the -- option to indicate that all following arguments
are non-options.  To remove a file called 'C<-f>' in the current
directory, you could type either

     rmv -- -f
or
     rmv ./-f


=head1 OPTIONS

All options may be specified on the command line, or in an rcfile in the form
option=value

Options will be read from rmvrc in /etc/skel, /etc/profile, or /etc,
or from ~/.rmvrc.  Options given on the command line will override any
of these.  For options without apparent values, set them to B<1> or B<0> for
on or off respectively in the rcfile.

=head2 options similar to GNU rm's:

=over

=item -f, --force

ignore nonexistent files, never prompt

=item -i, --interactive

prompt before any removal

=item -r, -R, --recursive

remove the contents of directories recursively

=item -v, --verbose

explain what is being done

=item -h, --help

display this help text and exit

=item --version

output version information and settings, then exit

=back



=head2 additional features:

=over 

=item -k, --kill

permanently remove files, bypassing the trash can (just like rm).

=item -e, --empty

empty the trash can. 

By default, this cleans out trash more than max_age (see below) old.
you can specify --empty=all to clear out all the trash, or
--empty=by_size to clear out the oldest trash first, until the trash
can is less than max_size (see below) kilobytes

I recommend an rmv --empty either in your .login, or as a cron job.

=back

=head2 settings:

note: --option "value" will work just as well as the forms below.

=over

=item --junk=B<pttn>

do not back up files matching the perl regular expression /B<pttn>/

=item --trashcan=B<path>

use B<path> as the trash can

=item --max_age=B<days>

set the maximum age for emptying by date to B<days>

=item --max_size=B<kb>

set the maximum size for the trash can to B<kb> kilobytes

=item --copy=B<cmd>

specify B<cmd> as the command for copying files

=item --chmod=B<cmd>

specify B<cmd> as the command for changing permissions (with chmod style
arguments) on a file

=item --date=B<cmd>

specify B<cmd> as the command for finding the date (specify the date
format this way)

=item --mkdir=B<cmd> 

specify B<cmd> as the command for creating a directory, and possibly
parent directories as well.

=back

=head1 AUTHOR

Written by Greg Marton with valuable input from Deniz Yuret.
Bugs and comments to gremio@speakeasy.org

=cut
#>

#< config defaults

my $User = ($ENV{LOGNAME} || $ENV{USER} || $ENV{USERNAME});
my $Home = $ENV{HOME};
unless ($Home) {
    foreach (qw(/home /usr/home/ /export/home/ /usr/export/home/)) {
	$Home ||= "$_/$User" if -d "$_/$User";
    }
}
my $config = { 
    #system commands:
    copy => "cp -dfr", # if you preserve attributes, the by_date empty will
    #                    get confused.  if you don't preserve links (-d) you
    #                    risk huge trash cans or infinitely recursive ones. 
    #                    if you don't override (-f) you may die on removing 
    #                    the same file twice within the date period below. 
    chmod => "chmod",
    date => qq(date "+%Y%m%d%H%M"),
    mkdir => "mkdir -p",
    
    #settings
    trashcan => qq($Home/.trash),
    clean_first => "",
    junk => qq(^\$),
    max_size => 5000,
    max_age => 7, 
    recursive => 0,
    interactive => 0
    };

#>

#< read_config_file($configfilename, \%config);
sub read_config_file {
    my ($configfile, $config) = @_;
    #configfile is the name of the configuration file to read. 
    #config is a hash of default (or pre-existing) values. 
    open(CONF, "<". $configfile) or return $config;
    while (<CONF>) {
	if (/^(\w+)\s*=\s*(.*?)\s*$/) {
	    $config->{$1}=$2;
	} elsif (/^(\w+)\s*\+=\s*(.*?)\s*$/) {
	    $config->{$1} ||= [];
	    push @{$config->{$1}}, $2;
	}
    }
}
#>
#< read config
{
    my $configfile;
    my $rc = $0;
    $rc =~ s|^.*/||;
    $rc .= "rc";
    $configfile = qq($Home/.$rc);
    $configfile = qq(/etc/skel/$rc) unless -f $configfile;
    $configfile = qq(/etc/profile/$rc) unless -f $configfile;
    $configfile = qq(/etc/$rc) unless -f $configfile;
    read_config_file($configfile, $config);
}
#>
#< option processing

use Getopt::Long;
while (defined $ARGV[0] and $ARGV[0] =~ /^-[fRrivh]+$/) {
    #enable aggregate processing for -h, -f, -i, -r, -v to better emulate rm.
    #I refuse to enable -d for something that's supposed to be "safer". 
    my $opts = shift @ARGV;
    foreach (split //, $opts) {
	$config->{interactive}=1 if /i/;
	$config->{force}=1 if /f/;
	$config->{recursive}=1 if /r/i;
	$config->{verbose}=1 if /v/;
	$config->{help}=1 if /h/;
    }
}
GetOptions($config, 
	   #system calls: 
	   "copy=s", "chmod=s", "date=s", "mkdir=s",
	   #settings:
	   "trashcan=s", "junk=s", "max_size=i", "max_age=f", 
	   #standard rm options:
	   "interactive", "force", "recursive", "verbose", "help", "version",
	   #rmv commands:
	   "empty:s", "kill");
$config->{force}=1 unless -t STDIN; #don't interact if there's nothing to 
#                                    interact with. 
$config->{interactive} = -1 if $config->{force};

if ($config->{help}) {
    $ENV{PAGER} ||= "more";
    exec(qq(pod2man $0 | nroff -man | $ENV{PAGER})) or 
	exec(qq(perl -ne'{\$a++ if /^=pod/; \$a-- if /^=cut/; s/^=\\w+//; print if \$a;}' $0))
	     #now how exactly they managed to execute the program and didn't 
	     #luck out on that second try, I don't know, but just in case...
	    or (print "couldn't print the help for some reason.  sorry.\n" 
		and exit 0);

}
if ($config->{version}) {
    print "$0: version $Version\n";
    use Data::Dumper;
    print Data::Dumper->Dump([$config],["config"]);
    
    print "\n\nCopyright (C) 2000 Gregory Marton\n";
    print "This is free software; see the source for copying conditions.\n";
    print "There is NO warranty; not even for MERCHANTABILITY or \n";
    print "FITNESS FOR A PARTICULAR PURPOSE.\n";
    exit 0;
}

#>

#< find the current directory and date
use Cwd;
my $Curdir = cwd();
chomp $Curdir;
$Curdir =~ s|/$||;
$Curdir =~ s|.*/||;

my $Date = qx($config->{date});
chomp $Date;
#>

#< backup
sub target_name {
    my ($target) = @_;
    my $basedir = $target;
    $basedir =~ s|^(.+)/.*|$1|;
    my $newbasedir = $basedir;
    $newbasedir =~ s/\W/_/gs;
    $target =~ s|\Q$basedir\E|$newbasedir|;
    $target = $config->{trashcan} ."/". $Date ."_". $Curdir ."_". $target;

    #now make sure the target's directory exists.
    if ($target !~ m|/$|) {
	$basedir = $target;
	$basedir =~ s|/[^/]*$||;
	print qq($config->{mkdir} $basedir\n) if $config->{verbose};
	system(qq($config->{mkdir} $basedir));
    }
    return $target;
}
sub backup {
    return 1 if $config->{kill};
    die "$0: trash can [$config->{trashcan}] is not writeable.\n" 
	unless -w $config->{trashcan};
    foreach my $entry (@_) {
	next if $entry =~ $config->{junk};
	next unless -l $entry or -f _ or -d _;
	my $target = &target_name($entry);
	print qq($config->{copy} "$entry" "$target"\n) if $config->{verbose};
	system(qq($config->{copy} "$entry" "$target")) and 
	    do {
		warn "$0: cannot back up [$entry] to [$target]\n";
		return 0;
	    };
    }
    return 1;
}
#>
#< empty
sub by_date {return (-M "$_[0]" > $config->{max_age});}
sub by_size {
    $config->{done_count}||=2;
    $config->{check_every}||=1;
    return if $config->{check_every} < 0;
    unless ($config->{done_count} % $config->{check_every}) {
	#check again every 10 files. 
	my $size = qx(du -ks $config->{trashcan});
	$size =~ s/\D//g;
	print "size = $size\n";

	#check less often if we've more to do:
	$config->{check_every} = ($size - $config->{max_size}) / 1024;
	$config->{check_every} =~ s/\..*//;
	print "will check again in $config->{check_every} files...\n";

	$config->{done_count} = -1 if $size < $config->{max_size};
    }
    return 0 if $config->{done_count} < 0;
    return ++$config->{done_count};
}
#>
#< remove 

sub remove {
    #this is basically an internal implementation of /bin/rm.
    #it's faster to do it like this than to make a million system calls.
    my $backup = shift @_;
    foreach my $entry (@_) {
	next unless -l $entry or -e $entry;
	next if $entry =~ m|^(.*/)?\.\.?$|; #don't worry about specials.
	print "trying to remove $entry\n" if $config->{verbose};
	#< check writeable, maybe chmod.

	if (not -l $entry and not -w _) { #lstat needed, and ok for -w.
#	    warn "$0: [$entry] is not writeable.\n";
	    my $override=1;
	    if ($config->{interactive} > -1) {
		print "$0: override write-protection for [$entry]? (Ny) ";
		$override = <STDIN>;
		$override = ($override =~ /[yY]/ and $override !~ /[nN]/);
	    }
	    next unless $override;
	    my $e = $entry;
	    $e =~ s/\"/\\\"/;
	    print qq($config->{chmod} +w "$entry"\n) if $config->{verbose};
	    system(qq($config->{chmod} +w "$entry"));
	    if (not -w $entry) { #need a new stat.
		warn "$0: cannot change permissions for [$entry]: $!\n";
		next;
	    }
	}

	#> 
	if (-f $entry or -l $entry or not -d _) { # -l needs an lstat, not just a stat.
	    #< interact
	    if ($config->{interactive} == 1) {
		print STDERR "remove [$entry]? (Ny) ";
		my $ans = <STDIN>;
		next unless $ans =~ /y/i and $ans !~ /n/i;
	    }
	    #>
	    &{$backup}($entry) or next;
	    print "unlink $entry\n" if $config->{verbose};
	    unlink $entry or warn "$0: cannot unlink [$entry]: $!\n";
	} else {
	    $entry =~ s|/$||;
	    unless ($config->{recursive}) {
		warn "$0: [$entry] is a directory.\n";
		next;
	    }
	    #< interact
	    $config->{interactive}++ if $config->{interactive} > 1;
	    if ($config->{interactive} == 1) {
		print STDERR "remove directory [$entry]? (Eny) ";
		my $ans = <STDIN>;
		next if $ans =~ /n/i;
		$config->{interactive}++ if $ans =~ /y/i and $ans !~ /e/i;
	    }
	    #>
	    local *DIR;
	    opendir(DIR, $entry) or warn "$0: cannot open dir [$entry]: $!\n";
	    remove($backup, map {$_ = qq($entry/$_);} readdir(DIR));
	    closedir(DIR);
	    print "rmdir $entry\n" if $config->{verbose};
	    rmdir $entry;
	    $config->{interactive}-- if $config->{interactive} > 1;
	}
    }
}

#>

#< take out the trash
if (defined $config->{empty}) {
    my $tmp_conf = { %$config };
    $config->{recursive} = 1;
    $config->{interactive} = -1;

    remove(sub {return $_[0] =~ m|$config->{clean_first}|}, 
	   $config->{trashcan}) if $config->{clean_first};

    my $method;
    $method = sub{1} if $config->{empty} eq "all";
    $method = \&by_size if $config->{empty} eq "by_size";
    $method ||= \&by_date;
    remove($method, $config->{trashcan});

    $config = $tmp_conf;
}
#>
#< make sure there's a trashcan

if (! -d $config->{trashcan}) {
    print qq($config->{mkdir} $config->{trashcan}\n) if $config->{verbose};
    system(qq($config->{mkdir} $config->{trashcan})) and 
	die "$0: cannot make trash can at [$config->{trashcan}]: $!\n";
}

#>

my $method;
#< check for accidental rmv ~ instead of rmv *~ or something. 
unless ($config->{interactive} < 0) {
    if (grep /$Home/, @ARGV) {
	print qq(Are you sure you want to remove your home directory? (Ny) );
	my $answer = <STDIN>;
	exit 0 unless $answer =~ /y/i and $answer !~ /n/i;
    }
}
#>

#< perform faster total backup beforehand if not interacting:
if ($config->{interactive} < 1) {
    &backup(@ARGV) or 
	die "$0: You can use the --kill option to bypass backup.\n";
    $method=sub{1};
} else {
    # otherwise we'll need to back things up as we destroy them. 
    $method=\&backup;
}
#>

remove($method, @ARGV);
@ARGV = ();