File Coverage

blib/lib/Cache/Redis.pm
Criterion Covered Total %
statement 11 98 11.2
branch 0 34 0.0
condition 0 25 0.0
subroutine 4 20 20.0
pod 8 8 100.0
total 23 185 12.4


line stmt bran cond sub pod time code
1             package Cache::Redis;
2 7     7   595030 use 5.008_001;
  7         27  
3 7     7   32 use strict;
  7         12  
  7         130  
4 7     7   35 use warnings;
  7         17  
  7         298  
5              
6             our $VERSION = '0.13';
7              
8 7     7   18520 use Module::Load;
  7         7185  
  7         43  
9              
10             my $_mp;
11             sub _mp {
12 0   0 0     $_mp ||= Data::MessagePack->new->utf8;
13             }
14             sub _mp_serialize {
15 0     0     _mp->pack(@_);
16             }
17             sub _mp_deserialize {
18 0     0     _mp->unpack(@_);
19             }
20              
21             sub _mk_serialize {
22 0     0     my $code = shift;
23              
24             return sub {
25 0     0     my $data = shift;
26              
27 0           my $flags; # for future extention
28 0           my $store_date = [$data, $flags];
29 0           $code->($store_date);
30 0           };
31             }
32              
33             sub _mk_deserialize {
34 0     0     my $code = shift;
35              
36             return sub {
37 0     0     my $data = shift;
38              
39 0           my ($org, $flags) = @{$code->($data)};
  0            
40 0           $org;
41 0           };
42             }
43              
44             sub new {
45 0     0 1   my $class = shift;
46              
47 0 0         my $args = @_ == 1 ? $_[0] : {@_};
48 0   0       my $default_expires_in = delete $args->{default_expires_in} || 60*60*24 * 30;
49 0   0       my $namespace = delete $args->{namespace} || '';
50 0   0       my $nowait = delete $args->{nowait} || 0;
51 0   0       my $redis_class = delete $args->{redis_class} || 'Redis';
52              
53 0           my $redis = delete $args->{redis};
54 0           my $serializer = delete $args->{serializer};
55 0           my $serialize_methods = delete $args->{serialize_methods};
56 0 0 0       die '`serializer` and `serialize_methods` is exclusive option' if $serializer && $serialize_methods;
57 0 0 0       $serializer ||= 'Storable' unless $serialize_methods;
58              
59 0           my ($serialize, $deserialize);
60 0 0         if ($serializer) {
61 0 0         if ($serializer eq 'Storable') {
    0          
62 0           require Storable;
63 0           $serialize_methods = [\&Storable::nfreeze, \&Storable::thaw];
64             }
65             elsif ($serializer eq 'JSON') {
66 0           require JSON::XS;
67 0           $serialize_methods = [\&JSON::XS::encode_json, \&JSON::XS::decode_json];
68             }
69             }
70              
71 0 0         if ($serialize_methods) {
    0          
72 0           $serialize = _mk_serialize $serialize_methods->[0];
73 0           $deserialize = _mk_deserialize $serialize_methods->[1];
74             }
75             elsif ($serializer eq 'MessagePack') {
76 0           require Data::MessagePack;
77 0           $serialize = \&_mp_serialize;
78 0           $deserialize = \&_mp_deserialize;
79             }
80 0 0 0       die 'Serializer is not found' if !$serialize || !$deserialize;
81              
82 0 0         unless ( $redis ) {
83 0           load $redis_class;
84 0           $redis = $redis_class->new(
85             encoding => undef,
86             %$args
87             );
88             }
89              
90             bless {
91 0           default_expires_in => $default_expires_in,
92             serialize => $serialize,
93             deserialize => $deserialize,
94             redis => $redis,
95             namespace => $namespace,
96             nowait => $nowait,
97             }, $class;
98             }
99              
100             sub get {
101 0     0 1   my ($self, $key) = @_;
102 0           $key = $self->{namespace} . $key;
103              
104 0           my $data = $self->{redis}->get($key);
105              
106 0 0         defined $data ? $self->{deserialize}->($data) : $data;
107             }
108              
109             sub get_multi {
110 0     0 1   my ($self, @keys) = @_;
111 0           @keys = map { $self->{namespace} . $_ } @keys;
  0            
112              
113 0           my @data = $self->{redis}->mget(@keys);
114              
115 0           my $i = 0;
116 0           my $ret = {};
117 0           for my $key ( @keys ) {
118 0 0         if ( defined $data[$i] ) {
119 0           $ret->{$key} = $self->{deserialize}->($data[$i]);
120             }
121 0           $i++;
122             }
123              
124 0           $ret;
125             }
126              
127             sub set {
128 0     0 1   my ($self, $key, $value, $expire, $callback) = @_;
129              
130 0 0         die 'set() requires key and value arguments' if scalar(@_) < 3;
131              
132 0           my $response = $self->_set($key, $value, $expire, $callback);
133              
134             # return now as the callabck will be called when it's done processing
135 0 0         return if ($self->{nowait});
136 0           $self->{redis}->wait_all_responses;
137 0           return $response;
138             }
139              
140             sub set_multi {
141 0     0 1   my ($self, @items) = @_;
142              
143 0           for my $item ( @items ) {
144 0           $self->_set(@$item);
145             }
146 0 0         $self->{redis}->wait_all_responses unless $self->{nowait};
147             }
148              
149             sub _set {
150 0     0     my ($self, $key, $value, $expire, $callback) = @_;
151 0           $key = $self->{namespace} . $key;
152 0   0       $expire ||= $self->{default_expires_in};
153              
154 0 0 0       if ($self->{nowait} && $callback) {
155 0           $self->{redis}->setex($key, $expire, $self->{serialize}->($value), $callback);
156             }
157             else {
158 0           $self->{redis}->setex($key, $expire, $self->{serialize}->($value));
159             }
160             }
161              
162             sub get_or_set {
163 0     0 1   my ($self, $key, $code, $expire) = @_;
164              
165 0           my $data = $self->get($key);
166 0 0         unless (defined $data) {
167 0           $data = $code->();
168 0           $self->set($key, $data, $expire);
169             }
170 0           $data;
171             }
172              
173             sub remove {
174 0     0 1   my ($self, $key) = @_;
175              
176 0           my $data = $self->get($key);
177 0           $key = $self->{namespace} . $key;
178 0           $self->{redis}->del($key);
179              
180 0           $data;
181             }
182              
183             sub nowait_push {
184 0     0 1   shift->{redis}->wait_all_responses;
185             }
186              
187             1;
188             __END__