File Coverage

blib/lib/Tie/CacheRedisDB.pm

Criterion	Covered	Total	%
statement	17	62	27.4
branch	0	8	0.0
condition	0	11	0.0
subroutine	6	20	30.0
pod	0	2	0.0
total	23	103	22.3

package Tie::CacheRedisDB;

use strict;
use warnings;
use 5.010;
our $VERSION = '1.0.1';

use Carp qw(croak);
use Scalar::Util qw(reftype);
use Cache::RedisDB;

sub TIEHASH {
    my ($self, $addr, $args) = @_;

    # Don't want to be crazy strict, but at least something which implies they know how this works.
    my $whatsit = reftype $args;

    croak 'Must supply a lookup element' unless defined $addr;
    croak 'Arguments must be supplied as a hash reference.'
      unless (not defined $whatsit)
      or (($whatsit // '') eq 'HASH');

    my $where = [$args->{namespace} // "TIECACHEREDISDB", $addr];

    my $node = {
        EXP_SECONDS  => $args->{expiry},
        CAN_MISS     => $args->{can_miss} // 2,
        DIRTY        => 0,
        DEL_ON_UNTIE => 0,
        WHERE        => $where,
        DATA         => Cache::RedisDB->get(@$where) // {},
    };

    return bless $node, $self;
}

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

    return $self->{DATA}->{$key};
}

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

    $self->{DATA}->{$key} = $val;
    return $self->_check_dirty;
}

sub _check_dirty {
    my $self = shift;

    $self->{DIRTY} += 1;
    $self->sync
      if ($self->{DIRTY} > $self->{CAN_MISS});   # Need to hit the backing store

    return;
}

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

    my $val = delete $self->{DATA}->{$key};
    $self->_check_dirty;

    return $val;
}

sub CLEAR {
    my $self = shift;

    $self->{DATA} = {};
    return $self->sync;

}

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

    return exists $self->{DATA}->{$key};
}

sub FIRSTKEY {
    my $self = shift;

    return each %{$self->{DATA}};
}

sub NEXTKEY {
    my $self = shift;

    return each %{$self->{DATA}};
}

sub SCALAR {
    my $self = shift;

    return scalar %{$self->{DATA}};
}

sub UNTIE {
    my $self = shift;

    return ($self->{DEL_ON_UNTIE})
        ? Cache::RedisDB->del(@{$self->{WHERE}})
        : $self->sync;
}

sub DESTROY {
    my $self = shift;

    return $self->UNTIE;
}

sub sync {
    my $self = shift;

    Cache::RedisDB->set(@{$self->{WHERE}}, $self->{DATA}, $self->{EXP_SECONDS});

    return $self->{DIRTY} = 0;    # Since we've sync'd it's not longer dirty,
}

sub delete {
    my $self = shift;

    return $self->{DEL_ON_UNTIE} = 1;
}

1;
__END__