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});
30 # see also Koha::Caches->get_instance;
34 Koha caching routines. This class provides two interfaces for cache access.
35 The first, traditional OO interface provides the following functions:
44 use Module::Load::Conditional qw(can_load);
49 use Koha::Cache::Object;
52 use base qw(Class::Accessor);
54 __PACKAGE__->mk_ro_accessors(
55 qw( cache memcached_cache ));
58 our $L1_encoder = Sereal::Encoder->new;
59 our $L1_decoder = Sereal::Decoder->new;
63 Create a new Koha::Cache object. This is required for all cache-related functionality.
68 my ( $class, $self, $params ) = @_;
69 $self->{'default_type'} =
71 || $ENV{CACHING_SYSTEM} # DELME What about this?
74 my $subnamespace = $params->{subnamespace} // '';
76 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
78 $self->{'timeout'} ||= 0;
79 # Should we continue to support MEMCACHED ENV vars?
80 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
81 my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
82 $self->{namespace} ||= C4::Context->config('memcached_namespace') || 'koha';
83 @servers = split /,/, C4::Context->config('memcached_servers') // ''
85 $self->{namespace} .= ":$subnamespace:";
87 if ( $self->{'default_type'} eq 'memcached'
88 && can_load( modules => { 'Cache::Memcached::Fast::Safe' => undef } )
89 && _initialize_memcached($self, @servers)
90 && defined( $self->{'memcached_cache'} ) )
92 $self->{'cache'} = $self->{'memcached_cache'};
95 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
102 sub _initialize_memcached {
103 my ($self, @servers) = @_;
105 return unless @servers;
108 && carp "Memcached server settings: "
109 . join( ', ', @servers )
111 . $self->{'namespace'};
112 # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
113 # so we force it on setting.
114 my $memcached = Cache::Memcached::Fast::Safe->new(
116 servers => \@servers,
117 compress_threshold => 10_000,
118 namespace => $self->{'namespace'},
123 # Ensure we can actually talk to the memcached server
124 my $ismemcached = $memcached->set('ismemcached','1');
125 unless ($ismemcached) {
126 warn "\nConnection to the memcached servers '@servers' failed. Are the unix socket permissions set properly? Is the host reachable?\nIf you ignore this warning, you will face performance issues\n";
129 $self->{'memcached_cache'} = $memcached;
133 =head2 is_cache_active
135 Routine that checks whether or not a default caching method is active on this
140 sub is_cache_active {
142 return $self->{'cache'} ? 1 : 0;
147 $cache->set_in_cache($key, $value, [$options]);
149 Save a value to the specified key in the cache. A hashref of options may be
152 The possible options are:
158 Expiry time of this cached entry in seconds.
162 The cache object to use if you want to provide your own. It should be an
163 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
170 my ( $self, $key, $value, $options ) = @_;
172 my $unsafe = $options->{unsafe} || 0;
174 # the key mustn't contain whitespace (or control characters) for memcache
175 # but shouldn't be any harm in applying it globally.
176 $key =~ s/[\x00-\x20]/_/g;
178 my $cache = $options->{cache} || 'cache';
179 croak "No key" unless $key;
180 $ENV{DEBUG} && carp "set_in_cache for $key";
182 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
183 my $expiry = $options->{expiry};
184 $expiry //= $self->{timeout};
185 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
187 my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
189 # Set in L1 cache as a data structure
190 # We only save the frozen form: we do want to save $value in L1
191 # directly in order to protect it. And thawing now may not be
192 # needed, so improves performance.
193 $value = $L1_encoder->encode($value);
194 $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
197 # Set in L1 cache as a scalar; exit if we are caching an undef
198 $L1_cache{$self->{namespace}}{$key} = $value;
199 return if !defined $value;
203 # We consider an expiry of 0 to be infinite
206 ? $set_sub->( $key, $value, $expiry )
207 : $self->{$cache}->set( $key, $value, $expiry );
211 ? $set_sub->( $key, $value )
212 : $self->{$cache}->set( $key, $value );
216 =head2 get_from_cache
218 my $value = $cache->get_from_cache($key, [ $options ]);
220 Retrieve the value stored under the specified key in the cache.
222 The possible options are:
228 If set, this will avoid performing a deep copy of the item. This
229 means that it won't be safe if something later modifies the result of the
230 function. It should be used with caution, and could save processing time
231 in some situations where is safe to use it. Make sure you know what you are doing!
235 The cache object to use if you want to provide your own. It should be an
236 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
243 my ( $self, $key, $options ) = @_;
244 my $cache = $options->{cache} || 'cache';
245 my $unsafe = $options->{unsafe} || 0;
246 $key =~ s/[\x00-\x20]/_/g;
247 croak "No key" unless $key;
248 $ENV{DEBUG} && carp "get_from_cache for $key";
249 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
251 # Return L1 cache value if exists
252 if ( exists $L1_cache{$self->{namespace}}{$key} ) {
253 if (ref($L1_cache{$self->{namespace}}{$key})) {
255 # ONLY use thawed for unsafe calls !!!
256 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
257 return $L1_cache{$self->{namespace}}{$key}->{thawed};
259 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
262 # No need to thaw if it's a scalar
263 return $L1_cache{$self->{namespace}}{$key};
267 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
268 my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
270 return if ref($L2_value);
271 return unless (defined($L2_value) && length($L2_value) >= 4);
273 my $flag = substr($L2_value, -4, 4, '');
274 if ($flag eq '-CF0') {
276 $L1_cache{$self->{namespace}}{$key} = $L2_value;
278 } elsif ($flag eq '-CF1') {
279 # it's a frozen data structure
281 eval { $thawed = $L1_decoder->decode($L2_value); };
283 $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
284 # ONLY save thawed for unsafe calls !!!
285 $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
289 # Unknown value / data type returned from L2 cache
293 =head2 clear_from_cache
295 $cache->clear_from_cache($key);
297 Remove the value identified by the specified key from the default cache.
301 sub clear_from_cache {
302 my ( $self, $key, $cache ) = @_;
303 $key =~ s/[\x00-\x20]/_/g;
305 croak "No key" unless $key;
306 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
308 # Clear from L1 cache
309 delete $L1_cache{$self->{namespace}}{$key};
311 return $self->{$cache}->delete($key)
312 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
313 return $self->{$cache}->remove($key);
320 Clear the entire default cache.
325 my ( $self, $cache ) = shift;
327 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
329 $self->flush_L1_cache();
331 return $self->{$cache}->flush_all()
332 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
333 return $self->{$cache}->clear();
338 delete $L1_cache{$self->{namespace}};
341 =head1 TIED INTERFACE
343 Koha::Cache also provides a tied interface which enables users to provide a
344 constructor closure and (after creation) treat cached data like normal reference
345 variables and rely on the cache Just Working and getting updated when it
348 my $cache = Koha::Cache->new();
349 my $data = 'whatever';
350 my $scalar = Koha::Cache->create_scalar(
354 'constructor' => sub { return $data; },
357 print "$$scalar\n"; # Prints "whatever"
358 $data = 'somethingelse';
359 print "$$scalar\n"; # Prints "whatever" because it is cached
360 sleep 2; # Wait until the cache entry has expired
361 print "$$scalar\n"; # Prints "somethingelse"
363 my $hash = Koha::Cache->create_hash(
367 'constructor' => sub { return $data; },
370 print "$$variable\n"; # Prints "whatever"
372 The gotcha with this interface, of course, is that the variable returned by
373 create_scalar and create_hash is a I<reference> to a tied variable and not a
374 tied variable itself.
376 The tied variable is configured by means of a hashref passed in to the
377 create_scalar and create_hash methods. The following parameters are supported:
383 Required. The key to use for identifying the variable in the cache.
387 Required. A closure (or reference to a function) that will return the value that
388 needs to be stored in the cache.
392 Optional. A closure (or reference to a function) that gets run to initialize
393 the cache when creating the tied variable.
397 Optional. Array reference with the arguments that should be passed to the
398 constructor function.
402 Optional. The cache timeout in seconds for the variable. Defaults to 600
407 Optional. Which type of cache to use for the variable. Defaults to whatever is
408 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
409 caching for the tied variable.
413 Optional. Boolean flag to allow the variable to be updated directly. When this
414 is set and the variable is used as an l-value, the cache will be updated
415 immediately with the new value. Using this is probably a bad idea on a
416 multi-threaded system. When I<allowupdate> is not set to true, using the
417 tied variable as an l-value will have no effect.
421 Optional. A closure (or reference to a function) that should be called when the
422 tied variable is destroyed.
426 Optional. Boolean flag to tell the object to remove the variable from the cache
427 when it is destroyed or goes out of scope.
431 Optional. Boolean flag to tell the object not to refresh the variable from the
432 cache every time the value is desired, but rather only when the I<local> copy
433 of the variable is older than the timeout.
439 my $scalar = Koha::Cache->create_scalar(\%params);
441 Create scalar tied to the cache.
446 my ( $self, $args ) = @_;
448 $self->_set_tied_defaults($args);
450 tie my $scalar, 'Koha::Cache::Object', $args;
455 my ( $self, $args ) = @_;
457 $self->_set_tied_defaults($args);
459 tie my %hash, 'Koha::Cache::Object', $args;
463 sub _set_tied_defaults {
464 my ( $self, $args ) = @_;
466 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
467 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
468 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
469 $args->{'cache'} = $self;
470 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
486 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
487 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
488 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>