File Coverage

lib/Mail/Action/Role/Purge.pm

Criterion	Covered	Total	%
statement	50	53	94.3
branch	12	18	66.6
condition	5	5	100.0
subroutine	11	11	100.0
pod	4	4	100.0
total	82	91	90.1

=head1 NAME

Mail::Action::Role::Purge - purge expired objects from Mail::Action::Storage
collections.

=head1 SYNOPSIS

 use Mail::TempAddress::Addresses;
 use Mail::Action::Role::Purge;
 use Class::Roles
    apply => {
        role => 'Purge',
        to   => 'Mail::TempAddress::Addresses',
    };
 my $addrs = Mail::TempAddress::Addresses->new( '/foo' );
 for my $addr( $addrs->object_names ) {
     print "the address for ", $addr->owner, " expires at ",
           scalar localtime($addr->expires), "\n";
     if( $addr->expires < time() ) {
         $addrs->delete_from_storage($addr);
     }
 }

=head1 DESCRIPTION

Mail::Action::Role::Purge provides a role to allow subclasses of
Mail::Action::Storage to retrieve the names of all object in the collection
and remove the file on disk underlying a named object.

=cut

package Mail::Action::Role::Purge;

use strict;
use Carp 'croak';

use Mail::Action::Storage;
use Class::Roles
    multi => {
        'Purge' => [ qw|
            object_names
            num_objects
            delete_from_storage
            purge
        |],
    };

use vars '$VERSION';

$VERSION = '0.11';

use File::Basename;
use Fcntl ':flock';

sub object_names
{

    my $self = shift;
    my $dir = $self->storage_dir;
    my $extension = $self->storage_extension();
    my @files = map {
        scalar( s/\.$extension//, basename $_)
    } glob("$dir/*.$extension");
    return wantarray ? @files : \@files;

}

sub num_objects
{

    my $self = shift;
    return scalar @{ $self->object_names } || 0;

}

sub delete_from_storage
{

    my $self = shift;
    my $name = shift;
    my $file = $self->storage_file($name);
    unless( $file ) {
        $! = "no object by that name";
        return undef;
    }
    open( OUT, '+< ' . $file ) or croak "cannot open $file: $!";
    flock OUT, LOCK_EX or croak "cannot lock $file: $!";
    unlink($file) && return 1;
    return undef;

}

sub purge
{

    my $self = shift;

    my $min_ts;
    if( my $min_age = shift  ) {
        my $subtract = Mail::Action::Address->process_time( $min_age );
        $min_ts = time() - $subtract;
    }
    else {
        $min_ts = time();
    }

    my $purged = 0;
    for( $self->object_names ) {
        my $addy = $self->fetch($_);
        next unless $addy;
        my $expires = $addy->expires();
        if( $expires && $expires < $min_ts ) {
            $self->delete_from_storage($_) && $purged++;
        }
    }

    return $purged;

}

# keep require happy
1;


__END__