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 ( $self->{'default_type'} eq 'memcached'
88 && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
89 && _initialize_memcached($self)
90 && defined( $self->{'memcached_cache'} ) )
92 $self->{'cache'} = $self->{'memcached_cache'};
95 if ( $self->{'default_type'} eq 'fastmmap'
96 && defined( $ENV{GATEWAY_INTERFACE} )
97 && can_load( modules => { 'Cache::FastMmap' => undef } )
98 && _initialize_fastmmap($self)
99 && defined( $self->{'fastmmap_cache'} ) )
101 $self->{'cache'} = $self->{'fastmmap_cache'};
104 # Unless memcache or fastmmap has already been picked, use memory_cache
105 unless ( defined( $self->{'cache'} ) ) {
106 if ( can_load( modules => { 'Cache::Memory' => undef } )
107 && _initialize_memory($self) )
109 $self->{'cache'} = $self->{'memory_cache'};
113 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
120 sub _initialize_memcached {
123 split /,/, $self->{'cache_servers'}
124 ? $self->{'cache_servers'}
125 : ($ENV{MEMCACHED_SERVERS} || '');
129 && carp "Memcached server settings: "
130 . join( ', ', @servers )
132 . $self->{'namespace'};
133 # Cache::Memcached::Fast doesn't allow a default expire time to be set
134 # so we force it on setting.
135 my $memcached = Cache::Memcached::Fast->new(
137 servers => \@servers,
138 compress_threshold => 10_000,
139 namespace => $self->{'namespace'},
143 # Ensure we can actually talk to the memcached server
144 my $ismemcached = $memcached->set('ismemcached','1');
145 return $self unless $ismemcached;
146 $self->{'memcached_cache'} = $memcached;
150 sub _initialize_fastmmap {
152 my ($cache, $share_file);
154 # Temporary workaround to catch fatal errors when: C4::Context module
155 # is not loaded beforehand, or Cache::FastMmap init fails for whatever
156 # other reason (e.g. due to permission issues - see Bug 13431)
158 $share_file = join( '-',
159 "/tmp/sharefile-koha", $self->{'namespace'},
160 C4::Context->config('hostname'), C4::Context->config('database') );
162 $cache = Cache::FastMmap->new(
163 'share_file' => $share_file,
164 'expire_time' => $self->{'timeout'},
165 'unlink_on_exit' => 0,
169 warn "FastMmap cache initialization failed: $@";
172 return unless defined $cache;
173 $self->{'fastmmap_cache'} = $cache;
177 sub _initialize_memory {
180 # Default cache time for memory is _always_ short unless it's specially
181 # defined, to allow it to work reliably in a persistent environment.
182 my $cache = Cache::Memory->new(
183 'namespace' => $self->{'namespace'},
184 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
186 $self->{'memory_cache'} = $cache;
187 # Memory cache can't handle complex types for some reason, so we use its
188 # freeze and thaw functions.
189 $self->{ref($cache) . '_set'} = sub {
190 my ($key, $val, $exp) = @_;
191 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
192 $exp = "$exp sec" if defined $exp;
193 # Because we need to use freeze, it must be a reference type.
194 $cache->freeze($key, [$val], $exp);
196 $self->{ref($cache) . '_get'} = sub {
197 my $res = $cache->thaw(shift);
198 return unless defined $res;
204 =head2 is_cache_active
206 Routine that checks whether or not a default caching method is active on this
211 sub is_cache_active {
213 return $self->{'cache'} ? 1 : 0;
218 $cache->set_in_cache($key, $value, [$options]);
220 Save a value to the specified key in the cache. A hashref of options may be
223 The possible options are:
229 Expiry time of this cached entry in seconds.
233 If set, this will perform a deep copy of the item when it's retrieved. This
234 means that it'll be safe if something later modifies the result of the
235 function. Will be ignored in situations where the same behaviour comes from
236 the caching layer anyway.
240 The cache object to use if you want to provide your own. It should be an
241 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
248 my ( $self, $key, $value, $options, $_cache) = @_;
249 # This is a bit of a hack to support the old API in case things still use it
250 if (defined $options && (ref($options) ne 'HASH')) {
252 $new_options->{expiry} = $options;
253 $new_options->{cache} = $_cache if defined $_cache;
254 $options = $new_options;
257 # the key mustn't contain whitespace (or control characters) for memcache
258 # but shouldn't be any harm in applying it globally.
259 $key =~ s/[\x00-\x20]/_/g;
261 my $cache = $options->{cache} || 'cache';
262 croak "No key" unless $key;
263 $ENV{DEBUG} && carp "set_in_cache for $key";
265 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
266 my $expiry = $options->{expiry};
267 $expiry //= $self->{timeout};
268 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
271 $L1_cache{ $key } = $value;
273 # We consider an expiry of 0 to be inifinite
276 ? $set_sub->( $key, $value, $expiry )
277 : $self->{$cache}->set( $key, $value, $expiry );
281 ? $set_sub->( $key, $value )
282 : $self->{$cache}->set( $key, $value );
286 =head2 get_from_cache
288 my $value = $cache->get_from_cache($key, [ $options ]);
290 Retrieve the value stored under the specified key in the default cache.
292 The options can set an unsafe flag to avoid a deep copy.
293 When this flag is set, you have to know what you are doing!
294 If you are retrieving a structure and modify it, you will modify the contain
300 my ( $self, $key, $options ) = @_;
301 my $cache = $options->{cache} || 'cache';
302 my $unsafe = $options->{unsafe} || 0;
303 $key =~ s/[\x00-\x20]/_/g;
304 croak "No key" unless $key;
305 $ENV{DEBUG} && carp "get_from_cache for $key";
306 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
308 # Return L1 cache value if exists
309 if ( exists $L1_cache{$key} ) {
310 # No need to deep copy if it's a scalar
311 # Or if we do not need to deep copy
312 return $L1_cache{$key}
313 if not ref $L1_cache{$key} or $unsafe;
314 return clone $L1_cache{$key};
317 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
318 my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
320 # Update the L1 cache when fetching the L2 cache
321 # Otherwise the L1 cache won't ever be populated
322 $L1_cache{$key} = $value;
324 $value = clone $value if ref $L1_cache{$key} and not $unsafe;
329 =head2 clear_from_cache
331 $cache->clear_from_cache($key);
333 Remove the value identified by the specified key from the default cache.
337 sub clear_from_cache {
338 my ( $self, $key, $cache ) = @_;
339 $key =~ s/[\x00-\x20]/_/g;
341 croak "No key" unless $key;
342 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
344 # Clear from L1 cache
345 delete $L1_cache{$key};
347 return $self->{$cache}->delete($key)
348 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
349 return $self->{$cache}->remove($key);
356 Clear the entire default cache.
361 my ( $self, $cache ) = shift;
363 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
365 $self->flush_L1_cache();
367 return $self->{$cache}->flush_all()
368 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
369 return $self->{$cache}->clear();
377 =head1 TIED INTERFACE
379 Koha::Cache also provides a tied interface which enables users to provide a
380 constructor closure and (after creation) treat cached data like normal reference
381 variables and rely on the cache Just Working and getting updated when it
384 my $cache = Koha::Cache->new();
385 my $data = 'whatever';
386 my $scalar = Koha::Cache->create_scalar(
390 'constructor' => sub { return $data; },
393 print "$$scalar\n"; # Prints "whatever"
394 $data = 'somethingelse';
395 print "$$scalar\n"; # Prints "whatever" because it is cached
396 sleep 2; # Wait until the cache entry has expired
397 print "$$scalar\n"; # Prints "somethingelse"
399 my $hash = Koha::Cache->create_hash(
403 'constructor' => sub { return $data; },
406 print "$$variable\n"; # Prints "whatever"
408 The gotcha with this interface, of course, is that the variable returned by
409 create_scalar and create_hash is a I<reference> to a tied variable and not a
410 tied variable itself.
412 The tied variable is configured by means of a hashref passed in to the
413 create_scalar and create_hash methods. The following parameters are supported:
419 Required. The key to use for identifying the variable in the cache.
423 Required. A closure (or reference to a function) that will return the value that
424 needs to be stored in the cache.
428 Optional. A closure (or reference to a function) that gets run to initialize
429 the cache when creating the tied variable.
433 Optional. Array reference with the arguments that should be passed to the
434 constructor function.
438 Optional. The cache timeout in seconds for the variable. Defaults to 600
443 Optional. Which type of cache to use for the variable. Defaults to whatever is
444 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
445 caching for the tied variable.
449 Optional. Boolean flag to allow the variable to be updated directly. When this
450 is set and the variable is used as an l-value, the cache will be updated
451 immediately with the new value. Using this is probably a bad idea on a
452 multi-threaded system. When I<allowupdate> is not set to true, using the
453 tied variable as an l-value will have no effect.
457 Optional. A closure (or reference to a function) that should be called when the
458 tied variable is destroyed.
462 Optional. Boolean flag to tell the object to remove the variable from the cache
463 when it is destroyed or goes out of scope.
467 Optional. Boolean flag to tell the object not to refresh the variable from the
468 cache every time the value is desired, but rather only when the I<local> copy
469 of the variable is older than the timeout.
475 my $scalar = Koha::Cache->create_scalar(\%params);
477 Create scalar tied to the cache.
482 my ( $self, $args ) = @_;
484 $self->_set_tied_defaults($args);
486 tie my $scalar, 'Koha::Cache::Object', $args;
491 my ( $self, $args ) = @_;
493 $self->_set_tied_defaults($args);
495 tie my %hash, 'Koha::Cache::Object', $args;
499 sub _set_tied_defaults {
500 my ( $self, $args ) = @_;
502 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
503 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
504 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
505 $args->{'cache'} = $self;
506 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
522 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
523 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
524 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>