Lines 1-6
Link Here
|
1 |
package Koha::Cache; |
1 |
package Koha::Cache; |
2 |
|
2 |
|
3 |
# Copyright 2009 Chris Cormack and The Koha Dev Team |
3 |
# Copyright 2009 Chris Cormack and The Koha Dev Team |
|
|
4 |
# Parts copyright 2012-2013 C & P Bibliography Services |
4 |
# |
5 |
# |
5 |
# This file is part of Koha. |
6 |
# This file is part of Koha. |
6 |
# |
7 |
# |
Lines 23-46
Koha::Cache - Handling caching of html and Objects for Koha
Link Here
|
23 |
|
24 |
|
24 |
=head1 SYNOPSIS |
25 |
=head1 SYNOPSIS |
25 |
|
26 |
|
26 |
use Koha::Cache (cache_type => $cache_type, %params ); |
27 |
use Koha::Cache; |
|
|
28 |
my $cache = Koha::Cache->new({cache_type => $cache_type, %params}); |
27 |
|
29 |
|
28 |
=head1 DESCRIPTION |
30 |
=head1 DESCRIPTION |
29 |
|
31 |
|
30 |
Base class for Koha::Cache::X. Subclasses must provide the following methods |
32 |
Koha caching routines. This class provides two interfaces for cache access. |
31 |
|
33 |
The first, traditional interface provides the following functions: |
32 |
B<_cache_handle ($params_hr)> - cache handle creator |
|
|
33 |
|
34 |
Subclasses may override the following methods if they are not using a |
35 |
CHI-derived cache |
36 |
|
37 |
B<set_in_cache ($key, $value, $expiry)> |
38 |
|
39 |
B<get_from_cache ($key)> |
40 |
|
41 |
B<clear_from_cache ($key)> |
42 |
|
43 |
B<flush_all ()> |
44 |
|
34 |
|
45 |
=head1 FUNCTIONS |
35 |
=head1 FUNCTIONS |
46 |
|
36 |
|
Lines 50-139
use strict;
Link Here
|
50 |
use warnings; |
40 |
use warnings; |
51 |
use Carp; |
41 |
use Carp; |
52 |
use Module::Load::Conditional qw(can_load); |
42 |
use Module::Load::Conditional qw(can_load); |
53 |
use Module::Load; |
43 |
use Koha::Cache::Object; |
54 |
|
44 |
|
55 |
my $have_chi = 0; |
45 |
use base qw(Class::Accessor); |
56 |
|
46 |
|
57 |
BEGIN: { |
47 |
__PACKAGE__->mk_ro_accessors( |
58 |
if ( can_load( modules => { CHI => undef } ) ) { |
48 |
qw( cache memcached_cache fastmmap_cache memory_cache )); |
59 |
$have_chi = 1; |
|
|
60 |
} |
61 |
} |
62 |
|
49 |
|
63 |
use base qw(Class::Accessor); |
50 |
=head2 new |
64 |
|
51 |
|
65 |
__PACKAGE__->mk_ro_accessors(qw( cache )); |
52 |
Create a new Koha::Cache object. This is required for all cache-related functionality. |
|
|
53 |
|
54 |
=cut |
66 |
|
55 |
|
67 |
sub new { |
56 |
sub new { |
68 |
my $class = shift; |
57 |
my ( $class, $self ) = @_; |
69 |
my $param = shift; |
58 |
$self->{'default_type'} = |
70 |
my $cache_type = |
59 |
$self->{cache_type} |
71 |
$ENV{CACHING_SYSTEM} |
60 |
|| $ENV{CACHING_SYSTEM} |
72 |
|| $param->{cache_type} |
|
|
73 |
|| 'memcached'; |
61 |
|| 'memcached'; |
74 |
my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type); |
62 |
|
75 |
$param->{have_chi} = $have_chi; |
63 |
$ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}"; |
76 |
unless ( can_load( modules => { $subclass => undef } ) ) { |
64 |
|
77 |
$subclass = __PACKAGE__ . "::" . ucfirst('Null'); |
65 |
$self->{'timeout'} ||= 0; |
78 |
load $subclass; |
66 |
$self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha'; |
|
|
67 |
|
68 |
if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) { |
69 |
_initialize_memcached($self); |
70 |
if ( $self->{'default_type'} eq 'memcached' |
71 |
&& defined( $self->{'memcached_cache'} ) ) |
72 |
{ |
73 |
$self->{'cache'} = $self->{'memcached_cache'}; |
74 |
} |
75 |
} |
76 |
|
77 |
if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) { |
78 |
_initialize_fastmmap($self); |
79 |
if ( $self->{'default_type'} eq 'fastmmap' |
80 |
&& defined( $self->{'fastmmap_cache'} ) ) |
81 |
{ |
82 |
$self->{'cache'} = $self->{'fastmmap_cache'}; |
83 |
} |
79 |
} |
84 |
} |
80 |
my $cache = $subclass->_cache_handle($param); |
85 |
|
|
|
86 |
if ( can_load( modules => { 'Cache::Memory' => undef } ) ) { |
87 |
_initialize_memory($self); |
88 |
if ( $self->{'default_type'} eq 'memory' |
89 |
&& defined( $self->{'memory_cache'} ) ) |
90 |
{ |
91 |
$self->{'cache'} = $self->{'memory_cache'}; |
92 |
} |
93 |
} |
94 |
|
95 |
# NOTE: The following five lines could be uncommented if we wanted to |
96 |
# fall back to any functioning cache. Commented out since this would |
97 |
# represent a change in behavior. |
98 |
# |
99 |
#unless (defined($self->{'cache'})) { |
100 |
# foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) { |
101 |
# $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember})); |
102 |
# } |
103 |
#} |
104 |
|
81 |
return |
105 |
return |
82 |
bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ), |
106 |
bless $self, |
83 |
$subclass; |
107 |
$class; |
|
|
108 |
} |
109 |
|
110 |
sub _initialize_memcached { |
111 |
my ($self) = @_; |
112 |
my @servers = |
113 |
split /,/, $self->{'cache_servers'} |
114 |
? $self->{'cache_servers'} |
115 |
: $ENV{MEMCACHED_SERVERS}; |
116 |
|
117 |
$ENV{DEBUG} |
118 |
&& carp "Memcached server settings: " |
119 |
. join( ', ', @servers ) |
120 |
. " with " |
121 |
. $self->{'namespace'}; |
122 |
$self->{'memcached_cache'} = Cache::Memcached::Fast->new( |
123 |
{ |
124 |
servers => \@servers, |
125 |
compress_threshold => 10_000, |
126 |
namespace => $self->{'namespace'}, |
127 |
} |
128 |
); |
129 |
return $self; |
84 |
} |
130 |
} |
85 |
|
131 |
|
|
|
132 |
sub _initialize_fastmmap { |
133 |
my ($self) = @_; |
134 |
|
135 |
$self->{'fastmmap_cache'} = Cache::FastMmap->new( |
136 |
'share_file' => "/tmp/sharefile-koha-$self->{'namespace'}", |
137 |
'expire_time' => $self->{'timeout'}, |
138 |
'unlink_on_exit' => 0, |
139 |
); |
140 |
return $self; |
141 |
} |
142 |
|
143 |
sub _initialize_memory { |
144 |
my ($self) = @_; |
145 |
|
146 |
$self->{'memory_cache'} = Cache::Memory->new( |
147 |
'namespace' => $self->{'namespace'}, |
148 |
'default_expires' => $self->{'timeout'} |
149 |
); |
150 |
return $self; |
151 |
} |
152 |
|
153 |
=head2 is_cache_active |
154 |
|
155 |
Routine that checks whether or not a caching system has been selected. This is |
156 |
not an instance method. |
157 |
|
158 |
=cut |
159 |
|
86 |
sub is_cache_active { |
160 |
sub is_cache_active { |
87 |
return $ENV{CACHING_SYSTEM} ? '1' : ''; |
161 |
return $ENV{CACHING_SYSTEM} ? '1' : ''; |
88 |
} |
162 |
} |
89 |
|
163 |
|
|
|
164 |
=head2 set_in_cache |
165 |
|
166 |
$cache->set_in_cache($key, $value, [$expiry]); |
167 |
|
168 |
Save a value to the specified key in the default cache, optionally with a |
169 |
particular expiry. |
170 |
|
171 |
=cut |
172 |
|
90 |
sub set_in_cache { |
173 |
sub set_in_cache { |
91 |
my ( $self, $key, $value, $expiry ) = @_; |
174 |
my ( $self, $key, $value, $expiry, $cache ) = @_; |
|
|
175 |
$cache ||= 'cache'; |
92 |
croak "No key" unless $key; |
176 |
croak "No key" unless $key; |
93 |
$ENV{DEBUG} && warn "set_in_cache for $key"; |
177 |
$ENV{DEBUG} && carp "set_in_cache for $key"; |
94 |
|
|
|
95 |
return unless $self->{cache}; |
96 |
return unless $self->{have_chi}; |
97 |
|
178 |
|
|
|
179 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
98 |
if ( defined $expiry ) { |
180 |
if ( defined $expiry ) { |
99 |
return $self->{cache}->set( $key, $value, $expiry ); |
181 |
if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) { |
|
|
182 |
$expiry = "$expiry sec"; |
183 |
} |
184 |
return $self->{$cache}->set( $key, $value, $expiry ); |
100 |
} |
185 |
} |
101 |
else { |
186 |
else { |
102 |
return $self->{cache}->set( $key, $value ); |
187 |
return $self->{$cache}->set( $key, $value ); |
103 |
} |
188 |
} |
104 |
} |
189 |
} |
105 |
|
190 |
|
|
|
191 |
=head2 get_from_cache |
192 |
|
193 |
my $value = $cache->get_from_cache($key); |
194 |
|
195 |
Retrieve the value stored under the specified key in the default cache. |
196 |
|
197 |
=cut |
198 |
|
106 |
sub get_from_cache { |
199 |
sub get_from_cache { |
107 |
my ( $self, $key ) = @_; |
200 |
my ( $self, $key, $cache ) = @_; |
|
|
201 |
$cache ||= 'cache'; |
108 |
croak "No key" unless $key; |
202 |
croak "No key" unless $key; |
109 |
$ENV{DEBUG} && warn "get_from_cache for $key"; |
203 |
$ENV{DEBUG} && carp "get_from_cache for $key"; |
110 |
return unless $self->{cache}; |
204 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
111 |
return unless $self->{have_chi}; |
205 |
return $self->{$cache}->get($key); |
112 |
return $self->{cache}->get($key); |
|
|
113 |
} |
206 |
} |
114 |
|
207 |
|
|
|
208 |
=head2 clear_from_cache |
209 |
|
210 |
$cache->clear_from_cache($key); |
211 |
|
212 |
Remove the value identified by the specified key from the default cache. |
213 |
|
214 |
=cut |
215 |
|
115 |
sub clear_from_cache { |
216 |
sub clear_from_cache { |
116 |
my ( $self, $key ) = @_; |
217 |
my ( $self, $key, $cache ) = @_; |
|
|
218 |
$cache ||= 'cache'; |
117 |
croak "No key" unless $key; |
219 |
croak "No key" unless $key; |
118 |
return unless $self->{cache}; |
220 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
119 |
return unless $self->{have_chi}; |
221 |
return $self->{$cache}->delete($key) |
120 |
return $self->{cache}->remove($key); |
222 |
if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); |
|
|
223 |
return $self->{$cache}->remove($key); |
121 |
} |
224 |
} |
122 |
|
225 |
|
|
|
226 |
=head2 flush_all |
227 |
|
228 |
$cache->flush_all(); |
229 |
|
230 |
Clear the entire default cache. |
231 |
|
232 |
=cut |
233 |
|
123 |
sub flush_all { |
234 |
sub flush_all { |
124 |
my $self = shift; |
235 |
my ( $self, $cache ) = shift; |
125 |
return unless $self->{cache}; |
236 |
$cache ||= 'cache'; |
126 |
return unless $self->{have_chi}; |
237 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
127 |
return $self->{cache}->clear(); |
238 |
return $self->{$cache}->flush_all() |
|
|
239 |
if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); |
240 |
return $self->{$cache}->clear(); |
241 |
} |
242 |
|
243 |
=head1 TIED INTERFACE |
244 |
|
245 |
Koha::Cache also provides a tied interface which enables users to provide a |
246 |
constructor closure and (after creation) treat cached data like normal reference |
247 |
variables and rely on the cache Just Working and getting updated when it |
248 |
expires, etc. |
249 |
|
250 |
my $cache = Koha::Cache->new(); |
251 |
my $data = 'whatever'; |
252 |
my $scalar = Koha::Cache->create_scalar( |
253 |
{ |
254 |
'key' => 'whatever', |
255 |
'timeout' => 2, |
256 |
'constructor' => sub { return $data; }, |
257 |
} |
258 |
); |
259 |
print "$$scalar\n"; # Prints "whatever" |
260 |
$data = 'somethingelse'; |
261 |
print "$$scalar\n"; # Prints "whatever" because it is cached |
262 |
sleep 2; # Wait until the cache entry has expired |
263 |
print "$$scalar\n"; # Prints "somethingelse" |
264 |
|
265 |
my $hash = Koha::Cache->create_hash( |
266 |
{ |
267 |
'key' => 'whatever', |
268 |
'timeout' => 2, |
269 |
'constructor' => sub { return $data; }, |
270 |
} |
271 |
); |
272 |
print "$$variable\n"; # Prints "whatever" |
273 |
|
274 |
The gotcha with this interface, of course, is that the variable returned by |
275 |
create_scalar and create_hash is a I<reference> to a tied variable and not a |
276 |
tied variable itself. |
277 |
|
278 |
The tied variable is configured by means of a hashref passed in to the |
279 |
create_scalar and create_hash methods. The following parameters are supported: |
280 |
|
281 |
=over |
282 |
|
283 |
=item I<key> |
284 |
|
285 |
Required. The key to use for identifying the variable in the cache. |
286 |
|
287 |
=item I<constructor> |
288 |
|
289 |
Required. A closure (or reference to a function) that will return the value that |
290 |
needs to be stored in the cache. |
291 |
|
292 |
=item I<preload> |
293 |
|
294 |
Optional. A closure (or reference to a function) that gets run to initialize |
295 |
the cache when creating the tied variable. |
296 |
|
297 |
=item I<arguments> |
298 |
|
299 |
Optional. Array reference with the arguments that should be passed to the |
300 |
constructor function. |
301 |
|
302 |
=item I<timeout> |
303 |
|
304 |
Optional. The cache timeout in seconds for the variable. Defaults to 600 |
305 |
(ten minutes). |
306 |
|
307 |
=item I<cache_type> |
308 |
|
309 |
Optional. Which type of cache to use for the variable. Defaults to whatever is |
310 |
set in the environment variable CACHING_SYSTEM. If set to 'null', disables |
311 |
caching for the tied variable. |
312 |
|
313 |
=item I<allowupdate> |
314 |
|
315 |
Optional. Boolean flag to allow the variable to be updated directly. When this |
316 |
is set and the variable is used as an l-value, the cache will be updated |
317 |
immediately with the new value. Using this is probably a bad idea on a |
318 |
multi-threaded system. When I<allowupdate> is not set to true, using the |
319 |
tied variable as an l-value will have no effect. |
320 |
|
321 |
=item I<destructor> |
322 |
|
323 |
Optional. A closure (or reference to a function) that should be called when the |
324 |
tied variable is destroyed. |
325 |
|
326 |
=item I<unset> |
327 |
|
328 |
Optional. Boolean flag to tell the object to remove the variable from the cache |
329 |
when it is destroyed or goes out of scope. |
330 |
|
331 |
=item I<inprocess> |
332 |
|
333 |
Optional. Boolean flag to tell the object not to refresh the variable from the |
334 |
cache every time the value is desired, but rather only when the I<local> copy |
335 |
of the variable is older than the timeout. |
336 |
|
337 |
=back |
338 |
|
339 |
=head2 create_scalar |
340 |
|
341 |
my $scalar = Koha::Cache->create_scalar(\%params); |
342 |
|
343 |
Create scalar tied to the cache. |
344 |
|
345 |
=cut |
346 |
|
347 |
sub create_scalar { |
348 |
my ( $self, $args ) = @_; |
349 |
|
350 |
$self->_set_tied_defaults($args); |
351 |
|
352 |
tie my $scalar, 'Koha::Cache::Object', $args; |
353 |
return \$scalar; |
354 |
} |
355 |
|
356 |
sub create_hash { |
357 |
my ( $self, $args ) = @_; |
358 |
|
359 |
$self->_set_tied_defaults($args); |
360 |
|
361 |
tie my %hash, 'Koha::Cache::Object', $args; |
362 |
return \%hash; |
363 |
} |
364 |
|
365 |
sub _set_tied_defaults { |
366 |
my ( $self, $args ) = @_; |
367 |
|
368 |
$args->{'timeout'} = '600' unless defined( $args->{'timeout'} ); |
369 |
$args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} ); |
370 |
unless ( lc( $args->{'cache_type'} ) eq 'null' ) { |
371 |
$args->{'cache'} = $self; |
372 |
$args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'}; |
373 |
} |
374 |
|
375 |
return $args; |
128 |
} |
376 |
} |
129 |
|
377 |
|
130 |
=head2 EXPORT |
378 |
=head1 EXPORT |
131 |
|
379 |
|
132 |
None by default. |
380 |
None by default. |
133 |
|
381 |
|
134 |
=head1 SEE ALSO |
382 |
=head1 SEE ALSO |
135 |
|
383 |
|
136 |
Koha::Cache::Memcached |
384 |
Koha::Cache::Object |
137 |
|
385 |
|
138 |
=head1 AUTHOR |
386 |
=head1 AUTHOR |
139 |
|
387 |
|