Khairul Azmi wrote:
>
> On 6/23/06, John Ackley <[EMAIL PROTECTED]> wrote:
>>
>> Khairul Azmi wrote:
>> > I have this problem. There is a script that stores log files into
>> > folders that follows structure of the following
>> >
>> > YYYY/MM/DD
>> >
>> > eg..
>> >
>> > /var/log/projects/2006/06/20/8231.tgz
>> > /var/log/project1/2006/06/21/1432.tgz
>> > /var/log/projects/2006/06/22/1756.tgz
>> > /var/log/projects/2006/06/23/1756.tgz
>> >
>> > Now I want to write a script that would erase all logs that has been
>> > stored except for the log for the current day. For the above example,
>> > since today is 23 June 2006, the code will erase log files in
>> > folders 2006/06/20/ and 2006/06/21/ only. Can somebody give ideas on
>> > how to do this. This script is to be ran once a day.
>>
>> #! /usr/bin/perl
>> use strict;
>> use warnings;
>> use Date::Manip;
>>
>> my $directory;
>> my $days = 2;
>> while( -d
>> ($directory =
>> UnixDate(DateCalc('today',"$days ago"),
>> '/var/log/projects/%Y/%m/%d')) ) {
>> unlink "$directory/*";
>> $days++;
>> }
>
> Thanks for the code. However it does not works as expected. My testing
> shows that the program will only unlink folders if the structure name
> of the folders falls exactly on the range.
>
> Say today is 16 August 2006. If I have only have this folder
>
> /var/log/project1/2006/08/08/8231.tgz
>
> The program does not works, unless I change the variable $days exactly
> to 8. What I need is a program that could unlink all folders except
> for today's.
use File::Basename;
use POSIX 'strftime';
my $root = '/var/log/projects';
my $today = strftime '%Y/%m/%d', localtime;
my @files = grep !m!^$root/$today!,
glob "$root/[0-9][0-9][0-9][0-9]/[0-9][0-9]/[0-9][0-9]/*.tgz";
for my $file ( @files ) {
unlink $file or warn "Cannot unlink '$file' $!";
for ( 1 .. 3 ) {
my $dir = dirname $file;
rmdir $dir; # ignore errors!
}
}
John
--
use Perl;
program
fulfillment
--
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
<http://learn.perl.org/> <http://learn.perl.org/first-response>
