Description: |
Delete all but "n" newest files of given filespec from specified directory. Accepts filesystem wildcards like * and ? as filespec arguments. The code line that actually unlinks files is commented out - uncomment once you're comfortable with how options and arguments operate. Tested with Perl 5.6.1 on Debian 3, Win2kPro, WinNT plus Perl 5.8.0 on Cygwin.
It's entirely possible that this might be done in fewer LOC using File::Find. Nonetheless, has been a good exercise/refresher for /me on stat, sort, cmp, regexen, and glob.
Thanks to the following monks for direction, clues, and answers to brain-mushing questions: Petruchio, jkahn, Undermine, Zaxo, theorbtwo, fever, BrowserUk, tye, belg4mit, PodMaster, and Mr. Muskrat. And to some guy named vroom.
Update: see pod UPDATES
Example syntax and output:
joe@host:~/rmdir$ prune.pl --dir=./ --filespec="*" --keepnum=5
Specified Files Retained:
keep5
rm6
keep6.txt
rm6.txt
keep6
Specified Files Pruned:
rm1
keep1.txt
keep1
rm1.txt
keep2
keep2.txt
rm2.txt
rm2
keep3.txt
rm3.txt
keep3
rm3
keep4.txt
rm4
keep4
rm4.txt
rm5
keep5.txt
rm5.txt
|
#!/usr/bin/perl -w
# prune.pl
# pod at tail
# allays stuff
use strict; # avoid D'oh! bugs
use Getopt::Long; # options & arguments
use Pod::Usage; # eliminate redundant Usage()
use File::Spec; # strip path from $0
use Sys::Hostname; # determine hostname of localhost
my $VERSION = '0.3.18';
$|++;
# program-specific stuff
use Net::SMTP; # email notification
# preliminaries
my $time = localtime(time);
my $host = hostname; # localhost
my $arg_keepnum = 3; # default value
my $arg_smtp = $host; # default value
my ($feh, $eep, $program) = File::Spec->splitpath( $0 );
push my @message, '#' x 40, "\n";
push @message, "$time\n";
# options and arguments
my ($arg_dir, $arg_filespec, @arg_recipients);
my ($opt_help, $opt_man, $opt_versions);
GetOptions(
'dir=s' => \$arg_dir,
'filespec=s' => \$arg_filespec,
'keepnum=i' => \$arg_keepnum,
'recipients=s' => \@arg_recipients,
'smtp=s' => \$arg_smtp,
'versions!' => \$opt_versions,
'help!' => \$opt_help,
'man!' => \$opt_man,
) or pod2usage(-verbose => 1) && exit;
pod2usage(-verbose => 1) && exit if $opt_help;
pod2usage(-verbose => 2) && exit if $opt_man;
pod2usage(-verbose => 1) && exit unless $arg_dir && $arg_filespec;
# read specified directory for specified filespec
chdir $arg_dir or die "Error chdir to $arg_dir: $!";
my @files = grep -f $_, glob($arg_filespec);
# nominal validation of input
my $filenum = scalar(@files);
$arg_keepnum = $filenum if $arg_keepnum > $filenum;
unless($filenum){
push @message," No files found matching regex $arg_filespec\n\n";
exit;
}
# sort by timestamp, oldest first
my %file;
$file{$_} = (stat($_))[9] for(@files);
my @filesOldFirst = sort { $file{$a} <=> $file{$b} } keys %file;
# delete all but newest n specified files
my @allButNewestN = @filesOldFirst[0 .. $filenum-$arg_keepnum-1];
unlink or warn "Error unlinking $_ : $!" for @allButNewestN;
# report on specified files retained and purged
my @newestN = @filesOldFirst[$filenum-$arg_keepnum..$filenum-1];
my $allButNewestN = scalar(@allButNewestN);
push @message, " Specified Files Retained:\n";
push @message, " $_\n" for @newestN;
push @message, " Specified Files Pruned:\n";
push @message, " $_\n" for @allButNewestN;
END{
# report on versions n'such
if(defined $opt_versions){
my @versions = (
" Modules, Perl, OS, Program info:\n",
" Net::SMTP $Net::SMTP::VERSION\n",
" Sys::Hostname $Sys::Hostname::VERSION\n",
" Getopt::Long $Getopt::Long::VERSION\n",
" Pod::Usage $Pod::Usage::VERSION\n",
" strict $strict::VERSION\n",
" Perl $]\n",
" OS $^O\n",
" $program $VERSION\n",
" localhost $host\n",
);
push @message, @versions;
}
# merge messages
my $message = join('', @message);
print $message unless $opt_help or $opt_man;
# email notification o'results
if(@arg_recipients){
my $autoMsg =
"Message automatically generated by $program program and sent to
+:";
my $recipListMsg = join("\n ", @arg_recipients);
for my $recipient(@arg_recipients){
print "Sending message to $recipient... ";
if(my $smtp = new Net::SMTP($arg_smtp)){
$smtp->mail("$program\@$host");
$smtp->to($recipient);
$smtp->data();
$smtp->datasend("To: $recipient\n");
$smtp->datasend("Subject: $program - $host \n");
$smtp->datasend("\n");
$smtp->datasend("\n$autoMsg\n $recipListMsg\n\n$message\n");
$smtp->dataend();
$smtp->quit();
print "successful";
}
}
}
}
=head1 NAME
prune.pl - unlink all but $arg_keepnum newest $filespec in $arg_dir
=head1 SYNOPSIS
prune.pl -d ~/temp -f "foo*.???"
prune.pl -d c:\drtemp\deleteme -k 2 -f ?delme.txt -v >> c:\winatlogs\
+prune.log && df -hT c: d:
prune.pl --dir = ~/temp --filespec = "foo*.???"
--keepnum = 7
--recipients = FOO
--smtp = host.domain
--version
--help
--man
=head1 OPTIONS AND ARGUMENTS
=head2 MANDATORY ARGUMENTS
dir directory to prune old files from
absolute or relative
filespec filename sans path - wildcards like * and ? are valid
doublequotes needed for *nix bash if wildcard(s)
doublequotes optional for win32 command.com and cmd.exe
=head2 OPTIONAL ARGUMENTS
keepnum number of newest files to retain (default 3)
recipients email address to send results to
smtp nearest mailserver (default localhost)
=head2 OPTIONAL OPTIONS
versions print Perl, module, and program versions to screen
help print brief usage message to screen
man print full contents of program pod to screen
=head1 DESCRIPTION
Prune old files of specified name/extension from a given directory.
Intended to run periodically from *nix cron or win32 at.
Entirely possible this could be done in fewer LOC using File::Find.
Nonetheless, a good refresher for /me on stat, sort, cmp, regexen, an
+d glob
The line of code that actually unlinks files is commented out.
Uncomment after you're comfortable with how options and arguments wor
+k.
=head1 WIN32 NOTES
assoc .pl=Perl
ftype Perl=c:\perl\bin\perl.exe "%1" %*
pathext=.pl;
path=c:\perl\bin\;
Login as administrator
control panel, scheduler, runas specific_user
at 06:00 /every:Th c:\perl\bin\perl.exe c:\perls\prune.pl -d c:\foo -
+f bar?*.??? -r user@host.dom -v
pl2bat prune.pl
=head1 SMTP NOTES
telnet mailserver.dom.tld 25
220 mailserver.dom.tld ESMTP
helo client.dom.tld
250 OK
mail from: user1@dom.tld
250 Sender OK
rcpt to: user2@dom.tld
250 Recipient OK
testing, testing, 1... 2... 3
.
250 Message accepted for deliver
quit
221 mailserver.dom.tld closing connection
=head1 SEE ALSO
Perl(1)
Pod::Usage(3perl)
Sys::Hostname(3perl)
File::Spec(3perl)
Getopt::Long(3)
Net::SMTP(3)
=head1 TESTED
Net::SMTP 2.19 2.24 2.16, 2.24
Sys::Hostname 1.1 1.1 1.1
Getopt::Long 2.32 2.25 2.25
Pod::Usage 1.14 1.14 1.14
strict 1.01 1.01 1.01, 1.02
Perl 5.006001 5.006001 5.006001, 5.008
OS Debian 3.0 Win(2k|NT4) Cygwin
=head1 UPDATES
2003-02-21 19:20 CST
chdir to target directory (fixes substantial bug)
tweak output for legability
error handling to chdir
2002-11-27 12:25 CST
Add Win32, SMTP notes to pod
Test with Perl 5.8.0 Cygwin on Win2kPro
Post to PerlMonks Code Catacombs Utility Scripts
glob() for filesystem wildcards (foo*.???) instead of perl regex
Summarize PCRE for --man
Sanity check for $numKeep =< $filenum
Test with ActivePerl on WinNT, Win2kPro
Email results - id://181972
Ponder globbing, to allow non-regex user input of filespec
Sys::Hostname for localhost name
Email notification of results
Getopt::Long;
Pod::Usage;
2002-11-24 22:25 CST
Initial working code
=head1 TODO
Debug no '--help' output on Cygwin
Test err on unlink if insufficient perms
Taint-check user-supplied params
Eliminate all but newest(?) of duplicate files before pruning
use File::Same;
my @fileDups = File::Same::scan_dir($_, $arg_dir);
AppConfig instead of Getopt::Long(?)
config file support in addition to commandline args/options
=head1 CREDITS
Thanks to:
Petruchio, jkahn, Undermine for allButLastN direction,
Zaxo, theorbtwo, fever, BrowserUk for precedence tips,
tye, bel4mit, PodMaster for glob direction,
Mr. Muskrat for shell escape diffs cmd.exe to bash,
And to some guy named vroom.
=head1 AUTHOR
ybiC
=cut
|