Jocqui has asked for the wisdom of the Perl Monks concerning the following question:

I have a list of files in teh following format and i wish to delete all files that are older than the latest .bac file not including the file with the same name as the .bac file or any other .bac files. A sample of teh files are bellow. I wish to dleet everything apart from 000000010000000300000067.00000020.bac ,000000010000000300000067 and files created after 000000010000000300000067.00000020.bac .Any ideas how to do this in perl 

rw-------  1 postgres postgres 16777216 Jul 16 22:56 00000001000000030
+000005B
-rw-------  1 postgres postgres 16777216 Jul 16 22:59 0000000100000003
+0000005C
-rw-------  1 postgres postgres 16777216 Jul 16 23:01 0000000100000003
+0000005D
-rw-------  1 postgres postgres 16777216 Jul 16 23:04 0000000100000003
+0000005E
-rw-------  1 postgres postgres 16777216 Jul 16 23:06 0000000100000003
+0000005F
-rw-------  1 postgres postgres 16777216 Jul 16 23:09 0000000100000003
+00000060
-rw-------  1 postgres postgres 16777216 Jul 16 23:12 0000000100000003
+00000061
-rw-------  1 postgres postgres 16777216 Jul 16 23:14 0000000100000003
+00000062
-rw-------  1 postgres postgres 16777216 Jul 16 23:17 0000000100000003
+00000063
-rw-------  1 postgres postgres 16777216 Jul 16 23:20 0000000100000003
+00000064
-rw-------  1 postgres postgres 16777216 Jul 16 23:23 0000000100000003
+00000065
-rw-------  1 postgres postgres 16777216 Jul 16 23:25 0000000100000003
+00000066
-rw-------  1 postgres postgres 16777216 Jul 16 23:26 0000000100000003
+00000067
-rw-------  1 postgres postgres      285 Jul 16 23:26 0000000100000003
+00000067.00000020.bac
-rw-------  1 postgres postgres 16777216 Jul 16 23:27 0000000100000003
+00000068
-rw-------  1 postgres postgres 16777216 Jul 16 23:30 0000000100000003
+00000069

[download]

Replies are listed 'Best First'.
Re: removing files with perl based on age and name
by graff (Chancellor) on Jul 19, 2014 at 00:19 UTC
    Here's how I would do it: 
    #!/usr/bin/perl
use strict;
use warnings;

die "Usage: $0 directory_path\n" unless ( @ARGV == 1 and -d $ARGV[0] )
+;
my $target_dir = shift;
chdir $target_dir or die "chdir $target_dir: $!\n";

opendir( my $dir, "." );
my %files = map { $_ => -M } grep /\w/, readdir( $dir );
my @bacs = sort { $files{$a} <=> $files{$b} } grep /\.bac$/, keys %fil
+es;
@bacs or die "No *.bac file found in $target_dir - nothing to do\n";

my $latest_bac_age = $files{$bacs[0]};
( my $latest_bac_id = $bacs[0] ) =~ s/^(\w+).*/$1/;
warn "latest bac file in $target_dir is $bacs[0]\n";

for my $f ( keys %files ) {
    my $result = "kept";
    if ( $files{$f} > $latest_bac_age and $f !~ /^$latest_bac_id/ and 
+-f $f ) {
        unlink $f and $result = "deleted";
    }
    warn "$result $f\n";
}

    [download]
    You can skip the "warn" outputs if you like, but for this sort of thing, I think it's nice to keep a log of what actually happens on a given run.

    Updated the script to include the two "… or die …" conditions -- I should have had those in there from the beginning. Also updated the logic in the for loop: added the "-f $f" condition to the "if" statement (no point trying to unlink sub-directories), and only report "deleted" if the deletion actually succeeds.

[reply]
[d/l]
Re: removing files with perl
by Anonymous Monk on Jul 18, 2014 at 09:26 UTC
[reply]
Re: removing files with perl based on age and name
by Anonymous Monk on Jul 19, 2014 at 15:40 UTC
    The logrotate utility in Unix/Linux can already do a lot of these chores . . .
[reply]
      How?
[reply]
Re: removing files with perl based on age and name
by gurpreetsingh13 (Scribe) on Jul 18, 2014 at 10:54 UTC
    From what I can understand from your post, you need a bac file and its creation date.
    Next you need to delete all the files which are older than that bac file and those whose names do not match with that bac file.

    So try this code if it works for you.

    Pass bac file name as an argument.

    Example:
    perl test.pl 000000010000000300000067.00000020.bac
    use v5.14;

my $bacFileName = $ARGV[0];

#First get the epoch creation time of bac file
my $bacFileTime = `stat $bacFileName --format=%W`;

foreach my $fileName (`ls`) {
    chomp($fileName);
    next if $fileName eq $bacFileName;
    my $bacTypeFileName = ( ( split /\./, $bacFileName )[0] );
    next if $fileName =~ /$bacTypeFileName/;
    my $fileCreationTime = `stat $fileName --format=%W`;
    next if $fileCreationTime > $bacFileTime;
    `rm -rf $fileName`;
}

    [download]
[reply]
[d/l]

      Why shell out to stat instead of using the builtin? Why the -r and -f on the rm when you are only deleting one file at a time? Why use backticks for the rm? Why shell out to rm at all when we have unlink?

      As it stands your script looks a bit too dangerous to consider running, sorry.

[reply]
      A reply falls below the community's threshold of quality. You may see it by logging in.

Back to Seekers of Perl Wisdom