#!/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
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.