Dir::Purge - Purge directories to a given number of files.

  perl -MDir::Purge -e 'purgedir (5, @ARGV)' /spare/backups

  use Dir::Purge;
  purgedir ({keep => 5, strategy => "by_age", verbose => 1}, "/spare/backups");

  use Dir::Purge qw(purgedir_by_age);
  purgedir_by_age (5, "/spare/backups");

  purgedir ({keep => 3, test => 1}, "/spare/backups");
  purgedir_by_age ({keep => 3, test => 1}, "/spare/backups");
  purgedir ({strategy => "by_age", keep => 3, test => 1}, "/spare/backups");

# Dir::Purge.pm -- Purge directories
# RCS Info        : $Id: Purge.pm,v 1.6 2006/09/19 12:24:01 jv Exp $
# Author          : Johan Vromans
# Created On      : Wed May 17 12:58:02 2000
# Last Modified By: Johan Vromans
# Last Modified On: Tue Sep 19 14:23:56 2006
# Update Count    : 161
# Status          : Unknown, Use with caution!

# Purge directories by strategy.
#
# This is also an exercise in weird programming techniques.

package Dir::Purge;

use strict;
use Carp;

use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
$VERSION    = "1.02";
@ISA        = qw(Exporter);
@EXPORT     = qw(&purgedir);
@EXPORT_OK  = qw(&purgedir_by_age);

my $purge_by_age;		# strategy

sub purgedir_by_age {
    my @dirs = @_;
    my $opts;
    if ( UNIVERSAL::isa ($dirs[0], 'HASH') ) {
	$opts = shift (@dirs);
	my $strat = delete $opts->{strategy};
	if ( defined $strat && $strat ne "by_age" ) {
	    croak ("Invalid option: 'strategy'");
	}
	$opts->{strategy} = "by_age";
    }
    else {
	$opts = { keep => shift(@dirs), strategy => "by_age" };
    }
    purgedir ($opts, @dirs);
}


# Common processing code. It verifies the arguments, directories and
# calls $code->(...) to do the actual purging.
# Nothing is done if any of the verifications fail.

sub purgedir {

    my (@dirs) = @_;
    my $error = 0;
    my $code = $purge_by_age;	# default: by age
    my $ctl = { tag => "purgedir" };
    my @opts = qw(keep strategy reverse include verbose test debug);

    # Get the parameters. Only the 'keep' value is mandatory.
    if ( UNIVERSAL::isa ($dirs[0], 'HASH') ) {
	my $opts  = shift (@dirs);
	@{$ctl}{@opts} = delete @{$opts}{@opts};
	if ( $ctl->{strategy} ) {
	    if ( $ctl->{strategy} eq "by_age" ) {
		$code = $purge_by_age;
	    }
	    else {
		carp ("Unsupported purge strategy: '$ctl->{strategy}'");
		$error++;
	    }
	}
	foreach (sort keys %$opts) {
	    carp ("Unhandled option \"$_\"");
	    $error++;
	}
    }
    elsif ( $dirs[0] =~ /^-?\d+$/ ) {
	$ctl->{keep} = shift (@dirs);
    }

    unless ( $ctl->{keep} ) {
	croak ("Missing 'keep' value");
    }
    elsif ( $ctl->{keep} < 0 ) {
	# Hmm. I would like to deprecate this, but on the other hand,
	# a negative 'subscript' fits well in Perl.
	#carp ("Negative 'keep' value is deprecated, ".
	#      "use 'reverse => 1' instead");
	$ctl->{keep} = -$ctl->{keep};
	$ctl->{reverse} = !$ctl->{reverse};
    }

    $ctl->{verbose} = 1 unless defined ($ctl->{verbose});
    $ctl->{verbose} = 9 if $ctl->{debug};

    if ( $ctl->{include} ) {
	if ( !ref($ctl->{include}) ) {
	    croak("Invalid value for 'include': " . $ctl->{include});
	}
	elsif ( UNIVERSAL::isa($ctl->{include}, 'CODE') ) {
	    # OK
	}
	elsif ( UNIVERSAL::isa($ctl->{include}, 'Regexp') ) {
	    my $pat = $ctl->{include};
	    $ctl->{include} = sub { $_[0] =~ $pat };
	}
	else {
	    croak("Invalid value for 'include': " . $ctl->{include});
	}
    }

    # Thouroughly check the directories, and refuse to do anything
    # in case of problems.
    warn ("$ctl->{tag}: checking directories\n") if $ctl->{verbose} > 1;
    foreach my $dir ( @dirs ) {
	# Must be a directory.
	unless ( -d $dir ) {
	    carp (-e _ ? "$dir: not a directory" : "$dir: not existing");
	    $error++;
	    next;
	}
	# We need write access since we are going to delete files.
	unless ( -w _ ) {
	    carp ("$dir: no write access");
	    $error++;
	}
	# We need read access since we are going to get the file list.
	unless ( -r _ ) {
	    carp ("$dir: no read access");
	    $error++;
	}
	# Probably need this as well, don't know.
	unless ( -x _ ) {
	    carp ("$dir: no access");
	    $error++;
	}
    }

    # If errors, bail out unless testing.
    if ( $error ) {
	if ( $ctl->{test} ) {
	    carp ("$ctl->{tag}: errors detected, continuing");
	}
	else {
	    croak ("$ctl->{tag}: errors detected, nothing done");
	}
    }

    # Process the directories.
    foreach my $dir ( @dirs ) {
	$code->($ctl, $dir);
    }
};

# Everything else is assumed to be small building-block routines to
# implement a plethora of purge strategies.
# Actually, I cannot think of any right now.

# Gather file names and additional info.
my $gather = sub {
    my ($ctl, $dir, $what) = @_;

    local (*DIR);
    opendir (DIR, $dir)
      or croak ("dir: $!");	# shouldn't happen -- we've checked!
    my @files;
    foreach ( readdir (DIR) ) {
	next if $ctl->{include} && !$ctl->{include}->($_, $dir);
	next if /^\./;
	next unless -f "$dir/$_";
	push (@files, [ "$dir/$_", $what->("$dir/$_") ]);
    }
    closedir (DIR);

    warn ("$ctl->{tag}: $dir: ", scalar(@files), " files\n")
      if $ctl->{verbose} > 1;
    warn ("$ctl->{tag}: $dir: @{[map { $_->[0] } @files]}\n")
      if $ctl->{debug};

    \@files;
};

# Sort the list on the supplied info.
my $sort = sub {
    my ($ctl, $files) = @_;

    my @sorted = map { $_->[0] } sort { $a->[1] <=> $b->[1] } @$files;
    warn ("$ctl->{tag}: sorted: @sorted\n") if $ctl->{debug};
    \@sorted;
};

# Remove the files to keep from the list.
my $reduce = sub {
    my ($ctl, $files) = @_;

    if ( $ctl->{reverse} ) {
	# Keep the newest files (tail of the list).
	splice (@$files, @$files-$ctl->{keep}, $ctl->{keep});
    }
    else {
	# Keep the oldest files (head of the list).
	splice (@$files, 0, $ctl->{keep});
    }
    $files;
};

# Remove the files in the list.
my $purge = sub {
    my ($ctl, $files) = @_;

    # Remove the selected files.
    foreach ( @$files ) {
	if ( $ctl->{test} ) {
	    warn ("$ctl->{tag}: candidate: $_\n");
	}
	else {
	    warn ("$ctl->{tag}: removing $_\n") if $ctl->{verbose};
	    unlink ($_) or carp ("$_: $!");
	}
    }
};

# Processing routine: purge by file age.
$purge_by_age = sub {
    my ($ctl, $dir) = @_;

    warn ("$ctl->{tag}: purging directory $dir (by age, keep $ctl->{keep})\n")
      if $ctl->{verbose} > 1;

    # Gather, with age info.
    my $files = $gather->($ctl, $dir, sub { -M _ });

    # Is there anything to do?
    if ( @$files <= $ctl->{keep} ) {
	warn ("$ctl->{tag}: $dir: below limit\n") if $ctl->{verbose} > 1;
	return;
    }

    # Sort, reduce and purge.
    $purge->($ctl, $reduce->($ctl, $sort->($ctl, $files)));
};

1;

__END__