1: #!/usr/bin/perl -w
2: #emacs note: the '#<' and '#>' marks are folding marks for folding.el.
3: # you may find reading the code with folding more pleasant.
4:
5: # COPYING: This source may be modified, copied, and distributed under
6: # the terms of any license meeting the Open Source Definition:
7: # http://basiclinux.hypermart.net/opensource/perens.html
8: # If you want to be particular, you may distribute it in
9: # accordance with the the distribution rules of GNU rm.
10:
11: use strict;
12:
13: my $Version = q|$Id: rmv,v 1.5 2000/11/20 04:07:49 gmarton Exp $|;
14:
15: #< documentation
16: =pod
17:
18: =head1 NAME
19:
20: rmv - remove files and directories, with a trash can
21:
22: =head1 SYNOPSIS
23:
24: rmv [OPTIONS]... FILES...
25:
26: =head1 DESCRIPTION
27:
28: rmv is intended to replace GNU rm for the average user. It
29: should not generally be used by root or by suid programs
30: because it is insecure. It attempts to mimic and extend
31: GNU rm's functionality and interface.
32:
33: By default, rmv does not remove directories. If a file is not
34: writeable, and the standard input is a tty, and the C<-f> or C<--force>
35: option has not been specified, then rmv will prompt the user about
36: removing the file anyway.
37:
38: rmv, like every program that uses Getopt::Long to parse its arguments,
39: lets you use the -- option to indicate that all following arguments
40: are non-options. To remove a file called 'C<-f>' in the current
41: directory, you could type either
42:
43: rmv -- -f
44: or
45: rmv ./-f
46:
47:
48: =head1 OPTIONS
49:
50: All options may be specified on the command line, or in an rcfile in the form
51: option=value
52:
53: Options will be read from rmvrc in /etc/skel, /etc/profile, or /etc,
54: or from ~/.rmvrc. Options given on the command line will override any
55: of these. For options without apparent values, set them to B<1> or B<0> for
56: on or off respectively in the rcfile.
57:
58: =head2 options similar to GNU rm's:
59:
60: =over
61:
62: =item -f, --force
63:
64: ignore nonexistent files, never prompt
65:
66: =item -i, --interactive
67:
68: prompt before any removal
69:
70: =item -r, -R, --recursive
71:
72: remove the contents of directories recursively
73:
74: =item -v, --verbose
75:
76: explain what is being done
77:
78: =item -h, --help
79:
80: display this help text and exit
81:
82: =item --version
83:
84: output version information and settings, then exit
85:
86: =back
87:
88:
89:
90: =head2 additional features:
91:
92: =over
93:
94: =item -k, --kill
95:
96: permanently remove files, bypassing the trash can (just like rm).
97:
98: =item -e, --empty
99:
100: empty the trash can.
101:
102: By default, this cleans out trash more than max_age (see below) old.
103: you can specify --empty=all to clear out all the trash, or
104: --empty=by_size to clear out the oldest trash first, until the trash
105: can is less than max_size (see below) kilobytes
106:
107: I recommend an rmv --empty either in your .login, or as a cron job.
108:
109: =back
110:
111: =head2 settings:
112:
113: note: --option "value" will work just as well as the forms below.
114:
115: =over
116:
117: =item --junk=B<pttn>
118:
119: do not back up files matching the perl regular expression /B<pttn>/
120:
121: =item --trashcan=B<path>
122:
123: use B<path> as the trash can
124:
125: =item --max_age=B<days>
126:
127: set the maximum age for emptying by date to B<days>
128:
129: =item --max_size=B<kb>
130:
131: set the maximum size for the trash can to B<kb> kilobytes
132:
133: =item --copy=B<cmd>
134:
135: specify B<cmd> as the command for copying files
136:
137: =item --chmod=B<cmd>
138:
139: specify B<cmd> as the command for changing permissions (with chmod style
140: arguments) on a file
141:
142: =item --date=B<cmd>
143:
144: specify B<cmd> as the command for finding the date (specify the date
145: format this way)
146:
147: =item --mkdir=B<cmd>
148:
149: specify B<cmd> as the command for creating a directory, and possibly
150: parent directories as well.
151:
152: =back
153:
154: =head1 AUTHOR
155:
156: Written by Greg Marton with valuable input from Deniz Yuret.
157: Bugs and comments to gremio@speakeasy.org
158:
159: =cut
160: #>
161:
162: #< config defaults
163:
164: my $User = ($ENV{LOGNAME} || $ENV{USER} || $ENV{USERNAME});
165: my $Home = $ENV{HOME};
166: unless ($Home) {
167: foreach (qw(/home /usr/home/ /export/home/ /usr/export/home/)) {
168: $Home ||= "$_/$User" if -d "$_/$User";
169: }
170: }
171: my $config = {
172: #system commands:
173: copy => "cp -dfr", # if you preserve attributes, the by_date empty will
174: # get confused. if you don't preserve links (-d) you
175: # risk huge trash cans or infinitely recursive ones.
176: # if you don't override (-f) you may die on removing
177: # the same file twice within the date period below.
178: chmod => "chmod",
179: date => qq(date "+%Y%m%d%H%M"),
180: mkdir => "mkdir -p",
181:
182: #settings
183: trashcan => qq($Home/.trash),
184: clean_first => "",
185: junk => qq(^\$),
186: max_size => 5000,
187: max_age => 7,
188: recursive => 0,
189: interactive => 0
190: };
191:
192: #>
193:
194: #< read_config_file($configfilename, \%config);
195: sub read_config_file {
196: my ($configfile, $config) = @_;
197: #configfile is the name of the configuration file to read.
198: #config is a hash of default (or pre-existing) values.
199: open(CONF, "<". $configfile) or return $config;
200: while (<CONF>) {
201: if (/^(\w+)\s*=\s*(.*?)\s*$/) {
202: $config->{$1}=$2;
203: } elsif (/^(\w+)\s*\+=\s*(.*?)\s*$/) {
204: $config->{$1} ||= [];
205: push @{$config->{$1}}, $2;
206: }
207: }
208: }
209: #>
210: #< read config
211: {
212: my $configfile;
213: my $rc = $0;
214: $rc =~ s|^.*/||;
215: $rc .= "rc";
216: $configfile = qq($Home/.$rc);
217: $configfile = qq(/etc/skel/$rc) unless -f $configfile;
218: $configfile = qq(/etc/profile/$rc) unless -f $configfile;
219: $configfile = qq(/etc/$rc) unless -f $configfile;
220: read_config_file($configfile, $config);
221: }
222: #>
223: #< option processing
224:
225: use Getopt::Long;
226: while (defined $ARGV[0] and $ARGV[0] =~ /^-[fRrivh]+$/) {
227: #enable aggregate processing for -h, -f, -i, -r, -v to better emulate rm.
228: #I refuse to enable -d for something that's supposed to be "safer".
229: my $opts = shift @ARGV;
230: foreach (split //, $opts) {
231: $config->{interactive}=1 if /i/;
232: $config->{force}=1 if /f/;
233: $config->{recursive}=1 if /r/i;
234: $config->{verbose}=1 if /v/;
235: $config->{help}=1 if /h/;
236: }
237: }
238: GetOptions($config,
239: #system calls:
240: "copy=s", "chmod=s", "date=s", "mkdir=s",
241: #settings:
242: "trashcan=s", "junk=s", "max_size=i", "max_age=f",
243: #standard rm options:
244: "interactive", "force", "recursive", "verbose", "help", "version",
245: #rmv commands:
246: "empty:s", "kill");
247: $config->{force}=1 unless -t STDIN; #don't interact if there's nothing to
248: # interact with.
249: $config->{interactive} = -1 if $config->{force};
250:
251: if ($config->{help}) {
252: $ENV{PAGER} ||= "more";
253: exec(qq(pod2man $0 | nroff -man | $ENV{PAGER})) or
254: exec(qq(perl -ne'{\$a++ if /^=pod/; \$a-- if /^=cut/; s/^=\\w+//; print if \$a;}' $0))
255: #now how exactly they managed to execute the program and didn't
256: #luck out on that second try, I don't know, but just in case...
257: or (print "couldn't print the help for some reason. sorry.\n"
258: and exit 0);
259:
260: }
261: if ($config->{version}) {
262: print "$0: version $Version\n";
263: use Data::Dumper;
264: print Data::Dumper->Dump([$config],["config"]);
265:
266: print "\n\nCopyright (C) 2000 Gregory Marton\n";
267: print "This is free software; see the source for copying conditions.\n";
268: print "There is NO warranty; not even for MERCHANTABILITY or \n";
269: print "FITNESS FOR A PARTICULAR PURPOSE.\n";
270: exit 0;
271: }
272:
273: #>
274:
275: #< find the current directory and date
276: use Cwd;
277: my $Curdir = cwd();
278: chomp $Curdir;
279: $Curdir =~ s|/$||;
280: $Curdir =~ s|.*/||;
281:
282: my $Date = qx($config->{date});
283: chomp $Date;
284: #>
285:
286: #< backup
287: sub target_name {
288: my ($target) = @_;
289: my $basedir = $target;
290: $basedir =~ s|^(.+)/.*|$1|;
291: my $newbasedir = $basedir;
292: $newbasedir =~ s/\W/_/gs;
293: $target =~ s|\Q$basedir\E|$newbasedir|;
294: $target = $config->{trashcan} ."/". $Date ."_". $Curdir ."_". $target;
295:
296: #now make sure the target's directory exists.
297: if ($target !~ m|/$|) {
298: $basedir = $target;
299: $basedir =~ s|/[^/]*$||;
300: print qq($config->{mkdir} $basedir\n) if $config->{verbose};
301: system(qq($config->{mkdir} $basedir));
302: }
303: return $target;
304: }
305: sub backup {
306: return 1 if $config->{kill};
307: die "$0: trash can [$config->{trashcan}] is not writeable.\n"
308: unless -w $config->{trashcan};
309: foreach my $entry (@_) {
310: next if $entry =~ $config->{junk};
311: next unless -l $entry or -f _ or -d _;
312: my $target = &target_name($entry);
313: print qq($config->{copy} "$entry" "$target"\n) if $config->{verbose};
314: system(qq($config->{copy} "$entry" "$target")) and
315: do {
316: warn "$0: cannot back up [$entry] to [$target]\n";
317: return 0;
318: };
319: }
320: return 1;
321: }
322: #>
323: #< empty
324: sub by_date {return (-M "$_[0]" > $config->{max_age});}
325: sub by_size {
326: $config->{done_count}||=2;
327: $config->{check_every}||=1;
328: return if $config->{check_every} < 0;
329: unless ($config->{done_count} % $config->{check_every}) {
330: #check again every 10 files.
331: my $size = qx(du -ks $config->{trashcan});
332: $size =~ s/\D//g;
333: print "size = $size\n";
334:
335: #check less often if we've more to do:
336: $config->{check_every} = ($size - $config->{max_size}) / 1024;
337: $config->{check_every} =~ s/\..*//;
338: print "will check again in $config->{check_every} files...\n";
339:
340: $config->{done_count} = -1 if $size < $config->{max_size};
341: }
342: return 0 if $config->{done_count} < 0;
343: return ++$config->{done_count};
344: }
345: #>
346: #< remove
347:
348: sub remove {
349: #this is basically an internal implementation of /bin/rm.
350: #it's faster to do it like this than to make a million system calls.
351: my $backup = shift @_;
352: foreach my $entry (@_) {
353: next unless -l $entry or -e $entry;
354: next if $entry =~ m|^(.*/)?\.\.?$|; #don't worry about specials.
355: print "trying to remove $entry\n" if $config->{verbose};
356: #< check writeable, maybe chmod.
357:
358: if (not -l $entry and not -w _) { #lstat needed, and ok for -w.
359: # warn "$0: [$entry] is not writeable.\n";
360: my $override=1;
361: if ($config->{interactive} > -1) {
362: print "$0: override write-protection for [$entry]? (Ny) ";
363: $override = <STDIN>;
364: $override = ($override =~ /[yY]/ and $override !~ /[nN]/);
365: }
366: next unless $override;
367: my $e = $entry;
368: $e =~ s/\"/\\\"/;
369: print qq($config->{chmod} +w "$entry"\n) if $config->{verbose};
370: system(qq($config->{chmod} +w "$entry"));
371: if (not -w $entry) { #need a new stat.
372: warn "$0: cannot change permissions for [$entry]: $!\n";
373: next;
374: }
375: }
376:
377: #>
378: if (-f $entry or -l $entry or not -d _) { # -l needs an lstat, not just a stat.
379: #< interact
380: if ($config->{interactive} == 1) {
381: print STDERR "remove [$entry]? (Ny) ";
382: my $ans = <STDIN>;
383: next unless $ans =~ /y/i and $ans !~ /n/i;
384: }
385: #>
386: &{$backup}($entry) or next;
387: print "unlink $entry\n" if $config->{verbose};
388: unlink $entry or warn "$0: cannot unlink [$entry]: $!\n";
389: } else {
390: $entry =~ s|/$||;
391: unless ($config->{recursive}) {
392: warn "$0: [$entry] is a directory.\n";
393: next;
394: }
395: #< interact
396: $config->{interactive}++ if $config->{interactive} > 1;
397: if ($config->{interactive} == 1) {
398: print STDERR "remove directory [$entry]? (Eny) ";
399: my $ans = <STDIN>;
400: next if $ans =~ /n/i;
401: $config->{interactive}++ if $ans =~ /y/i and $ans !~ /e/i;
402: }
403: #>
404: local *DIR;
405: opendir(DIR, $entry) or warn "$0: cannot open dir [$entry]: $!\n";
406: remove($backup, map {$_ = qq($entry/$_);} readdir(DIR));
407: closedir(DIR);
408: print "rmdir $entry\n" if $config->{verbose};
409: rmdir $entry;
410: $config->{interactive}-- if $config->{interactive} > 1;
411: }
412: }
413: }
414:
415: #>
416:
417: #< take out the trash
418: if (defined $config->{empty}) {
419: my $tmp_conf = { %$config };
420: $config->{recursive} = 1;
421: $config->{interactive} = -1;
422:
423: remove(sub {return $_[0] =~ m|$config->{clean_first}|},
424: $config->{trashcan}) if $config->{clean_first};
425:
426: my $method;
427: $method = sub{1} if $config->{empty} eq "all";
428: $method = \&by_size if $config->{empty} eq "by_size";
429: $method ||= \&by_date;
430: remove($method, $config->{trashcan});
431:
432: $config = $tmp_conf;
433: }
434: #>
435: #< make sure there's a trashcan
436:
437: if (! -d $config->{trashcan}) {
438: print qq($config->{mkdir} $config->{trashcan}\n) if $config->{verbose};
439: system(qq($config->{mkdir} $config->{trashcan})) and
440: die "$0: cannot make trash can at [$config->{trashcan}]: $!\n";
441: }
442:
443: #>
444:
445: my $method;
446: #< check for accidental rmv ~ instead of rmv *~ or something.
447: unless ($config->{interactive} < 0) {
448: if (grep /$Home/, @ARGV) {
449: print qq(Are you sure you want to remove your home directory? (Ny) );
450: my $answer = <STDIN>;
451: exit 0 unless $answer =~ /y/i and $answer !~ /n/i;
452: }
453: }
454: #>
455:
456: #< perform faster total backup beforehand if not interacting:
457: if ($config->{interactive} < 1) {
458: &backup(@ARGV) or
459: die "$0: You can use the --kill option to bypass backup.\n";
460: $method=sub{1};
461: } else {
462: # otherwise we'll need to back things up as we destroy them.
463: $method=\&backup;
464: }
465: #>
466:
467: remove($method, @ARGV);
468: @ARGV = ();
469: