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 $self->{'timeout'} ||= 0;
77 # Should we continue to support MEMCACHED ENV vars?
78 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
79 my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
80 $self->{namespace} ||= C4::Context->config('memcached_namespace') || 'koha';
81 @servers = split /,/, C4::Context->config('memcached_servers') // ''
83 $self->{namespace} .= ":$subnamespace:";
85 if ( $self->{'default_type'} eq 'memcached'
86 && can_load( modules => { 'Cache::Memcached::Fast::Safe' => undef } )
87 && _initialize_memcached($self, @servers)
88 && defined( $self->{'memcached_cache'} ) )
90 $self->{'cache'} = $self->{'memcached_cache'};
98 sub _initialize_memcached {
99 my ($self, @servers) = @_;
101 return unless @servers;
103 # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
104 # so we force it on setting.
105 my $memcached = Cache::Memcached::Fast::Safe->new(
107 servers => \@servers,
108 compress_threshold => 10_000,
109 namespace => $self->{'namespace'},
114 # Ensure we can actually talk to the memcached server
115 my $ismemcached = $memcached->set('ismemcached','1');
116 unless ($ismemcached) {
117 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";
120 $self->{'memcached_cache'} = $memcached;
124 =head2 is_cache_active
126 Routine that checks whether or not a default caching method is active on this
131 sub is_cache_active {
133 return $self->{'cache'} ? 1 : 0;
138 $cache->set_in_cache($key, $value, [$options]);
140 Save a value to the specified key in the cache. A hashref of options may be
143 The possible options are:
149 Expiry time of this cached entry in seconds.
153 The cache object to use if you want to provide your own. It should be an
154 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
161 my ( $self, $key, $value, $options ) = @_;
163 my $unsafe = $options->{unsafe} || 0;
165 # the key mustn't contain whitespace (or control characters) for memcache
166 # but shouldn't be any harm in applying it globally.
167 $key =~ s/[\x00-\x20]/_/g;
169 my $cache = $options->{cache} || 'cache';
170 croak "No key" unless $key;
172 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
173 my $expiry = $options->{expiry};
174 $expiry //= $self->{timeout};
175 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
177 my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
179 # Set in L1 cache as a data structure
180 # We only save the frozen form: we do want to save $value in L1
181 # directly in order to protect it. And thawing now may not be
182 # needed, so improves performance.
183 $value = $L1_encoder->encode($value);
184 $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
187 # Set in L1 cache as a scalar; exit if we are caching an undef
188 $L1_cache{$self->{namespace}}{$key} = $value;
189 return if !defined $value;
193 # We consider an expiry of 0 to be infinite
196 ? $set_sub->( $key, $value, $expiry )
197 : $self->{$cache}->set( $key, $value, $expiry );
201 ? $set_sub->( $key, $value )
202 : $self->{$cache}->set( $key, $value );
206 =head2 get_from_cache
208 my $value = $cache->get_from_cache($key, [ $options ]);
210 Retrieve the value stored under the specified key in the cache.
212 The possible options are:
218 If set, this will avoid performing a deep copy of the item. This
219 means that it won't be safe if something later modifies the result of the
220 function. It should be used with caution, and could save processing time
221 in some situations where is safe to use it. Make sure you know what you are doing!
225 The cache object to use if you want to provide your own. It should be an
226 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
233 my ( $self, $key, $options ) = @_;
234 my $cache = $options->{cache} || 'cache';
235 my $unsafe = $options->{unsafe} || 0;
236 $key =~ s/[\x00-\x20]/_/g;
237 croak "No key" unless $key;
238 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
240 # Return L1 cache value if exists
241 if ( exists $L1_cache{$self->{namespace}}{$key} ) {
242 if (ref($L1_cache{$self->{namespace}}{$key})) {
244 # ONLY use thawed for unsafe calls !!!
245 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
246 return $L1_cache{$self->{namespace}}{$key}->{thawed};
248 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
251 # No need to thaw if it's a scalar
252 return $L1_cache{$self->{namespace}}{$key};
256 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
257 my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
259 return if ref($L2_value);
260 return unless (defined($L2_value) && length($L2_value) >= 4);
262 my $flag = substr($L2_value, -4, 4, '');
263 if ($flag eq '-CF0') {
265 $L1_cache{$self->{namespace}}{$key} = $L2_value;
267 } elsif ($flag eq '-CF1') {
268 # it's a frozen data structure
270 eval { $thawed = $L1_decoder->decode($L2_value); };
272 $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
273 # ONLY save thawed for unsafe calls !!!
274 $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
278 # Unknown value / data type returned from L2 cache
282 =head2 clear_from_cache
284 $cache->clear_from_cache($key);
286 Remove the value identified by the specified key from the default cache.
290 sub clear_from_cache {
291 my ( $self, $key, $cache ) = @_;
292 $key =~ s/[\x00-\x20]/_/g;
294 croak "No key" unless $key;
295 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
297 # Clear from L1 cache
298 delete $L1_cache{$self->{namespace}}{$key};
300 return $self->{$cache}->delete($key)
301 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
302 return $self->{$cache}->remove($key);
309 Clear the entire default cache.
314 my ( $self, $cache ) = shift;
316 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
318 $self->flush_L1_cache();
320 return $self->{$cache}->flush_all()
321 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
322 return $self->{$cache}->clear();
327 delete $L1_cache{$self->{namespace}};
330 =head1 TIED INTERFACE
332 Koha::Cache also provides a tied interface which enables users to provide a
333 constructor closure and (after creation) treat cached data like normal reference
334 variables and rely on the cache Just Working and getting updated when it
337 my $cache = Koha::Cache->new();
338 my $data = 'whatever';
339 my $scalar = Koha::Cache->create_scalar(
343 'constructor' => sub { return $data; },
346 print "$$scalar\n"; # Prints "whatever"
347 $data = 'somethingelse';
348 print "$$scalar\n"; # Prints "whatever" because it is cached
349 sleep 2; # Wait until the cache entry has expired
350 print "$$scalar\n"; # Prints "somethingelse"
352 my $hash = Koha::Cache->create_hash(
356 'constructor' => sub { return $data; },
359 print "$$variable\n"; # Prints "whatever"
361 The gotcha with this interface, of course, is that the variable returned by
362 create_scalar and create_hash is a I<reference> to a tied variable and not a
363 tied variable itself.
365 The tied variable is configured by means of a hashref passed in to the
366 create_scalar and create_hash methods. The following parameters are supported:
372 Required. The key to use for identifying the variable in the cache.
376 Required. A closure (or reference to a function) that will return the value that
377 needs to be stored in the cache.
381 Optional. A closure (or reference to a function) that gets run to initialize
382 the cache when creating the tied variable.
386 Optional. Array reference with the arguments that should be passed to the
387 constructor function.
391 Optional. The cache timeout in seconds for the variable. Defaults to 600
396 Optional. Which type of cache to use for the variable. Defaults to whatever is
397 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
398 caching for the tied variable.
402 Optional. Boolean flag to allow the variable to be updated directly. When this
403 is set and the variable is used as an l-value, the cache will be updated
404 immediately with the new value. Using this is probably a bad idea on a
405 multi-threaded system. When I<allowupdate> is not set to true, using the
406 tied variable as an l-value will have no effect.
410 Optional. A closure (or reference to a function) that should be called when the
411 tied variable is destroyed.
415 Optional. Boolean flag to tell the object to remove the variable from the cache
416 when it is destroyed or goes out of scope.
420 Optional. Boolean flag to tell the object not to refresh the variable from the
421 cache every time the value is desired, but rather only when the I<local> copy
422 of the variable is older than the timeout.
428 my $scalar = Koha::Cache->create_scalar(\%params);
430 Create scalar tied to the cache.
435 my ( $self, $args ) = @_;
437 $self->_set_tied_defaults($args);
439 tie my $scalar, 'Koha::Cache::Object', $args;
444 my ( $self, $args ) = @_;
446 $self->_set_tied_defaults($args);
448 tie my %hash, 'Koha::Cache::Object', $args;
452 sub _set_tied_defaults {
453 my ( $self, $args ) = @_;
455 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
456 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
457 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
458 $args->{'cache'} = $self;
459 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
475 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
476 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
477 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>