File Coverage

blib/lib/Tie/CacheRedisDB.pm
Criterion Covered Total %
statement 23 62 37.1
branch 4 8 50.0
condition 5 11 45.4
subroutine 7 20 35.0
pod 0 2 0.0
total 39 103 37.8


line stmt bran cond sub pod time code
1             package Tie::CacheRedisDB;
2              
3 1     1   51234 use strict;
  1         2  
  1         21  
4 1     1   3 use warnings;
  1         1  
  1         16  
5 1     1   15 use 5.010;
  1         2  
6             our $VERSION = '1.0.0';
7              
8 1     1   3 use Carp qw(croak);
  1         1  
  1         30  
9 1     1   2 use Scalar::Util qw(reftype);
  1         1  
  1         29  
10 1     1   375 use Cache::RedisDB;
  1         55829  
  1         394  
11              
12             sub TIEHASH {
13 5     5   4018849 my ($self, $addr, $args) = @_;
14              
15             # Don't want to be crazy strict, but at least something which implies they know how this works.
16 5         21 my $whatsit = reftype $args;
17              
18 5 100       36 croak 'Must supply a lookup element' unless defined $addr;
19 4 100 50     36 croak 'Arguments must be supplied as a hash reference.'
      66        
20             unless (not defined $whatsit)
21             or (($whatsit // '') eq 'HASH');
22              
23 3   50     20 my $where = [$args->{namespace} // "TIECACHEREDISDB", $addr];
24              
25             my $node = {
26             EXP_SECONDS => $args->{expiry},
27 3   50     33 CAN_MISS => $args->{can_miss} // 2,
      0        
28             DIRTY => 0,
29             DEL_ON_UNTIE => 0,
30             WHERE => $where,
31             DATA => Cache::RedisDB->get(@$where) // {},
32             };
33              
34 0           return bless $node, $self;
35             }
36              
37             sub FETCH {
38 0     0     my ($self, $key) = @_;
39              
40 0           return $self->{DATA}->{$key};
41             }
42              
43             sub STORE {
44 0     0     my ($self, $key, $val) = @_;
45              
46 0           $self->{DATA}->{$key} = $val;
47 0           return $self->_check_dirty;
48             }
49              
50             sub _check_dirty {
51 0     0     my $self = shift;
52              
53 0           $self->{DIRTY} += 1;
54             $self->sync
55 0 0         if ($self->{DIRTY} > $self->{CAN_MISS}); # Need to hit the backing store
56              
57 0           return;
58             }
59              
60             sub DELETE {
61 0     0     my ($self, $key) = @_;
62              
63 0           my $val = delete $self->{DATA}->{$key};
64 0           $self->_check_dirty;
65              
66 0           return $val;
67             }
68              
69             sub CLEAR {
70 0     0     my $self = shift;
71              
72 0           $self->{DATA} = {};
73 0           return $self->sync;
74              
75             }
76              
77             sub EXISTS {
78 0     0     my ($self, $key) = @_;
79              
80 0           return exists $self->{DATA}->{$key};
81             }
82              
83             sub FIRSTKEY {
84 0     0     my $self = shift;
85              
86 0           return each %{$self->{DATA}};
  0            
87             }
88              
89             sub NEXTKEY {
90 0     0     my $self = shift;
91              
92 0           return each %{$self->{DATA}};
  0            
93             }
94              
95             sub SCALAR {
96 0     0     my $self = shift;
97              
98 0           return scalar %{$self->{DATA}};
  0            
99             }
100              
101             sub UNTIE {
102 0     0     my $self = shift;
103              
104             return ($self->{DEL_ON_UNTIE})
105 0 0         ? Cache::RedisDB->del(@{$self->{WHERE}})
  0            
106             : $self->sync;
107             }
108              
109             sub DESTROY {
110 0     0     my $self = shift;
111              
112 0           return $self->UNTIE;
113             }
114              
115             sub sync {
116 0     0 0   my $self = shift;
117              
118 0           Cache::RedisDB->set(@{$self->{WHERE}}, $self->{DATA}, $self->{EXP_SECONDS});
  0            
119              
120 0           return $self->{DIRTY} = 0; # Since we've sync'd it's not longer dirty,
121             }
122              
123             sub delete {
124 0     0 0   my $self = shift;
125              
126 0           return $self->{DEL_ON_UNTIE} = 1;
127             }
128              
129             1;
130             __END__