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);
48 use Koha::Cache::Object;
51 use base qw(Class::Accessor);
53 __PACKAGE__->mk_ro_accessors(
54 qw( cache memcached_cache ));
57 our $L1_encoder = Sereal::Encoder->new;
58 our $L1_decoder = Sereal::Decoder->new;
62 Create a new Koha::Cache object. This is required for all cache-related functionality.
67 my ( $class, $self, $params ) = @_;
68 $self->{'default_type'} =
70 || $ENV{CACHING_SYSTEM} # DELME What about this?
73 my $subnamespace = $params->{subnamespace} // '';
75 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
77 $self->{'timeout'} ||= 0;
78 # Should we continue to support MEMCACHED ENV vars?
79 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
80 my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
81 unless ( $self->{namespace} and @servers ) {
82 my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
83 $self->{namespace} ||= $koha_config->{config}{memcached_namespace} || 'koha';
84 @servers = split /,/, $koha_config->{config}{memcached_servers} // ''
87 $self->{namespace} .= ":$subnamespace:";
89 if ( $self->{'default_type'} eq 'memcached'
90 && can_load( modules => { 'Cache::Memcached::Fast::Safe' => undef } )
91 && _initialize_memcached($self, @servers)
92 && defined( $self->{'memcached_cache'} ) )
94 $self->{'cache'} = $self->{'memcached_cache'};
97 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
104 sub _initialize_memcached {
105 my ($self, @servers) = @_;
107 return unless @servers;
110 && carp "Memcached server settings: "
111 . join( ', ', @servers )
113 . $self->{'namespace'};
114 # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
115 # so we force it on setting.
116 my $memcached = Cache::Memcached::Fast::Safe->new(
118 servers => \@servers,
119 compress_threshold => 10_000,
120 namespace => $self->{'namespace'},
125 # Ensure we can actually talk to the memcached server
126 my $ismemcached = $memcached->set('ismemcached','1');
127 unless ($ismemcached) {
128 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";
131 $self->{'memcached_cache'} = $memcached;
135 =head2 is_cache_active
137 Routine that checks whether or not a default caching method is active on this
142 sub is_cache_active {
144 return $self->{'cache'} ? 1 : 0;
149 $cache->set_in_cache($key, $value, [$options]);
151 Save a value to the specified key in the cache. A hashref of options may be
154 The possible options are:
160 Expiry time of this cached entry in seconds.
164 The cache object to use if you want to provide your own. It should be an
165 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
172 my ( $self, $key, $value, $options ) = @_;
174 my $unsafe = $options->{unsafe} || 0;
176 # the key mustn't contain whitespace (or control characters) for memcache
177 # but shouldn't be any harm in applying it globally.
178 $key =~ s/[\x00-\x20]/_/g;
180 my $cache = $options->{cache} || 'cache';
181 croak "No key" unless $key;
182 $ENV{DEBUG} && carp "set_in_cache for $key";
184 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
185 my $expiry = $options->{expiry};
186 $expiry //= $self->{timeout};
187 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
189 my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
191 # Set in L1 cache as a data structure
192 # We only save the frozen form: we do want to save $value in L1
193 # directly in order to protect it. And thawing now may not be
194 # needed, so improves performance.
195 $value = $L1_encoder->encode($value);
196 $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
199 # Set in L1 cache as a scalar; exit if we are caching an undef
200 $L1_cache{$self->{namespace}}{$key} = $value;
201 return if !defined $value;
205 # We consider an expiry of 0 to be infinite
208 ? $set_sub->( $key, $value, $expiry )
209 : $self->{$cache}->set( $key, $value, $expiry );
213 ? $set_sub->( $key, $value )
214 : $self->{$cache}->set( $key, $value );
218 =head2 get_from_cache
220 my $value = $cache->get_from_cache($key, [ $options ]);
222 Retrieve the value stored under the specified key in the cache.
224 The possible options are:
230 If set, this will avoid performing a deep copy of the item. This
231 means that it won't be safe if something later modifies the result of the
232 function. It should be used with caution, and could save processing time
233 in some situations where is safe to use it. Make sure you know what you are doing!
237 The cache object to use if you want to provide your own. It should be an
238 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
245 my ( $self, $key, $options ) = @_;
246 my $cache = $options->{cache} || 'cache';
247 my $unsafe = $options->{unsafe} || 0;
248 $key =~ s/[\x00-\x20]/_/g;
249 croak "No key" unless $key;
250 $ENV{DEBUG} && carp "get_from_cache for $key";
251 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
253 # Return L1 cache value if exists
254 if ( exists $L1_cache{$self->{namespace}}{$key} ) {
255 if (ref($L1_cache{$self->{namespace}}{$key})) {
257 # ONLY use thawed for unsafe calls !!!
258 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
259 return $L1_cache{$self->{namespace}}{$key}->{thawed};
261 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
264 # No need to thaw if it's a scalar
265 return $L1_cache{$self->{namespace}}{$key};
269 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
270 my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
272 return if ref($L2_value);
273 return unless (defined($L2_value) && length($L2_value) >= 4);
275 my $flag = substr($L2_value, -4, 4, '');
276 if ($flag eq '-CF0') {
278 $L1_cache{$self->{namespace}}{$key} = $L2_value;
280 } elsif ($flag eq '-CF1') {
281 # it's a frozen data structure
283 eval { $thawed = $L1_decoder->decode($L2_value); };
285 $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
286 # ONLY save thawed for unsafe calls !!!
287 $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
291 # Unknown value / data type returned from L2 cache
295 =head2 clear_from_cache
297 $cache->clear_from_cache($key);
299 Remove the value identified by the specified key from the default cache.
303 sub clear_from_cache {
304 my ( $self, $key, $cache ) = @_;
305 $key =~ s/[\x00-\x20]/_/g;
307 croak "No key" unless $key;
308 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
310 # Clear from L1 cache
311 delete $L1_cache{$self->{namespace}}{$key};
313 return $self->{$cache}->delete($key)
314 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
315 return $self->{$cache}->remove($key);
322 Clear the entire default cache.
327 my ( $self, $cache ) = shift;
329 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
331 $self->flush_L1_cache();
333 return $self->{$cache}->flush_all()
334 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
335 return $self->{$cache}->clear();
340 delete $L1_cache{$self->{namespace}};
343 =head1 TIED INTERFACE
345 Koha::Cache also provides a tied interface which enables users to provide a
346 constructor closure and (after creation) treat cached data like normal reference
347 variables and rely on the cache Just Working and getting updated when it
350 my $cache = Koha::Cache->new();
351 my $data = 'whatever';
352 my $scalar = Koha::Cache->create_scalar(
356 'constructor' => sub { return $data; },
359 print "$$scalar\n"; # Prints "whatever"
360 $data = 'somethingelse';
361 print "$$scalar\n"; # Prints "whatever" because it is cached
362 sleep 2; # Wait until the cache entry has expired
363 print "$$scalar\n"; # Prints "somethingelse"
365 my $hash = Koha::Cache->create_hash(
369 'constructor' => sub { return $data; },
372 print "$$variable\n"; # Prints "whatever"
374 The gotcha with this interface, of course, is that the variable returned by
375 create_scalar and create_hash is a I<reference> to a tied variable and not a
376 tied variable itself.
378 The tied variable is configured by means of a hashref passed in to the
379 create_scalar and create_hash methods. The following parameters are supported:
385 Required. The key to use for identifying the variable in the cache.
389 Required. A closure (or reference to a function) that will return the value that
390 needs to be stored in the cache.
394 Optional. A closure (or reference to a function) that gets run to initialize
395 the cache when creating the tied variable.
399 Optional. Array reference with the arguments that should be passed to the
400 constructor function.
404 Optional. The cache timeout in seconds for the variable. Defaults to 600
409 Optional. Which type of cache to use for the variable. Defaults to whatever is
410 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
411 caching for the tied variable.
415 Optional. Boolean flag to allow the variable to be updated directly. When this
416 is set and the variable is used as an l-value, the cache will be updated
417 immediately with the new value. Using this is probably a bad idea on a
418 multi-threaded system. When I<allowupdate> is not set to true, using the
419 tied variable as an l-value will have no effect.
423 Optional. A closure (or reference to a function) that should be called when the
424 tied variable is destroyed.
428 Optional. Boolean flag to tell the object to remove the variable from the cache
429 when it is destroyed or goes out of scope.
433 Optional. Boolean flag to tell the object not to refresh the variable from the
434 cache every time the value is desired, but rather only when the I<local> copy
435 of the variable is older than the timeout.
441 my $scalar = Koha::Cache->create_scalar(\%params);
443 Create scalar tied to the cache.
448 my ( $self, $args ) = @_;
450 $self->_set_tied_defaults($args);
452 tie my $scalar, 'Koha::Cache::Object', $args;
457 my ( $self, $args ) = @_;
459 $self->_set_tied_defaults($args);
461 tie my %hash, 'Koha::Cache::Object', $args;
465 sub _set_tied_defaults {
466 my ( $self, $args ) = @_;
468 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
469 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
470 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
471 $args->{'cache'} = $self;
472 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
488 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
489 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
490 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>