3 # Copyright 2009 Chris Cormack and The Koha Dev Team
4 # Parts copyright 2012-2013 C & P Bibliography Services
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it
9 # under the terms of the GNU General Public License as published by
10 # the Free Software Foundation; either version 3 of the License, or
11 # (at your option) any later version.
13 # Koha is distributed in the hope that it will be useful, but
14 # WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
23 Koha::Cache - Handling caching of html and Objects for Koha
28 my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
32 Koha caching routines. This class provides two interfaces for cache access.
33 The first, traditional OO interface provides the following functions:
41 use Clone qw( clone );
42 use Module::Load::Conditional qw(can_load);
43 use Koha::Cache::Object;
45 use base qw(Class::Accessor);
47 __PACKAGE__->mk_ro_accessors(
48 qw( cache memcached_cache fastmmap_cache memory_cache ));
54 my $cache = Koha::Cache->get_instance();
56 This gets a shared instance of the cache, set up in a very default way. This is
57 the recommended way to fetch a cache object. If possible, it'll be
58 persistent across multiple instances.
65 $singleton_cache = $class->new() unless $singleton_cache;
66 return $singleton_cache;
71 Create a new Koha::Cache object. This is required for all cache-related functionality.
76 my ( $class, $self ) = @_;
77 $self->{'default_type'} =
79 || $ENV{CACHING_SYSTEM}
82 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
84 $self->{'timeout'} ||= 0;
85 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
87 if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
88 _initialize_memcached($self);
89 if ( $self->{'default_type'} eq 'memcached'
90 && defined( $self->{'memcached_cache'} ) )
92 $self->{'cache'} = $self->{'memcached_cache'};
96 if ( $self->{'default_type'} eq 'fastmmap'
97 && defined( $ENV{GATEWAY_INTERFACE} )
98 && can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
99 _initialize_fastmmap($self);
100 if ( defined( $self->{'fastmmap_cache'} ) )
102 $self->{'cache'} = $self->{'fastmmap_cache'};
106 if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
107 _initialize_memory($self);
108 if ( $self->{'default_type'} eq 'memory'
109 && defined( $self->{'memory_cache'} ) )
111 $self->{'cache'} = $self->{'memory_cache'};
115 # Unless a default has already been picked, we go through in best-to-
116 # least-best order, looking for something we can use. fastmmap_cache
117 # is excluded because it doesn't support expiry in a useful way.
118 unless ( defined( $self->{'cache'} ) ) {
119 foreach my $cachemember (qw(memcached_cache memory_cache )) {
120 if ( defined( $self->{$cachemember} ) ) {
121 $self->{'cache'} = $self->{$cachemember};
127 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
134 sub _initialize_memcached {
137 split /,/, $self->{'cache_servers'}
138 ? $self->{'cache_servers'}
139 : ($ENV{MEMCACHED_SERVERS} || '');
143 && carp "Memcached server settings: "
144 . join( ', ', @servers )
146 . $self->{'namespace'};
147 # Cache::Memcached::Fast doesn't allow a default expire time to be set
148 # so we force it on setting.
149 my $memcached = Cache::Memcached::Fast->new(
151 servers => \@servers,
152 compress_threshold => 10_000,
153 namespace => $self->{'namespace'},
157 # Ensure we can actually talk to the memcached server
158 my $ismemcached = $memcached->set('ismemcached','1');
159 return $self unless $ismemcached;
160 $self->{'memcached_cache'} = $memcached;
164 sub _initialize_fastmmap {
166 my ($cache, $share_file);
168 # Temporary workaround to catch fatal errors when: C4::Context module
169 # is not loaded beforehand, or Cache::FastMmap init fails for whatever
170 # other reason (e.g. due to permission issues - see Bug 13431)
172 $share_file = join( '-',
173 "/tmp/sharefile-koha", $self->{'namespace'},
174 C4::Context->config('hostname'), C4::Context->config('database') );
176 $cache = Cache::FastMmap->new(
177 'share_file' => $share_file,
178 'expire_time' => $self->{'timeout'},
179 'unlink_on_exit' => 0,
183 warn "FastMmap cache initialization failed: $@";
186 return unless defined $cache;
187 $self->{'fastmmap_cache'} = $cache;
191 sub _initialize_memory {
194 # Default cache time for memory is _always_ short unless it's specially
195 # defined, to allow it to work reliably in a persistent environment.
196 my $cache = Cache::Memory->new(
197 'namespace' => $self->{'namespace'},
198 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
200 $self->{'memory_cache'} = $cache;
201 # Memory cache can't handle complex types for some reason, so we use its
202 # freeze and thaw functions.
203 $self->{ref($cache) . '_set'} = sub {
204 my ($key, $val, $exp) = @_;
205 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
206 $exp = "$exp sec" if defined $exp;
207 # Because we need to use freeze, it must be a reference type.
208 $cache->freeze($key, [$val], $exp);
210 $self->{ref($cache) . '_get'} = sub {
211 my $res = $cache->thaw(shift);
212 return unless defined $res;
218 =head2 is_cache_active
220 Routine that checks whether or not a default caching method is active on this
225 sub is_cache_active {
227 return $self->{'cache'} ? 1 : 0;
232 $cache->set_in_cache($key, $value, [$options]);
234 Save a value to the specified key in the cache. A hashref of options may be
237 The possible options are:
243 Expiry time of this cached entry in seconds.
247 If set, this will perform a deep copy of the item when it's retrieved. This
248 means that it'll be safe if something later modifies the result of the
249 function. Will be ignored in situations where the same behaviour comes from
250 the caching layer anyway.
254 The cache object to use if you want to provide your own. It should be an
255 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
262 my ( $self, $key, $value, $options, $_cache) = @_;
263 # This is a bit of a hack to support the old API in case things still use it
264 if (defined $options && (ref($options) ne 'HASH')) {
266 $new_options->{expiry} = $options;
267 $new_options->{cache} = $_cache if defined $_cache;
268 $options = $new_options;
270 my $unsafe = $options->{unsafe} || 0;
272 # the key mustn't contain whitespace (or control characters) for memcache
273 # but shouldn't be any harm in applying it globally.
274 $key =~ s/[\x00-\x20]/_/g;
276 my $cache = $options->{cache} || 'cache';
277 croak "No key" unless $key;
278 $ENV{DEBUG} && carp "set_in_cache for $key";
280 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
281 my $expiry = $options->{expiry};
282 $expiry //= $self->{timeout};
283 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
285 # Deep copy if it's not a scalar and unsafe is not passed
286 $value = clone( $value ) if ref($value) and not $unsafe;
289 $L1_cache{ $key } = $value;
291 # We consider an expiry of 0 to be inifinite
294 ? $set_sub->( $key, $value, $expiry )
295 : $self->{$cache}->set( $key, $value, $expiry );
299 ? $set_sub->( $key, $value )
300 : $self->{$cache}->set( $key, $value );
304 =head2 get_from_cache
306 my $value = $cache->get_from_cache($key, [ $options ]);
308 Retrieve the value stored under the specified key in the default cache.
310 The options can set an unsafe flag to avoid a deep copy.
311 When this flag is set, you have to know what you are doing!
312 If you are retrieving a structure and modify it, you will modify the contain
318 my ( $self, $key, $options ) = @_;
319 my $cache = $options->{cache} || 'cache';
320 my $unsafe = $options->{unsafe} || 0;
321 $key =~ s/[\x00-\x20]/_/g;
322 croak "No key" unless $key;
323 $ENV{DEBUG} && carp "get_from_cache for $key";
324 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
326 # Return L1 cache value if exists
327 if ( exists $L1_cache{$key} ) {
328 # No need to deep copy if it's a scalar
329 # Or if we do not need to deep copy
330 return $L1_cache{$key}
331 if not ref $L1_cache{$key} or $unsafe;
332 return clone $L1_cache{$key};
335 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
336 my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
338 # Update the L1 cache when fetching the L2 cache
339 # Otherwise the L1 cache won't ever be populated
340 $L1_cache{$key} = $value;
342 $value = clone $value if ref $L1_cache{$key} and not $unsafe;
347 =head2 clear_from_cache
349 $cache->clear_from_cache($key);
351 Remove the value identified by the specified key from the default cache.
355 sub clear_from_cache {
356 my ( $self, $key, $cache ) = @_;
357 $key =~ s/[\x00-\x20]/_/g;
359 croak "No key" unless $key;
360 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
362 # Clear from L1 cache
363 delete $L1_cache{$key};
365 return $self->{$cache}->delete($key)
366 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
367 return $self->{$cache}->remove($key);
374 Clear the entire default cache.
379 my ( $self, $cache ) = shift;
381 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
383 $self->flush_L1_cache();
385 return $self->{$cache}->flush_all()
386 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
387 return $self->{$cache}->clear();
395 =head1 TIED INTERFACE
397 Koha::Cache also provides a tied interface which enables users to provide a
398 constructor closure and (after creation) treat cached data like normal reference
399 variables and rely on the cache Just Working and getting updated when it
402 my $cache = Koha::Cache->new();
403 my $data = 'whatever';
404 my $scalar = Koha::Cache->create_scalar(
408 'constructor' => sub { return $data; },
411 print "$$scalar\n"; # Prints "whatever"
412 $data = 'somethingelse';
413 print "$$scalar\n"; # Prints "whatever" because it is cached
414 sleep 2; # Wait until the cache entry has expired
415 print "$$scalar\n"; # Prints "somethingelse"
417 my $hash = Koha::Cache->create_hash(
421 'constructor' => sub { return $data; },
424 print "$$variable\n"; # Prints "whatever"
426 The gotcha with this interface, of course, is that the variable returned by
427 create_scalar and create_hash is a I<reference> to a tied variable and not a
428 tied variable itself.
430 The tied variable is configured by means of a hashref passed in to the
431 create_scalar and create_hash methods. The following parameters are supported:
437 Required. The key to use for identifying the variable in the cache.
441 Required. A closure (or reference to a function) that will return the value that
442 needs to be stored in the cache.
446 Optional. A closure (or reference to a function) that gets run to initialize
447 the cache when creating the tied variable.
451 Optional. Array reference with the arguments that should be passed to the
452 constructor function.
456 Optional. The cache timeout in seconds for the variable. Defaults to 600
461 Optional. Which type of cache to use for the variable. Defaults to whatever is
462 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
463 caching for the tied variable.
467 Optional. Boolean flag to allow the variable to be updated directly. When this
468 is set and the variable is used as an l-value, the cache will be updated
469 immediately with the new value. Using this is probably a bad idea on a
470 multi-threaded system. When I<allowupdate> is not set to true, using the
471 tied variable as an l-value will have no effect.
475 Optional. A closure (or reference to a function) that should be called when the
476 tied variable is destroyed.
480 Optional. Boolean flag to tell the object to remove the variable from the cache
481 when it is destroyed or goes out of scope.
485 Optional. Boolean flag to tell the object not to refresh the variable from the
486 cache every time the value is desired, but rather only when the I<local> copy
487 of the variable is older than the timeout.
493 my $scalar = Koha::Cache->create_scalar(\%params);
495 Create scalar tied to the cache.
500 my ( $self, $args ) = @_;
502 $self->_set_tied_defaults($args);
504 tie my $scalar, 'Koha::Cache::Object', $args;
509 my ( $self, $args ) = @_;
511 $self->_set_tied_defaults($args);
513 tie my %hash, 'Koha::Cache::Object', $args;
517 sub _set_tied_defaults {
518 my ( $self, $args ) = @_;
520 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
521 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
522 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
523 $args->{'cache'} = $self;
524 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
540 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
541 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
542 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>