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);
45 use Koha::Cache::Object;
48 use base qw(Class::Accessor);
50 __PACKAGE__->mk_ro_accessors(
51 qw( cache memcached_cache fastmmap_cache memory_cache ));
54 our $L1_encoder = Sereal::Encoder->new;
55 our $L1_decoder = Sereal::Decoder->new;
59 my $cache = Koha::Caches->get_instance();
61 This gets a shared instance of the cache, set up in a very default way. This is
62 the recommended way to fetch a cache object. If possible, it'll be
63 persistent across multiple instances.
69 Create a new Koha::Cache object. This is required for all cache-related functionality.
74 my ( $class, $self, $params ) = @_;
75 $self->{'default_type'} =
77 || $ENV{CACHING_SYSTEM} # DELME What about this?
80 my $subnamespace = $params->{subnamespace} // '';
82 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
84 $self->{'timeout'} ||= 0;
85 # Should we continue to support MEMCACHED ENV vars?
86 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
87 my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
88 unless ( $self->{namespace} and @servers ) {
89 my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
90 $self->{namespace} ||= $koha_config->{config}{memcached_namespace} || 'koha';
91 @servers ||= split /,/, $koha_config->{config}{memcached_servers};
93 $self->{namespace} .= ":$subnamespace:";
95 if ( $self->{'default_type'} eq 'memcached'
96 && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
97 && _initialize_memcached($self, @servers)
98 && defined( $self->{'memcached_cache'} ) )
100 $self->{'cache'} = $self->{'memcached_cache'};
103 if ( $self->{'default_type'} eq 'fastmmap'
104 && defined( $ENV{GATEWAY_INTERFACE} )
105 && can_load( modules => { 'Cache::FastMmap' => undef } )
106 && _initialize_fastmmap($self)
107 && defined( $self->{'fastmmap_cache'} ) )
109 $self->{'cache'} = $self->{'fastmmap_cache'};
112 # Unless memcache or fastmmap has already been picked, use memory_cache
113 unless ( defined( $self->{'cache'} ) ) {
114 if ( can_load( modules => { 'Cache::Memory' => undef } )
115 && _initialize_memory($self) )
117 $self->{'cache'} = $self->{'memory_cache'};
121 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
128 sub _initialize_memcached {
129 my ($self, @servers) = @_;
131 return unless @servers;
134 && carp "Memcached server settings: "
135 . join( ', ', @servers )
137 . $self->{'namespace'};
138 # Cache::Memcached::Fast doesn't allow a default expire time to be set
139 # so we force it on setting.
140 my $memcached = Cache::Memcached::Fast->new(
142 servers => \@servers,
143 compress_threshold => 10_000,
144 namespace => $self->{'namespace'},
148 # Ensure we can actually talk to the memcached server
149 my $ismemcached = $memcached->set('ismemcached','1');
150 return $self unless $ismemcached;
151 $self->{'memcached_cache'} = $memcached;
155 sub _initialize_fastmmap {
157 my ($cache, $share_file);
159 # Temporary workaround to catch fatal errors when: C4::Context module
160 # is not loaded beforehand, or Cache::FastMmap init fails for whatever
161 # other reason (e.g. due to permission issues - see Bug 13431)
163 $share_file = join( '-',
164 "/tmp/sharefile-koha", $self->{'namespace'},
165 C4::Context->config('hostname'), C4::Context->config('database') );
167 $cache = Cache::FastMmap->new(
168 'share_file' => $share_file,
169 'expire_time' => $self->{'timeout'},
170 'unlink_on_exit' => 0,
174 warn "FastMmap cache initialization failed: $@";
177 return unless defined $cache;
178 $self->{'fastmmap_cache'} = $cache;
182 sub _initialize_memory {
185 # Default cache time for memory is _always_ short unless it's specially
186 # defined, to allow it to work reliably in a persistent environment.
187 my $cache = Cache::Memory->new(
188 'namespace' => $self->{'namespace'},
189 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
191 $self->{'memory_cache'} = $cache;
192 # Memory cache can't handle complex types for some reason, so we use its
193 # freeze and thaw functions.
194 $self->{ref($cache) . '_set'} = sub {
195 my ($key, $val, $exp) = @_;
196 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
197 $exp = "$exp sec" if defined $exp;
198 # Because we need to use freeze, it must be a reference type.
199 $cache->freeze($key, [$val], $exp);
201 $self->{ref($cache) . '_get'} = sub {
202 my $res = $cache->thaw(shift);
203 return unless defined $res;
209 =head2 is_cache_active
211 Routine that checks whether or not a default caching method is active on this
216 sub is_cache_active {
218 return $self->{'cache'} ? 1 : 0;
223 $cache->set_in_cache($key, $value, [$options]);
225 Save a value to the specified key in the cache. A hashref of options may be
228 The possible options are:
234 Expiry time of this cached entry in seconds.
238 The cache object to use if you want to provide your own. It should be an
239 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
246 my ( $self, $key, $value, $options, $_cache) = @_;
247 # This is a bit of a hack to support the old API in case things still use it
248 if (defined $options && (ref($options) ne 'HASH')) {
250 $new_options->{expiry} = $options;
251 $new_options->{cache} = $_cache if defined $_cache;
252 $options = $new_options;
255 # the key mustn't contain whitespace (or control characters) for memcache
256 # but shouldn't be any harm in applying it globally.
257 $key =~ s/[\x00-\x20]/_/g;
259 my $cache = $options->{cache} || 'cache';
260 croak "No key" unless $key;
261 $ENV{DEBUG} && carp "set_in_cache for $key";
263 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
264 my $expiry = $options->{expiry};
265 $expiry //= $self->{timeout};
266 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
268 my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
270 # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
271 $value = $L1_encoder->encode($value);
272 $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
275 # Set in L1 cache as a scalar; exit if we are caching an undef
276 $L1_cache{$self->{namespace}}{$key} = $value;
277 return if !defined $value;
281 # We consider an expiry of 0 to be inifinite
284 ? $set_sub->( $key, $value, $expiry )
285 : $self->{$cache}->set( $key, $value, $expiry );
289 ? $set_sub->( $key, $value )
290 : $self->{$cache}->set( $key, $value );
294 =head2 get_from_cache
296 my $value = $cache->get_from_cache($key, [ $options ]);
298 Retrieve the value stored under the specified key in the cache.
300 The possible options are:
306 If set, this will avoid performing a deep copy of the item. This
307 means that it won't be safe if something later modifies the result of the
308 function. It should be used with caution, and could save processing time
309 in some situations where is safe to use it. Make sure you know what you are doing!
313 The cache object to use if you want to provide your own. It should be an
314 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
321 my ( $self, $key, $options ) = @_;
322 my $cache = $options->{cache} || 'cache';
323 my $unsafe = $options->{unsafe} || 0;
324 $key =~ s/[\x00-\x20]/_/g;
325 croak "No key" unless $key;
326 $ENV{DEBUG} && carp "get_from_cache for $key";
327 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
329 # Return L1 cache value if exists
330 if ( exists $L1_cache{$self->{namespace}}{$key} ) {
331 if (ref($L1_cache{$self->{namespace}}{$key})) {
333 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
334 return $L1_cache{$self->{namespace}}{$key}->{thawed};
336 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
339 # No need to thaw if it's a scalar
340 return $L1_cache{$self->{namespace}}{$key};
344 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
345 my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
347 return if ref($L2_value);
348 return unless (defined($L2_value) && length($L2_value) >= 4);
350 my $flag = substr($L2_value, -4, 4, '');
351 if ($flag eq '-CF0') {
353 $L1_cache{$self->{namespace}}{$key} = $L2_value;
355 } elsif ($flag eq '-CF1') {
356 # it's a frozen data structure
358 eval { $thawed = $L1_decoder->decode($L2_value); };
360 $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
361 $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
365 # Unknown value / data type returned from L2 cache
369 =head2 clear_from_cache
371 $cache->clear_from_cache($key);
373 Remove the value identified by the specified key from the default cache.
377 sub clear_from_cache {
378 my ( $self, $key, $cache ) = @_;
379 $key =~ s/[\x00-\x20]/_/g;
381 croak "No key" unless $key;
382 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
384 # Clear from L1 cache
385 delete $L1_cache{$self->{namespace}}{$key};
387 return $self->{$cache}->delete($key)
388 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
389 return $self->{$cache}->remove($key);
396 Clear the entire default cache.
401 my ( $self, $cache ) = shift;
403 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
405 $self->flush_L1_cache();
407 return $self->{$cache}->flush_all()
408 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
409 return $self->{$cache}->clear();
414 delete $L1_cache{$self->{namespace}};
417 =head1 TIED INTERFACE
419 Koha::Cache also provides a tied interface which enables users to provide a
420 constructor closure and (after creation) treat cached data like normal reference
421 variables and rely on the cache Just Working and getting updated when it
424 my $cache = Koha::Cache->new();
425 my $data = 'whatever';
426 my $scalar = Koha::Cache->create_scalar(
430 'constructor' => sub { return $data; },
433 print "$$scalar\n"; # Prints "whatever"
434 $data = 'somethingelse';
435 print "$$scalar\n"; # Prints "whatever" because it is cached
436 sleep 2; # Wait until the cache entry has expired
437 print "$$scalar\n"; # Prints "somethingelse"
439 my $hash = Koha::Cache->create_hash(
443 'constructor' => sub { return $data; },
446 print "$$variable\n"; # Prints "whatever"
448 The gotcha with this interface, of course, is that the variable returned by
449 create_scalar and create_hash is a I<reference> to a tied variable and not a
450 tied variable itself.
452 The tied variable is configured by means of a hashref passed in to the
453 create_scalar and create_hash methods. The following parameters are supported:
459 Required. The key to use for identifying the variable in the cache.
463 Required. A closure (or reference to a function) that will return the value that
464 needs to be stored in the cache.
468 Optional. A closure (or reference to a function) that gets run to initialize
469 the cache when creating the tied variable.
473 Optional. Array reference with the arguments that should be passed to the
474 constructor function.
478 Optional. The cache timeout in seconds for the variable. Defaults to 600
483 Optional. Which type of cache to use for the variable. Defaults to whatever is
484 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
485 caching for the tied variable.
489 Optional. Boolean flag to allow the variable to be updated directly. When this
490 is set and the variable is used as an l-value, the cache will be updated
491 immediately with the new value. Using this is probably a bad idea on a
492 multi-threaded system. When I<allowupdate> is not set to true, using the
493 tied variable as an l-value will have no effect.
497 Optional. A closure (or reference to a function) that should be called when the
498 tied variable is destroyed.
502 Optional. Boolean flag to tell the object to remove the variable from the cache
503 when it is destroyed or goes out of scope.
507 Optional. Boolean flag to tell the object not to refresh the variable from the
508 cache every time the value is desired, but rather only when the I<local> copy
509 of the variable is older than the timeout.
515 my $scalar = Koha::Cache->create_scalar(\%params);
517 Create scalar tied to the cache.
522 my ( $self, $args ) = @_;
524 $self->_set_tied_defaults($args);
526 tie my $scalar, 'Koha::Cache::Object', $args;
531 my ( $self, $args ) = @_;
533 $self->_set_tied_defaults($args);
535 tie my %hash, 'Koha::Cache::Object', $args;
539 sub _set_tied_defaults {
540 my ( $self, $args ) = @_;
542 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
543 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
544 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
545 $args->{'cache'} = $self;
546 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
562 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
563 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
564 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>