#!/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.pl 536 2006-11-22 03:12:22Z gremio $|;

#< 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 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

${\w+} will be replaced from the environment if possible.

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. 
The %1 in the command will be substituted by the source filename and
%2 by the destination.  This way you can even tar things and so on.
If either is not present, first %1 then %2 will be appended.  Use of 
double quotes around filenames is highly recommended to prevent problems
with strange filenames.  Double quotes inside each filename will be escaped.

=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.  %1 in the command will be substituted by
the directory to create, and will be appended if not present.  See
C<--copy> as well.  This expects that each nonexistant directory in the 
file path will be created all at once (gnu C<mkdir -p> behavior).

=back

=head1 BUGS

Root cannot use rmv because of huge gaping security holes like
executing arbitrary code read from a config file!  If somebody wants
to make this taint compliant, please let me know.  I think root would
be the one *most* helped by this functionality.

=head1 AUTHOR

Gregory A. Marton       L<http://csail.mit.edu/~gremio/>

with valuable input from Deniz Yuret

=begin html

=head1 Download

This program is distributed under the GNU General Public License: L<http://www.gnu.org/copyleft/gpl.html>

The source: L<http://csail.mit.edu/~gremio/code/rmv.pl>

=end html

=cut

#>

#< config defaults

my $me = $0;
$me =~ s|.*/||;

my $User = ($ENV{LOGNAME} || $ENV{USER} || $ENV{USERNAME} || `whoami`);
die "Root should never use rmv.  It's very insecure.\n"
    if $User eq "root";  #remove this check at your own risk.
#also note:  a determined hacker would have little trouble even exploiting
#            the `whoami` call above to gain root, so this message doesn't 
#            prevent *every* avenue of attack.  The fact that this isn't 
#            compiled isn't great either, but at least it can be made
#            non-modifiable.

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 => qq(cp -dfr "%1" "%2"),
    # -d: don't preserve links (or risk huge or infinitely recursive trash 
    #                           entries)
    # -f: overwrite existing file (in case you delete the name twice within
    #                              the time granularity)
    # -r: recursive (so you CAN remove directories)
    #
    # [-a]: preserving attributes is okay, but the file will not keep its
    # original timestamp.  I forcibly touch it after backing up so the 
    # by_date empty doesn't get confused.

#    copy => qq(mv -f "\%1" "\%2"),
    #                    This is a lot faster for local-disk removes.

    chmod => "chmod",
    date => qq(date "+%Y%m%d%H%M"),
    mkdir => qq(mkdir -p "%1"),
    
    #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>) {
	s/(\$\{?(\w+)\}?)/($ENV{$2}||$1)/ge; #expand variables, if possible.
	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;
my $was_interactive=$config->{interactive};
my $was_forced=$config->{force};
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");

#if both -i and -f are specified on the command line, -i wins, since we're 
#not order sensitive.  OTOH, if it was just specified in the config, -f
# -- the thing we specified now -- will win. 
$config->{interactive} = -1 if $config->{force} and
    ($was_interactive == $config->{interactive});

#don't interact if there's nothing to interact with. 
unless (-t STDIN) {
    $config->{force}=1; 
    $config->{interactive}=-1;
}


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";
    print "recipe file: [$configfile]\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|/[^/]*$||;
	my $mkdir = $config->{mkdir};
	$mkdir =~ s/(?!<\\)\%1/$basedir/gs;
	$mkdir .= qq( "$basedir") if ($mkdir !~ /\Q$basedir\E/);
	print qq($mkdir\n) if $config->{verbose};
	system($mkdir) and
	    die "cannot create directory [$basedir]: $!\n";
    }

    return $target;
}
sub backup {
    my (@files) = @_;
    return 1 if $config->{kill};
    die "$me: trash can [$config->{trashcan}] is not writeable.\n" 
	unless -w $config->{trashcan};
    foreach my $entry (@files) {
	next if $entry =~ $config->{junk};
	next unless -e $entry; #ignore broken symlinks. (keep before -l $entry)
	next unless -l $entry or -f _ or -d _;
	my $dirname = $entry;
	$dirname = "./" unless $dirname =~ m|/|;
	$dirname =~ s|/[^/]+/?$||;
	my $target = &target_name($entry);
	$entry =~ s/\"/\\\"/g;
	my $copy = $config->{copy};
	$copy =~ s/(?!<\\)\%1/$entry/gs;
	$copy =~ s/(?!<\\)\%2/$target/gs;
	$copy .= qq( "$entry") if ($copy !~ /\Q$entry\E/);
	$copy .= qq( "$target") if ($copy !~ /\Q$target\E/);
	print qq($copy\n) if $config->{verbose};
	system(qq($copy)) and 
	    do {
		warn "$me: cannot back up [$entry] to [$target]: $!\n";
		return undef;
	    };
	open(TOUCH, ">>".$entry); #this will intentionally fail on directories
	open(TOUCH, ">>".$target) or system("touch $target");
	close TOUCH;
    }
    return 1;
}

#>
#< empty
sub by_date {return ((-M "$_[0]" || ($config->{max_age} + 1)) 
		     > $config->{max_age});}
sub by_size {
    $config->{done_count}||=2;
    $config->{check_every}||=1;
    return undef 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 (@_) {
	if (not -l $entry and not -e _) {
	    warn "$me: cannot remove [$entry]: No such file or directory\n"
		if $config->{interactive} > -1;
	    next;
	}
	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 "$me: [$entry] is not writeable.\n";
	    my $override=1;
	    if ($config->{interactive} > -1) {
		print "$me: 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")) 
		and warn "cannot $config->{chmod} +w $entry: $@\n";
	}
	#> 
	if (-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;
	    }
	    #>
	    print "backup $entry\n" if $config->{verbose};
	    unless (defined &{$backup}($entry)) {
		print STDERR "cannot back up [$entry]: ";
		#< interact
		if ($config->{interactive} == 1) {
		    print STDERR "remove it anyway? (Ny) ";
		    my $ans = <STDIN>;
		    next unless $ans =~ /y/i and $ans !~ /n/i;
		} else {
		    print STDERR "use the -kill option to bypass backup.\n";
		    next;
		}
		#>
	    }		
	    print "unlink $entry\n" if $config->{verbose};
	    unlink $entry or warn "$me: cannot unlink [$entry]: $!\n";
	} else {
	    unless ($config->{recursive}) {
		warn "$me: [$entry] is a directory.\n";
		next;
	    }
	    local *DIR;
	    opendir(DIR, $entry) or warn "$me: cannot open dir [$entry]: $!\n";
	    my (@contents) = readdir(DIR);
	    #< interact
	    if (scalar @contents > 2) { # 2 being "." and ".."
		$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;
		}
	    } elsif ($config->{interactive} > 0) {
		print STDERR "remove empty directory [$entry]? (Ny) ";
		my $ans = <STDIN>;
		next unless $ans =~ /y/i and $ans !~ /n/i;
	    }
	    #>
	    remove($backup, map {$_ = qq($entry/$_);} @contents);
	    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}) {
    my $mkdir = $config->{mkdir};
    $mkdir =~ s/(?!<\\)\%1/$config->{trashcan}/gs;
    $mkdir .= qq( "$config->{trashcan}") 
	if ($mkdir !~ /\Q$config->{trashcan}\E/);
    print qq($mkdir\n) if $config->{verbose};
    system($mkdir) and
	die "$me: 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 /^\Q$Home\E$/, @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;
    }
}
#>

map {$_ =~ s|/$||} @ARGV;

#< perform faster total backup beforehand if not interacting:
if ($config->{interactive} < 1) {
    print "in non-interactive mode: doing whole backup beforehand.\n"
	if $config->{verbose};
    my $success = &backup(@ARGV);
#      or die "$me: You can use the --kill option to bypass backup.\n";
    if ($success) {
	$method=sub{1};
	print "backup finished: further 'backup' statements are really noops.\n" 
	    if $config->{verbose};
    } else {
	print "backup failed: going to individual backup mode.\n"
	    if $config->{verbose};
	$method=\&backup;
    }
} else {
    # otherwise we'll need to back things up as we destroy them. 
    $method=\&backup;
}
#>

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