File Coverage

blib/lib/Cache/Meh.pm

Criterion	Covered	Total	%
statement	84	89	94.3
branch	31	40	77.5
condition	2	3	66.6
subroutine	16	16	100.0
pod	7	7	100.0
total	140	155	90.3

use strict;
use warnings;
package Cache::Meh;
$Cache::Meh::VERSION = '0.04';
use Carp qw(confess);
use Storable qw(nstore retrieve);
use File::Spec::Functions qw(tmpdir catfile);
use File::Temp qw(tempfile);
use File::Copy qw(move);

# ABSTRACT: A cache of indifferent quality


sub filename {
    my ($self, $f) = @_;

    if ( defined $f ) {
        $self->{filename} = $f;
    }

    return $self->{filename};
}


sub only_memory {
    my ($self, $m) = @_;

    if ( defined $m ) {
        $self->{only_memory} = $m;
    }

    return $self->{only_memory};
}


sub validity {
    my $self = shift;
    my $validity = shift;

    if ( defined $validity ) {
        if ( $validity > 0 ) {
            $self->{validity} = int($validity);
        }
        else {
            confess "$validity is not a positive integer\n";
        }
    }

    return $self->{validity};
}


sub lookup {
    my $self = shift;
    my $coderef = shift;

    if ( ref($coderef) ne "CODE" ) {
        return $self->{lookup};
    }
    else {
        $self->{lookup} = $coderef;
    }

    return $self->{lookup};
}


sub new {
    my $class = shift;
    my %args = @_;

    my $self = {};

    bless $self, $class;

    if ( exists $args{only_memory} ) {
        $self->only_memory($args{only_memory});
    }
    elsif ( exists $args{filename} ) {
        $self->filename($args{filename});
    }
    else {
        confess "You must give a filename or set only_memory";
    }


    $self->{'~~~~cache'} = $self->_load();

    if ( exists $args{validity} ) {
        $self->validity($args{validity});
    }
    else {
        $self->validity(300);
    }

    $self->lookup($args{lookup}) if exists $args{lookup};

    return $self;
}

sub _load {
    my $self = shift;

    return {} if $self->only_memory();

    my $fname = catfile(tmpdir(), $self->filename());

    if ( -e $fname ) {
        if ( -r $fname ) {
            return retrieve($fname);
        }
        else {
            confess "$fname exists but is not readable.\n";
        }
    }

    return {};
}

# This method stores the new cache file into a temporary file, then renames the
# tempfile to the cache state file name, which should help protect against
# new file write failures, leaving at least *some* state that will persist. I
# guess you could call this "atomic" but there are still a ton of race
# conditions in the IO layer which could bite you in the rear-end.

sub _store {
    my $self = shift;

    return 1 if $self->only_memory();

    my ($fh, $filename) = tempfile();

    nstore($self->{'~~~~cache'}, $filename) or
        confess "Couldn't store cache in $filename: $!\n";

    # Unix doesn't care if the filehandle is still open, but Windows
    # will not allow a move unless there are no open handles to the
    # tempfile.
    close $fh or confess "Couldn't close filehandle for $filename: $!\n";

    my $fname = catfile(tmpdir(), $self->filename());
    move($filename, $fname) or
        confess "Couldn't rename $filename to $fname: $!\n";

    return 1;
}


sub get {
    my ($self, $key) = @_;

    if ( exists $self->{'~~~~cache'}->{$key} ) {
        my $i = $self->{'~~~~cache'}->{$key}->{'insert_time'} + $self->validity;
        return $self->{'~~~~cache'}->{$key}->{'value'} if ( time < $i ) ;
    }

    if ( exists $self->{lookup} && ref($self->{lookup}) eq 'CODE' ) {
        my $value = $self->{lookup}->($key);
        $self->set( $key, $value );
        return $value;
    }

    if ( exists $self->{'~~~~cache'}->{$key} ) {
        delete $self->{'~~~~cache'}->{$key};
        $self->_store();
    }

    return undef;
}


sub set {
    my ($self, $key, $value) = @_;

    $self->{'~~~~cache'}->{$key}->{'value'} = $value;
    $self->{'~~~~cache'}->{$key}->{'insert_time'} = time;

    $self->_store();

    return $self;
}

1;

__END__