File Coverage

blib/lib/Tie/Cache/Autoupdater.pm

Criterion	Covered	Total	%
statement	33	52	63.4
branch	14	18	77.7
condition	4	7	57.1
subroutine	8	16	50.0
pod			n/a
total	59	93	63.4

package Tie::Cache::Autoupdater;

use strict;
use warnings;

use Storable 'dclone';

BEGIN {
    eval { require Time::HiRes; };
    Time::HiRes->import('time') unless $@;
}

our $VERSION = 0.21;

sub TIEHASH {
    my $class       = shift;
    my %structure   = @_;

    my $self = {};
    while ( my ($k, $v) = each %structure ) {
        $self->{ $k } = {
            timeout => $v->{timeout} || 1,
            source  => $v->{source},
            last    => 0,
            result  => undef,
            clone   => $v->{clone} ? 1 : 0
        }
    }

    bless $self, $class;
}

sub FETCH {
    my ( $self, $k ) = @_;

    return undef unless exists $self->{ $k };
    _fetch( $_[0], $k )
}

sub STORE {
    my ( $self, $k, $v ) = @_;
    $self->{ $k } = {
        timeout => $v->{timeout} || 1,
        source  => $v->{source},
        last    => 0,
        result  => undef,
        clone   => $v->{clone} ? 1 : 0
    }
}

sub FIRSTKEY {
    keys %{$_[0]};
    my ( $k, $v ) = each %{$_[0]};
    _fetch( $_[0], $k )
}

sub NEXTKEY  {
    my ( $k, $v ) = each %{$_[0]};
    _fetch( $_[0], $k )
}

sub EXISTS   { exists $_[0]->{ $_[1] } }
sub DELETE   { delete $_[0]->{ $_[1] } }
sub CLEAR    { %{ $_[0] } = () }
sub SCALAR   { scalar %{ $_[0] } }
sub UNTIE    { $_[0] = undef }
sub DESTROY  { }

sub _fetch {
    my ( $self, $k ) = @_;

    if ( $self->{$k}{last} + $self->{$k}{timeout} < time() ) {

        my @result = eval { $self->{$k}{source}->() };
        if ( $@ ) {
            warn qq/Check source subroutine for key $k. Error - $@\n/;
            return undef
        }

        if ( @result == 1 ) {
            $self->{$k}{result} = $result[0];
        } elsif ( !@result ) {
            $self->{$k}{result} = undef;
        } else {
            $self->{$k}{result} = \@result;
        }

        $self->{$k}{last} = time();
    }

    return $self->{$k}{clone} && ref $self->{$k}{result}
        ? dclone($self->{$k}{result})
        : $self->{$k}{result};
}

1;

__END__