File Coverage

blib/lib/Rose/DBx/CannedQuery/SimpleQueryCache.pm

Criterion	Covered	Total	%
statement	57	57	100.0
branch	9	12	75.0
condition	2	3	66.6
subroutine	18	18	100.0
pod	4	4	100.0
total	90	94	95.7

#!perl
#

use strict;
use warnings;

package Rose::DBx::CannedQuery::SimpleQueryCache;

our ($VERSION) = '1.00';

use Data::Dumper;
use Digest::MD5 qw(md5_hex);

use Moo 2;
use Types::Standard qw/ CodeRef Object /;

has backend => (
    isa      => Object,
    is       => 'ro',
    required => 1,
    lazy     => 1,
    builder  => '_build_backend'
);

has args_to_key => (
    isa      => CodeRef,
    is       => 'ro',
    required => 1,
    lazy     => 1,
    builder  => '_build_args_to_key'
);

sub _build_backend {
    Rose::DBx::CannedQuery::SimpleQueryCache::_PlainOldHash->new();
}

{
    my $dumper = Data::Dumper->new( [] )->Sortkeys(1);

    sub _make_digest_key {
        my (%args) = ref $_[0] ? %{ $_[0] } : @_;
        my $key =
          $dumper->Reset->Values( [ map { $_ => $args{$_} } sort keys %args ] )
          ->Dump;
        $key =~ s/\s+/ /g;
        $key = lc $key;
        $key = md5_hex($key) if length($key) > 512;
        return $key;
    }
}

sub _build_args_to_key {
    return \&_make_digest_key;
}

sub get_query_from_cache {
    my $self = shift;
    my $key  = $self->args_to_key->(@_);
    my $qry  = $self->backend->get($key);

    if ($qry) {
        my $sth = $qry->sth;

        # We take this roundabout path to check on connectedness because
        # $sth's own Active attribute may be false if prepared but not yet
        # executed, and we don't want to go through Rose::DB->dbh to get
        # DBI's database handle, since it'll reconnect under the hood if
        # it's been disconnected, which doesn't help $sth
        return $qry if $sth->{Active} or $sth->{Database}->{Active};
        $self->backend->remove($key);
    }
    return;
}

sub add_query_to_cache {
    my $self  = shift;
    my $query = shift;
    my $key   = $self->args_to_key->(@_);
    my $ret   = $self->backend->set( $key, $query );
    return $ret ? $query : $ret;
}

sub remove_query_from_cache {
    my $self = shift;
    my $key  = $self->args_to_key->(@_);
    return $self->backend->remove($key);
}

sub clear_query_cache {
    shift->backend->clear();
}

{

    package Rose::DBx::CannedQuery::SimpleQueryCache::_PlainOldHash;

    sub new {
        bless {}, shift;
    }

    sub get {
        my ( $self, $key ) = @_;
        return $self->{$key} if exists $self->{$key};
        return;
    }

    sub set {
        my ( $self, $key, $query ) = @_;
        $self->{$key} = $query;
        return $query;
    }

    sub remove {
        my ( $self, $key ) = @_;
        delete $self->{$key};
    }

    sub clear {
        my $self = shift;
        undef %$self;
        return 1;
    }
}

1;

__END__