May 2009 Archives

Here is a script that deletes old files.  In the Unix environment this is an easy job for a one line script using find.  This Perl version has the -test option, to allow you to see what will happen, and prints some totals.

#!/usr/bin/perl

# delold.pl - delete old files

#-----------------------------------------------------------
# 05/24/2009  WR  Written
#-----------------------------------------------------------

use strict;
use warnings;
use Win32::Autoglob;
use Getopt::Long;

$| = 1;

sub print_usage;
sub abort_usage;

# option defaults
my $days_back    = 10;
my $test_flag    = 0;
my $verbose_flag = 0;
my $quiet_flag   = 0;

# get options
GetOptions (
    'days=i'  => \$days_back,
    'test'    => \$test_flag,
    'verbose' => \$verbose_flag,
    'quiet'   => \$quiet_flag,
    'usage'   => sub {print_usage; exit 1},
) or abort_usage "Invalid option";

my $time = time();

my $files_to_delete = 0;
my $files_total     = 0;
my $files_failed    = 0;

FILE:
for my $file (@ARGV) {

    # must exist, must be a plain old file
    next FILE if !-e $file;
    next FILE if !-f $file;

    $files_total++;

    # modified age in days
    my ($mtime) = (stat($file))[9];
    my $modified_age = ($time - $mtime) / (3600 * 24);

    # skip if too young
    next FILE if $modified_age < $days_back;
    
    $files_to_delete++;

    if ($test_flag || $verbose_flag) {
        printf "Age: %-6.1f  File: %s\n",
            $modified_age,
            $file;
    }

    # skip if we are testing
    next FILE if $test_flag;

    # delete the file
    if (!unlink $file) {
        warn "Failed to delete file $file\n";
        $files_failed++;
    }

}

if ($test_flag) {
    print "\nTest Flag is set, no deletes done!\n";
}

my $files_remaining = $files_total - $files_to_delete + $files_failed;

if (!$quiet_flag || $test_flag) {
    print "\n";
    print "Total files:      $files_total\n";
    print "Files to delete:  $files_to_delete\n";
    print "Failed to delete: $files_failed\n";
    print "Files remaining:  $files_remaining\n";
}

exit 1;

sub abort_usage {
    print STDERR join("\n", @_), "\n" if @_;
    print_usage;
    exit 0;
}

sub print_usage {
    print STDERR <<END;
Usage: delold.pl [Options] files...
Options:
    --days n      - Set age of files to keep.
                    Files over "days" old will be deleted.
                    Default is 10 days.
    --test        - Print file names to be deleted with age,
                    but do not actually delete.
                    Default is false.
    --verbose     - Print file name and age while deleting.
                    Default is false.
    --quiet       - Suppress printing of totals after deleting.
                    Default is false.
    --usage       - print this message and exit
END
}

The Perl community is making an effort to improve visibility.  I added "Perl programming" to the top of the blog in support of this effort.