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