File Coverage

blib/lib/Jifty/DBI/Record/Cachable.pm
Criterion Covered Total %
statement 84 106 79.2
branch 27 38 71.0
condition 6 25 24.0
subroutine 18 23 78.2
pod 3 3 100.0
total 138 195 70.7


line stmt bran cond sub pod time code
1             package Jifty::DBI::Record::Cachable;
2              
3 2     2   2232 use base qw(Jifty::DBI::Record);
  2         3  
  2         603  
4              
5 2     2   11 use Jifty::DBI::Handle;
  2         2  
  2         20  
6              
7 2     2   1052 use Cache::Simple::TimedExpiry;
  2         1020  
  2         22  
8 2     2   64 use Scalar::Util qw/ blessed /;
  2         4  
  2         105  
9              
10 2     2   7 use strict;
  2         3  
  2         44  
11 2     2   7 use warnings;
  2         2  
  2         1983  
12              
13             =head1 NAME
14              
15             Jifty::DBI::Record::Cachable - records with caching behavior
16              
17             =head1 SYNOPSIS
18              
19             package Myrecord;
20             use base qw/Jifty::DBI::Record::Cachable/;
21              
22             =head1 DESCRIPTION
23              
24             This module subclasses the main L package to add a
25             caching layer.
26              
27             The public interface remains the same, except that records which have
28             been loaded in the last few seconds may be reused by subsequent fetch
29             or load methods without retrieving them from the database.
30              
31             =head1 METHODS
32              
33             =cut
34              
35             my %_CACHES = ();
36              
37             sub _setup_cache {
38 9     9   11 my $self = shift;
39 9         8 my $cache = shift;
40 9         45 $_CACHES{$cache} = Cache::Simple::TimedExpiry->new();
41 9         63 $_CACHES{$cache}->expire_after( $self->_cache_config->{'cache_for_sec'} );
42             }
43              
44             =head2 flush_cache
45              
46             This class method flushes the _global_ Jifty::DBI::Record::Cachable
47             cache. All caches are immediately expired.
48              
49             =cut
50              
51             sub flush_cache {
52 6     6 1 2997 %_CACHES = ();
53             }
54              
55             sub _key_cache {
56 15     15   16 my $self = shift;
57 15   33     26 my $cache
58             = $self->_handle->dsn
59             . "-KEYS--"
60             . ( $self->{'_class'} || $self->table );
61 15 100       101 $self->_setup_cache($cache) unless exists( $_CACHES{$cache} );
62 15         43 return ( $_CACHES{$cache} );
63              
64             }
65              
66             =head2 _flush_key_cache
67              
68             Blow away this record type's key cache
69              
70             =cut
71              
72             sub _flush_key_cache {
73 0     0   0 my $self = shift;
74 0   0     0 my $cache
75             = $self->_handle->dsn
76             . "-KEYS--"
77             . ( $self->{'_class'} || $self->table );
78 0         0 $self->_setup_cache($cache);
79             }
80              
81             sub _record_cache {
82 20     20   22 my $self = shift;
83 20   33     43 my $cache
84             = $self->_handle->dsn . "--" . ( $self->{'_class'} || $self->table );
85 20 100       202 $self->_setup_cache($cache) unless exists( $_CACHES{$cache} );
86 20         100 return ( $_CACHES{$cache} );
87              
88             }
89              
90             sub _is_in_transaction {
91 8     8   10 my $self = shift;
92 8         36 $Jifty::DBI::Handle::TRANSDEPTH > 0;
93             }
94              
95             =head2 load_from_hash
96              
97             Overrides the implementation from L to add caching.
98              
99             =cut
100              
101             sub load_from_hash {
102 1     1 1 2 my $self = shift;
103              
104 1         7 my ( $rvalue, $msg );
105 1 50       4 if ( ref($self) ) {
106              
107             # Blow away the primary cache key since we're loading.
108 1         3 $self->{'_jifty_cache_pkey'} = undef;
109 1         9 ( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_);
110              
111             ## Check the return value, if its good, cache it!
112 1 50 33     12 $self->_store() if ($rvalue && !$self->_is_in_transaction);
113 1         35 return ( $rvalue, $msg );
114             } else { # Called as a class method;
115 0         0 $self = $self->SUPER::load_from_hash(@_);
116             ## Check the return value, if its good, cache it!
117 0 0 0     0 $self->_store() if ( $self->id && !$self->_is_in_transaction );
118 0         0 return ($self);
119             }
120              
121             }
122              
123             =head2 load_by_cols
124              
125             Overrides the implementation from L to add caching.
126              
127             =cut
128              
129             sub load_by_cols {
130 11     11 1 35 my ( $class, %attr ) = @_;
131              
132 11         12 my ($self);
133 11 50       21 if ( ref($class) ) {
134 11         19 ( $self, $class ) = ( $class, undef );
135             } else {
136 0   0     0 $self = $class->new( handle => ( delete $attr{'_handle'} || undef ) );
137             }
138              
139             ## Generate the cache key
140 11         42 my $alt_key = $self->_gen_record_cache_key(%attr);
141 11 100       94 if ( $self->_fetch($alt_key) ) {
142 4 50       9 if ($class) { return $self }
  0         0  
143 4         12 else { return ( 1, "Fetched from cache" ) }
144             }
145              
146             # Blow away the primary cache key since we're loading.
147 7         12 $self->{'_jifty_cache_pkey'} = undef;
148              
149             ## Fetch from the DB!
150 7         31 my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr);
151             ## Check the return value, if its good, cache it!
152 7 50 33     34 if ($rvalue && !$self->_is_in_transaction) {
153             ## Only cache the object if its okay to do so.
154 7         15 $self->_store();
155 7         134 $self->_key_cache->set(
156             $alt_key => $self->_primary_record_cache_key );
157              
158             }
159 7 50       60 if ($class) { return $self }
  0         0  
160             else {
161 7         35 return ( $rvalue, $msg );
162             }
163             }
164              
165             # Function: __set
166             # Type : (overloaded) public instance
167             # Args : see Jifty::DBI::Record::_Set
168             # Lvalue : ?
169              
170             sub __set () {
171 0     0   0 my $self = shift;
172              
173 0         0 $self->_expire();
174 0         0 return $self->SUPER::__set(@_);
175              
176             }
177              
178             # Function: delete
179             # Type : (overloaded) public instance
180             # Args : nil
181             # Lvalue : ?
182              
183             sub __delete () {
184 0     0   0 my $self = shift;
185              
186 0         0 $self->_expire();
187 0         0 return $self->SUPER::__delete(@_);
188              
189             }
190              
191             # Function: _expire
192             # Type : private instance
193             # Args : string(cache_key)
194             # Lvalue : 1
195             # Desc : Removes this object from the cache.
196              
197             sub _expire (\$) {
198 0     0   0 my $self = shift;
199 0         0 $self->_record_cache->set( $self->_primary_record_cache_key,
200             undef, time - 1 );
201              
202             # We should be doing something more surgical to clean out the key cache. but we do need to expire it
203 0         0 $self->_flush_key_cache;
204              
205             }
206              
207             # Function: _fetch
208             # Type : private instance
209             # Args : string(cache_key)
210             # Lvalue : 1
211             # Desc : Get an object from the cache, and make this object that.
212              
213             sub _fetch () {
214 11     11   16 my ( $self, $cache_key ) = @_;
215              
216             # If the alternate key is really the primary one
217              
218 11         23 my $data = $self->_record_cache->fetch($cache_key);
219              
220 11 100       183 unless ($data) {
221 8         22 $cache_key = $self->_key_cache->fetch($cache_key);
222 8 100       71 $data = $self->_record_cache->fetch($cache_key) if $cache_key;
223             }
224              
225 11 100       35 return undef unless ($data);
226              
227 4         13 @{$self}{ keys %$data } = values %$data; # deserialize
  4         13  
228 4         11 return 1;
229             }
230              
231             #sub __value {
232             # my $self = shift;
233             # my $column = shift;
234             #
235             # # XXX TODO, should we be fetching directly from the cache?
236             # return ( $self->SUPER::__value($column) );
237             #}
238              
239             # Function: _store
240             # Type : private instance
241             # Args : string(cache_key)
242             # Lvalue : 1
243             # Desc : Stores this object in the cache.
244              
245             sub _store (\$) {
246 8     8   7 my $self = shift;
247 8         18 $self->_record_cache->set(
248             $self->_primary_record_cache_key,
249             { values => $self->{'values'},
250             table => $self->table,
251             fetched => $self->{'fetched'},
252             decoded => $self->{'decoded'},
253             raw_values => $self->{'raw_values'},
254             }
255             );
256             }
257              
258             # Function: _gen_record_cache_key
259             # Type : private instance
260             # Args : hash (attr)
261             # Lvalue : 1
262             # Desc : Takes a perl hash and generates a key from it.
263              
264             sub _gen_record_cache_key {
265 11     11   17 my ( $self, %attr ) = @_;
266              
267 11         16 my @cols;
268              
269 11         34 while ( my ( $key, $value ) = each %attr ) {
270 11 100 33     59 unless ( defined $value ) {
    100          
    50          
271 1         5 push @cols, lc($key) . '=__undef';
272             } elsif ( ref($value) eq "HASH" ) {
273 1 50 50     12 push @cols,
274             lc($key)
275             . ( $value->{operator} || '=' )
276             . defined $value->{value} ? $value->{value} : '__undef';
277             } elsif ( blessed $value and $value->isa('Jifty::DBI::Record') ) {
278 0         0 push @cols, lc($key) . '=' . ( $value->id );
279             } else {
280 9         37 push @cols, lc($key) . "=" . $value;
281             }
282             }
283 11         32 return ( $self->table() . ':' . join( ',', @cols ) );
284             }
285              
286             # Function: _fetch_record_cache_key
287             # Type : private instance
288             # Args : nil
289             # Lvalue : 1
290              
291             sub _fetch_record_cache_key {
292 0     0   0 my ($self) = @_;
293 0         0 my $cache_key = $self->_cache_config->{'cache_key'};
294 0         0 return ($cache_key);
295             }
296              
297             # Function: _primary_record_cache_key
298             # Type : private instance
299             # Args : none
300             # Lvalue: : 1
301             # Desc : generate a primary-key based variant of this object's cache key
302             # primary keys is in the cache
303              
304             sub _primary_record_cache_key {
305 15     15   15 my ($self) = @_;
306              
307 15 100       28 unless ( $self->{'_jifty_cache_pkey'} ) {
308              
309 8         10 my @attributes;
310 8         20 my %pk = $self->primary_keys;
311 8         30 while ( my ( $key, $value ) = each %pk ) {
312 8 50       19 return unless defined $value;
313 8         34 push @attributes, lc($key) . '=' . $value;
314             }
315              
316 8         22 $self->{'_jifty_cache_pkey'} = $self->table . ':' . join ',',
317             @attributes;
318             }
319 15         93 return ( $self->{'_jifty_cache_pkey'} );
320              
321             }
322              
323             =head2 _cache_config
324              
325             You can override this method to change the duration of the caching
326             from the default of 5 seconds.
327              
328             For example, to cache records for up to 30 seconds, add the following
329             method to your class:
330              
331             sub _cache_config {
332             { 'cache_for_sec' => 30 }
333             }
334              
335             =cut
336              
337             sub _cache_config {
338 9     9   40 { 'cache_p' => 1,
339             'cache_for_sec' => 5,
340             };
341             }
342              
343             1;
344              
345             __END__