File Coverage

blib/lib/XAO/Cache.pm
Criterion Covered Total %
statement 56 57 98.2
branch 23 34 67.6
condition 16 29 55.1
subroutine 8 8 100.0
pod 4 4 100.0
total 107 132 81.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::Cache - generic interface for caching various data
4              
5             =head1 SYNOPSIS
6              
7             my $cache=XAO::Cache->new(
8             retrieve => &real_retrieve,
9             coords => [qw(outer inner)],
10             size => 100,
11             expire => 30*60,
12             backend => 'Cache::Memory',
13             );
14            
15             my $d1=$cache->get(outer => 123, inner => 'foo');
16              
17             my $d2=$cache->get($self, outer => 234, extra => 'bar');
18              
19             =head1 DESCRIPTION
20              
21             NOTE: It is almost always better to use Config::cache() method instead
22             of creating a cache directly with its new() method. That will also save
23             on the initialization step - cache object themselves are cached and
24             reused in that case.
25              
26             XAO::Cache is a generic cache implementation for caching various "slow"
27             data such as database content, results of remote requests and so on.
28              
29             There is no operation of storing data into the cache. Instead cache
30             is provided with a method to retrieve requested content whenever
31             required. On subsequent calls a cached value would be returned until
32             either expiration time is elapsed or cache has overgrown its maximum
33             size. In which case the real query will be made again to actually
34             retrieve data.
35              
36             That means that cache always returns valid data or throws an error if
37             that is not possible.
38              
39             To force the cache to use "retrieve" to get a new value that is stored
40             in the cache give an extra "force_update" parameter to the get() method.
41              
42             =head1 METHODS
43              
44             Here is the alphabetically arranged list of methods:
45              
46             =over
47              
48             =cut
49              
50             ###############################################################################
51             package XAO::Cache;
52 3     3   676 use strict;
  3         7  
  3         87  
53 3     3   15 use XAO::Utils;
  3         5  
  3         199  
54 3     3   20 use XAO::Errors qw(XAO::E::Cache);
  3         18  
  3         61  
55 3     3   18 use XAO::Objects;
  3         12  
  3         2789  
56              
57             our $VERSION=2.1;
58              
59             ###############################################################################
60              
61             =item drop ($%)
62              
63             Removes an element from cache. Useful to make cache aware of changes in
64             the cached element -- when cached data are no longer valid.
65              
66             Arguments must contain a list of coordinates the same as in get()
67             method.
68              
69             =cut
70              
71             sub drop ($%) {
72 8     8 1 149 my $self=shift;
73 8         12 my $backend=$self->{'backend'};
74            
75 8 50 33     21 my $object=ref($_[0]) && ref($_[0]) ne 'HASH' ? shift(@_) : undef;
76 8         19 my $args=get_args(\@_);
77              
78 8         18 my @c=map { $args->{$_} } @{$self->{'coords'}};
  16         33  
  8         19  
79 8 50       19 defined($c[0]) ||
80             throw XAO::E::Cache "get - no first coordinate ($args->{coords}->[0])";
81              
82 8         22 $backend->drop(\@c);
83             }
84              
85             ###############################################################################
86              
87             =item drop_all ($)
88              
89             Remove all elements from the cache.
90              
91             =cut
92              
93             sub drop_all ($) {
94 2     2 1 24 my $self=shift;
95              
96 2 50       14 if($self->{'backend'}->can('drop_all')) {
97 2         7 $self->{'backend'}->drop_all();
98             }
99             else {
100 0         0 eprint "Cache backend '$self->{'backend'}' does not support drop_all()";
101             }
102             }
103              
104             ###############################################################################
105              
106             =item get ($%)
107              
108             Retrieve a data element from the cache. The cache can decide to use real
109             'retrieve' method to get the data or return previously stored value
110             instead.
111              
112             All arguments given to the get() method will be passed to 'retrieve'
113             method. As a special case if retrieve is a method of some class then a
114             reference to object of that class must be the first argument followed by
115             a hash with arguments.
116              
117             Example of calling 'retrieve' as a function:
118              
119             $cache->get(foo => 123, bar => 234);
120              
121             Example of calling 'retrieve' as a method:
122              
123             $cache->get($object, foo => 123, bar => 123);
124              
125             Example of forcing an update of cache value:
126              
127             $cache->get(foo => 123, bar => 234, force_update => 1);
128              
129             =cut
130              
131             sub get ($@) {
132 2393     2393 1 4073045 my $self=shift;
133 2393         3376 my $backend=$self->{'backend'};
134            
135 2393 100 66     5225 my $object=ref($_[0]) && ref($_[0]) ne 'HASH' ? shift(@_) : undef;
136 2393         4657 my $args=get_args(\@_);
137              
138 2393         3568 my @c=map { $args->{$_} } @{$self->{'coords'}};
  3032         6471  
  2393         4053  
139 2393 50       4620 defined($c[0]) ||
140             throw XAO::E::Cache "get - no first coordinate ($args->{coords}->[0])";
141              
142             # Get method will return undef for non-existent. Or a reference to
143             # value (possibly an undef) when a value exists.
144             #
145 2393 100       5952 my $data_ref=$args->{'force_update'} ? undef : $backend->get(\@c);
146              
147 2393 100       5484 return $$data_ref if defined $data_ref;
148              
149 1678 100       2611 my $data=&{$self->{'retrieve'}}($object ? ($object) : (),$args);
  1678         3181  
150              
151 1678         11025 $backend->put(\@c => \$data);
152              
153 1678         4389 return $data;
154             }
155              
156             ###############################################################################
157              
158             =item new (%)
159              
160             Creates a new independent instance of a cache. When that instance is
161             destroyed all cache content is destroyed as well. Arguments are:
162              
163             =over
164              
165             =item backend
166              
167             Type of backend that will actuall keep values in cache.
168             Can be either a XAO object name or an object reference.
169              
170             Default is 'Cache::Memory' (XAO::DO::Cache::Memory).
171              
172             =item coords
173              
174             Coordinates of a data element in the cache -- reference to an array that
175             keeps names of arguments identifying a data element in the cache. The
176             order of elements in the list is significant -- first element is
177             mandatory, the rest is optional.
178              
179             A combination of all coordinates must uniquely identify a cached data
180             element among all others in the cache. For instance, if you create a
181             cache with customers, then 'customer_id' will most probably be your only
182             coordinate. But if to retrieve a data element you need element type and
183             id then your coordinates will be:
184              
185             coords => ['type', 'id']
186              
187             There is no default for coordinates.
188              
189             B: Coordinates are supposed to be text strings meeting isprint()
190             criteria.
191              
192             =item expire
193              
194             Expiration time for data elements in the cache. Default is no expiration
195             time.
196              
197             =item retrieve
198              
199             Reference to a method or a subroutine that will actually retrieve data
200             element when there is no element in the cache or cache element has
201             expired.
202              
203             The subroutine gets all parameters passed to cache's get() method.
204              
205             Cache does not perform any checks for correctness of result, so if for
206             some reason retrieval cannot be performed an error should be thrown
207             instead of returning undef or other indicator of failure.
208              
209             =item size
210              
211             Optional maximum size of the cache in Kbytes. If not specified then only
212             expiration time will be used as a criteria to throw a data element out
213             of cache.
214              
215             =item value_maxlength
216              
217             Maximum length of an individual value to be stored. Values longer than
218             this size may be ignored by the cache, but it is still safe to return
219             then from the retrieve() method. They MAY just not be cached.
220              
221             Primarily this is useful for memcached configuration to match what the
222             memcached server is going to reject anyway.
223              
224             =back
225              
226             If there is a current project and that project Config object holds a
227             /cache/config data then that data is used for default values, providing
228             a way to, for instance, change cache backend globally for all project
229             caches.
230              
231             The configuration is structured like this:
232              
233             cache => {
234             config => {
235             common => {
236             backend => 'Cache::Memcached',
237             },
238             foo_cache => {
239             backend => 'Cache::Memory',
240             size => 1_000_000,
241             },
242             },
243             },
244              
245             For a cache named foo_cache the backend would be 'Cache::Memory' and for
246             all other caches -- 'Cache::Memcached' in that case.
247              
248             =cut
249              
250             sub new ($%) {
251 15     15 1 460 my $proto=shift;
252 15         172 my $args=get_args(\@_);
253              
254             # Checking if there is a site configuration and some default
255             # parameters in it.
256             #
257             my $config=$args->{'sitename'}
258 15 50 66     123 ? XAO::Projects::get_project($args->{'sitename'})
259             : (XAO::Projects::get_current_project_name() && XAO::Projects::get_current_project());
260              
261 15 100 66     127 if($config && $config->can('get')) {
262             $args=merge_refs(
263             $config->get('/cache/config/common') || { },
264 14 100 50     643 ($args->{'name'} ? ($config->get('/cache/config/'.$args->{'name'})) : ()),
265             $args,
266             );
267             }
268              
269             # Backend -- can be an object reference or an object name
270             #
271 15   100     108 my $backend=$args->{'backend'} || 'Cache::Memory';
272             ### dprint "Created cache '",$args->{'name'},"', backend='$backend'";
273 15 50       95 $backend=XAO::Objects->new(objname => $backend) unless ref($backend);
274              
275             # Retrieve function must be a code reference
276             #
277 15   33     49 my $retrieve=$args->{'retrieve'} ||
278             throw XAO::E::Cache "new - no 'retrive' argument";
279 15 50       46 ref($retrieve) eq 'CODE' ||
280             throw XAO::E::Cache "new - 'retrive' must be a code reference";
281              
282             # Coords must be an array reference or a single scalar
283             #
284 15   0     35 my $coords=$args->{'coords'} || $args->{'coordinates'} ||
285             throw XAO::E::Cache "new - no 'coords' argument";
286              
287 15 50       63 $coords=[ $coords ] if !ref($coords);
288              
289 15 50       43 ref($coords) eq 'ARRAY' ||
290             throw XAO::E::Cache "new - 'coords' must be an array reference";
291              
292 15 50       46 (grep { $_ eq 'force_update' } @$coords) &&
  17         80  
293             throw XAO::E::Cache "new - cannot use 'force_update' as a coordinate";
294              
295             my $self={
296             name => $args->{'name'},
297             backend => $backend,
298             coords => $coords,
299             expire => $args->{'expire'} || 0,
300             retrieve => $retrieve,
301 15   100     175 size => ($args->{'size'} || 0)*1024,
      100        
302             };
303              
304             # Setting up back-end parameters
305             #
306 15         77 $backend->setup($args);
307              
308             # Old caches used to have 'exists' method, which is now obsolete.
309             # It requires at least a double key calculation, and in the case of
310             # memcached also a double network trip.
311             #
312 15 50       85 !$backend->can('exists') ||
313             throw XAO::E::Cache "new - backend '$backend' supports an obsolete 'exists' method, upgrade it";
314              
315             # Done, blessing
316             #
317 15   33     115 bless $self,ref($proto) || $proto;
318             }
319              
320             ###############################################################################
321             1;
322             __END__