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 Module::Load::Conditional qw(can_load);
42 use Koha::Cache::Object;
46 use base qw(Class::Accessor);
48 __PACKAGE__->mk_ro_accessors(
49 qw( cache memcached_cache fastmmap_cache memory_cache ));
52 our $L1_encoder = Sereal::Encoder->new;
53 our $L1_decoder = Sereal::Decoder->new;
57 my $cache = Koha::Cache->get_instance();
59 This gets a shared instance of the cache, set up in a very default way. This is
60 the recommended way to fetch a cache object. If possible, it'll be
61 persistent across multiple instances.
68 $singleton_cache = $class->new() unless $singleton_cache;
69 return $singleton_cache;
74 Create a new Koha::Cache object. This is required for all cache-related functionality.
79 my ( $class, $self ) = @_;
80 $self->{'default_type'} =
82 || $ENV{CACHING_SYSTEM}
85 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
87 $self->{'timeout'} ||= 0;
88 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
90 if ( $self->{'default_type'} eq 'memcached'
91 && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
92 && _initialize_memcached($self)
93 && defined( $self->{'memcached_cache'} ) )
95 $self->{'cache'} = $self->{'memcached_cache'};
98 if ( $self->{'default_type'} eq 'fastmmap'
99 && defined( $ENV{GATEWAY_INTERFACE} )
100 && can_load( modules => { 'Cache::FastMmap' => undef } )
101 && _initialize_fastmmap($self)
102 && defined( $self->{'fastmmap_cache'} ) )
104 $self->{'cache'} = $self->{'fastmmap_cache'};
107 # Unless memcache or fastmmap has already been picked, use memory_cache
108 unless ( defined( $self->{'cache'} ) ) {
109 if ( can_load( modules => { 'Cache::Memory' => undef } )
110 && _initialize_memory($self) )
112 $self->{'cache'} = $self->{'memory_cache'};
116 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
123 sub _initialize_memcached {
126 split /,/, $self->{'cache_servers'}
127 ? $self->{'cache_servers'}
128 : ($ENV{MEMCACHED_SERVERS} || '');
132 && carp "Memcached server settings: "
133 . join( ', ', @servers )
135 . $self->{'namespace'};
136 # Cache::Memcached::Fast doesn't allow a default expire time to be set
137 # so we force it on setting.
138 my $memcached = Cache::Memcached::Fast->new(
140 servers => \@servers,
141 compress_threshold => 10_000,
142 namespace => $self->{'namespace'},
146 # Ensure we can actually talk to the memcached server
147 my $ismemcached = $memcached->set('ismemcached','1');
148 return $self unless $ismemcached;
149 $self->{'memcached_cache'} = $memcached;
153 sub _initialize_fastmmap {
155 my ($cache, $share_file);
157 # Temporary workaround to catch fatal errors when: C4::Context module
158 # is not loaded beforehand, or Cache::FastMmap init fails for whatever
159 # other reason (e.g. due to permission issues - see Bug 13431)
161 $share_file = join( '-',
162 "/tmp/sharefile-koha", $self->{'namespace'},
163 C4::Context->config('hostname'), C4::Context->config('database') );
165 $cache = Cache::FastMmap->new(
166 'share_file' => $share_file,
167 'expire_time' => $self->{'timeout'},
168 'unlink_on_exit' => 0,
172 warn "FastMmap cache initialization failed: $@";
175 return unless defined $cache;
176 $self->{'fastmmap_cache'} = $cache;
180 sub _initialize_memory {
183 # Default cache time for memory is _always_ short unless it's specially
184 # defined, to allow it to work reliably in a persistent environment.
185 my $cache = Cache::Memory->new(
186 'namespace' => $self->{'namespace'},
187 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
189 $self->{'memory_cache'} = $cache;
190 # Memory cache can't handle complex types for some reason, so we use its
191 # freeze and thaw functions.
192 $self->{ref($cache) . '_set'} = sub {
193 my ($key, $val, $exp) = @_;
194 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
195 $exp = "$exp sec" if defined $exp;
196 # Because we need to use freeze, it must be a reference type.
197 $cache->freeze($key, [$val], $exp);
199 $self->{ref($cache) . '_get'} = sub {
200 my $res = $cache->thaw(shift);
201 return unless defined $res;
207 =head2 is_cache_active
209 Routine that checks whether or not a default caching method is active on this
214 sub is_cache_active {
216 return $self->{'cache'} ? 1 : 0;
221 $cache->set_in_cache($key, $value, [$options]);
223 Save a value to the specified key in the cache. A hashref of options may be
226 The possible options are:
232 Expiry time of this cached entry in seconds.
236 The cache object to use if you want to provide your own. It should be an
237 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
244 my ( $self, $key, $value, $options, $_cache) = @_;
245 # This is a bit of a hack to support the old API in case things still use it
246 if (defined $options && (ref($options) ne 'HASH')) {
248 $new_options->{expiry} = $options;
249 $new_options->{cache} = $_cache if defined $_cache;
250 $options = $new_options;
253 # the key mustn't contain whitespace (or control characters) for memcache
254 # but shouldn't be any harm in applying it globally.
255 $key =~ s/[\x00-\x20]/_/g;
257 my $cache = $options->{cache} || 'cache';
258 croak "No key" unless $key;
259 $ENV{DEBUG} && carp "set_in_cache for $key";
261 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
262 my $expiry = $options->{expiry};
263 $expiry //= $self->{timeout};
264 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
266 my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
268 # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
269 $value = $L1_encoder->encode($value);
270 $L1_cache{$key}->{frozen} = $value;
273 # Set in L1 cache as a scalar; exit if we are caching an undef
274 $L1_cache{$key} = $value;
275 return if !defined $value;
279 # We consider an expiry of 0 to be inifinite
282 ? $set_sub->( $key, $value, $expiry )
283 : $self->{$cache}->set( $key, $value, $expiry );
287 ? $set_sub->( $key, $value )
288 : $self->{$cache}->set( $key, $value );
292 =head2 get_from_cache
294 my $value = $cache->get_from_cache($key, [ $options ]);
296 Retrieve the value stored under the specified key in the cache.
298 The possible options are:
304 If set, this will avoid performing a deep copy of the item. This
305 means that it won't be safe if something later modifies the result of the
306 function. It should be used with caution, and could save processing time
307 in some situations where is safe to use it. Make sure you know what you are doing!
311 The cache object to use if you want to provide your own. It should be an
312 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
319 my ( $self, $key, $options ) = @_;
320 my $cache = $options->{cache} || 'cache';
321 my $unsafe = $options->{unsafe} || 0;
322 $key =~ s/[\x00-\x20]/_/g;
323 croak "No key" unless $key;
324 $ENV{DEBUG} && carp "get_from_cache for $key";
325 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
327 # Return L1 cache value if exists
328 if ( exists $L1_cache{$key} ) {
329 if (ref($L1_cache{$key})) {
331 $L1_cache{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$key}->{frozen});
332 return $L1_cache{$key}->{thawed};
334 return $L1_decoder->decode($L1_cache{$key}->{frozen});
337 # No need to thaw if it's a scalar
338 return $L1_cache{$key};
342 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
343 my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
345 return if ref($L2_value);
346 return unless (defined($L2_value) && length($L2_value) >= 4);
348 my $flag = substr($L2_value, -4, 4, '');
349 if ($flag eq '-CF0') {
351 $L1_cache{$key} = $L2_value;
353 } elsif ($flag eq '-CF1') {
354 # it's a frozen data structure
356 eval { $thawed = $L1_decoder->decode($L2_value); };
358 $L1_cache{$key}->{frozen} = $L2_value;
359 $L1_cache{$key}->{thawed} = $thawed if $unsafe;
363 # Unknown value / data type returned from L2 cache
367 =head2 clear_from_cache
369 $cache->clear_from_cache($key);
371 Remove the value identified by the specified key from the default cache.
375 sub clear_from_cache {
376 my ( $self, $key, $cache ) = @_;
377 $key =~ s/[\x00-\x20]/_/g;
379 croak "No key" unless $key;
380 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
382 # Clear from L1 cache
383 delete $L1_cache{$key};
385 return $self->{$cache}->delete($key)
386 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
387 return $self->{$cache}->remove($key);
394 Clear the entire default cache.
399 my ( $self, $cache ) = shift;
401 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
403 $self->flush_L1_cache();
405 return $self->{$cache}->flush_all()
406 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
407 return $self->{$cache}->clear();
415 =head1 TIED INTERFACE
417 Koha::Cache also provides a tied interface which enables users to provide a
418 constructor closure and (after creation) treat cached data like normal reference
419 variables and rely on the cache Just Working and getting updated when it
422 my $cache = Koha::Cache->new();
423 my $data = 'whatever';
424 my $scalar = Koha::Cache->create_scalar(
428 'constructor' => sub { return $data; },
431 print "$$scalar\n"; # Prints "whatever"
432 $data = 'somethingelse';
433 print "$$scalar\n"; # Prints "whatever" because it is cached
434 sleep 2; # Wait until the cache entry has expired
435 print "$$scalar\n"; # Prints "somethingelse"
437 my $hash = Koha::Cache->create_hash(
441 'constructor' => sub { return $data; },
444 print "$$variable\n"; # Prints "whatever"
446 The gotcha with this interface, of course, is that the variable returned by
447 create_scalar and create_hash is a I<reference> to a tied variable and not a
448 tied variable itself.
450 The tied variable is configured by means of a hashref passed in to the
451 create_scalar and create_hash methods. The following parameters are supported:
457 Required. The key to use for identifying the variable in the cache.
461 Required. A closure (or reference to a function) that will return the value that
462 needs to be stored in the cache.
466 Optional. A closure (or reference to a function) that gets run to initialize
467 the cache when creating the tied variable.
471 Optional. Array reference with the arguments that should be passed to the
472 constructor function.
476 Optional. The cache timeout in seconds for the variable. Defaults to 600
481 Optional. Which type of cache to use for the variable. Defaults to whatever is
482 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
483 caching for the tied variable.
487 Optional. Boolean flag to allow the variable to be updated directly. When this
488 is set and the variable is used as an l-value, the cache will be updated
489 immediately with the new value. Using this is probably a bad idea on a
490 multi-threaded system. When I<allowupdate> is not set to true, using the
491 tied variable as an l-value will have no effect.
495 Optional. A closure (or reference to a function) that should be called when the
496 tied variable is destroyed.
500 Optional. Boolean flag to tell the object to remove the variable from the cache
501 when it is destroyed or goes out of scope.
505 Optional. Boolean flag to tell the object not to refresh the variable from the
506 cache every time the value is desired, but rather only when the I<local> copy
507 of the variable is older than the timeout.
513 my $scalar = Koha::Cache->create_scalar(\%params);
515 Create scalar tied to the cache.
520 my ( $self, $args ) = @_;
522 $self->_set_tied_defaults($args);
524 tie my $scalar, 'Koha::Cache::Object', $args;
529 my ( $self, $args ) = @_;
531 $self->_set_tied_defaults($args);
533 tie my %hash, 'Koha::Cache::Object', $args;
537 sub _set_tied_defaults {
538 my ( $self, $args ) = @_;
540 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
541 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
542 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
543 $args->{'cache'} = $self;
544 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
560 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
561 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
562 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>