File Coverage

blib/lib/Tie/Hash/RedisDB.pm

Criterion	Covered	Total	%
statement	21	56	37.5
branch	0	10	0.0
condition	0	10	0.0
subroutine	7	18	38.8
pod	0	1	0.0
total	28	95	29.4

package Tie::Hash::RedisDB;

use strict;
use warnings;
our $VERSION = '1.02';

use Carp qw(croak);
use JSON;
use Scalar::Util qw(reftype);
use RedisDB;
use Try::Tiny;

my $json = JSON->new->utf8->allow_nonref;

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 ($whatsit // '') eq 'HASH';

    # All easy server definition for Cache::RedisDB users
    my $ruri = $args->{redis_uri} // $ENV{REDIS_CACHE_SERVER};
    croak 'Must supply a redis_redis' unless $ruri;

    my $node = {
        EXP_SECONDS  => $args->{expiry},
        DEL_ON_UNTIE => 0,
        WHERE        => join(chr(2), ($args->{namespace} // "THRDB"), $addr),
        REDIS => RedisDB->new(url => $ruri),
    };

    return bless $node, $self;

}

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

    my $val = $self->{REDIS}->hget($self->{WHERE}, $key);

    return $val && $json->decode($val);
}

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

    my $redis = $self->{REDIS};

    $redis->hset($self->{WHERE}, $key, $json->encode($val));
    if (my $expiry = $self->{EXP_SECONDS}) {
        $redis->expire($self->{WHERE}, $expiry);
    }

    return 1;
}

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

    return $self->{REDIS}->hdel($self->{WHERE}, $key);
}

sub CLEAR {
    my ($self) = @_;

    return $self->{REDIS}->del($self->{WHERE});
}

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

    return $self->{REDIS}->hexists($self->{WHERE}, $key);
}

sub FIRSTKEY {
    my ($self) = @_;

    $self->{_keys} = $self->{REDIS}->hkeys($self->{WHERE});

    return $self->NEXTKEY;
}

sub NEXTKEY {
    my ($self) = @_;

    return shift @{$self->{_keys}};
}

sub UNTIE {
    my ($self) = @_;

    return $self->{DEL_ON_UNTIE} ? $self->CLEAR : 1;
}

sub DESTROY {
    my ($self) = @_;

    return $self->UNTIE;
}

sub delete {
    my ($self) = @_;

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

1;
__END__