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 under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 2 of the License, or (at your option) any later
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
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;
44 use base qw(Class::Accessor);
46 __PACKAGE__->mk_ro_accessors(
47 qw( cache memcached_cache fastmmap_cache memory_cache ));
51 my $cache = Koha::Cache->get_instance();
53 This gets a shared instance of the cache, set up in a very default way. This is
54 the recommended way to fetch a cache object. If possible, it'll be
55 persistent across multiple instances.
62 $singleton_cache = $class->new() unless $singleton_cache;
63 return $singleton_cache;
68 Create a new Koha::Cache object. This is required for all cache-related functionality.
73 my ( $class, $self ) = @_;
74 $self->{'default_type'} =
76 || $ENV{CACHING_SYSTEM}
79 $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
81 $self->{'timeout'} ||= 0;
82 $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
84 if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
85 _initialize_memcached($self);
86 if ( $self->{'default_type'} eq 'memcached'
87 && defined( $self->{'memcached_cache'} ) )
89 $self->{'cache'} = $self->{'memcached_cache'};
93 if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
94 _initialize_fastmmap($self);
95 if ( $self->{'default_type'} eq 'fastmmap'
96 && defined( $self->{'fastmmap_cache'} ) )
98 $self->{'cache'} = $self->{'fastmmap_cache'};
102 if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
103 _initialize_memory($self);
104 if ( $self->{'default_type'} eq 'memory'
105 && defined( $self->{'memory_cache'} ) )
107 $self->{'cache'} = $self->{'memory_cache'};
111 # Unless a default has already been picked, we go through in best-to-
112 # least-best order, looking for something we can use. fastmmap_cache
113 # is excluded because it doesn't support expiry in a useful way.
114 unless ( defined( $self->{'cache'} ) ) {
115 foreach my $cachemember (qw(memcached_cache memory_cache )) {
116 if ( defined( $self->{$cachemember} ) ) {
117 $self->{'cache'} = $self->{$cachemember};
123 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
130 sub _initialize_memcached {
133 split /,/, $self->{'cache_servers'}
134 ? $self->{'cache_servers'}
135 : ($ENV{MEMCACHED_SERVERS} || '');
139 && carp "Memcached server settings: "
140 . join( ', ', @servers )
142 . $self->{'namespace'};
143 # Cache::Memcached::Fast doesn't allow a default expire time to be set
144 # so we force it on setting.
145 my $memcached = Cache::Memcached::Fast->new(
147 servers => \@servers,
148 compress_threshold => 10_000,
149 namespace => $self->{'namespace'},
153 # Ensure we can actually talk to the memcached server
154 my $ismemcached = $memcached->set('ismemcached','1');
155 return $self unless $ismemcached;
156 $self->{'memcached_cache'} = $memcached;
160 sub _initialize_fastmmap {
163 $self->{'fastmmap_cache'} = Cache::FastMmap->new(
164 'share_file' => "/tmp/sharefile-koha-$self->{'namespace'}",
165 'expire_time' => $self->{'timeout'},
166 'unlink_on_exit' => 0,
171 sub _initialize_memory {
174 # Default cache time for memory is _always_ short unless it's specially
175 # defined, to allow it to work reliably in a persistent environment.
176 my $cache = Cache::Memory->new(
177 'namespace' => $self->{'namespace'},
178 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
180 $self->{'memory_cache'} = $cache;
181 # Memory cache can't handle complex types for some reason, so we use its
182 # freeze and thaw functions.
183 $self->{ref($cache) . '_set'} = sub {
184 my ($key, $val, $exp) = @_;
185 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
186 $exp = "$exp sec" if defined $exp;
187 # Because we need to use freeze, it must be a reference type.
188 $cache->freeze($key, [$val], $exp);
190 $self->{ref($cache) . '_get'} = sub {
191 my $res = $cache->thaw(shift);
192 return unless defined $res;
198 =head2 is_cache_active
200 Routine that checks whether or not a default caching method is active on this
205 sub is_cache_active {
207 return $self->{'cache'} ? 1 : 0;
212 $cache->set_in_cache($key, $value, [$options]);
214 Save a value to the specified key in the cache. A hashref of options may be
217 The possible options are:
223 Expiry time of this cached entry in seconds.
227 If set, this will perform a deep copy of the item when it's retrieved. This
228 means that it'll be safe if something later modifies the result of the
229 function. Will be ignored in situations where the same behaviour comes from
230 the caching layer anyway.
234 The cache object to use if you want to provide your own. It should be an
235 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
240 my ( $self, $key, $value, $options, $_cache) = @_;
241 # This is a bit of a hack to support the old API in case things still use it
242 if (defined $options && (ref($options) ne 'HASH')) {
244 $new_options->{expiry} = $options;
245 $new_options->{cache} = $_cache if defined $_cache;
246 $options = $new_options;
249 # the key mustn't contain whitespace (or control characters) for memcache
250 # but shouldn't be any harm in applying it globally.
251 $key =~ s/[\x00-\x20]/_/g;
253 my $cache = $options->{cache} || 'cache';
254 croak "No key" unless $key;
255 $ENV{DEBUG} && carp "set_in_cache for $key";
257 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
258 my $expiry = $options->{expiry};
259 $expiry //= $self->{timeout};
260 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
261 # We consider an expiry of 0 to be inifinite
264 ? $set_sub->( $key, $value, $expiry )
265 : $self->{$cache}->set( $key, $value, $expiry );
269 ? $set_sub->( $key, $value )
270 : $self->{$cache}->set( $key, $value );
274 =head2 get_from_cache
276 my $value = $cache->get_from_cache($key);
278 Retrieve the value stored under the specified key in the default cache.
283 my ( $self, $key, $cache ) = @_;
284 $key =~ s/[\x00-\x20]/_/g;
286 croak "No key" unless $key;
287 $ENV{DEBUG} && carp "get_from_cache for $key";
288 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
289 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
290 return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
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::/ );
307 return $self->{$cache}->delete($key)
308 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
309 return $self->{$cache}->remove($key);
316 Clear the entire default cache.
321 my ( $self, $cache ) = shift;
323 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
324 return $self->{$cache}->flush_all()
325 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
326 return $self->{$cache}->clear();
329 =head1 TIED INTERFACE
331 Koha::Cache also provides a tied interface which enables users to provide a
332 constructor closure and (after creation) treat cached data like normal reference
333 variables and rely on the cache Just Working and getting updated when it
336 my $cache = Koha::Cache->new();
337 my $data = 'whatever';
338 my $scalar = Koha::Cache->create_scalar(
342 'constructor' => sub { return $data; },
345 print "$$scalar\n"; # Prints "whatever"
346 $data = 'somethingelse';
347 print "$$scalar\n"; # Prints "whatever" because it is cached
348 sleep 2; # Wait until the cache entry has expired
349 print "$$scalar\n"; # Prints "somethingelse"
351 my $hash = Koha::Cache->create_hash(
355 'constructor' => sub { return $data; },
358 print "$$variable\n"; # Prints "whatever"
360 The gotcha with this interface, of course, is that the variable returned by
361 create_scalar and create_hash is a I<reference> to a tied variable and not a
362 tied variable itself.
364 The tied variable is configured by means of a hashref passed in to the
365 create_scalar and create_hash methods. The following parameters are supported:
371 Required. The key to use for identifying the variable in the cache.
375 Required. A closure (or reference to a function) that will return the value that
376 needs to be stored in the cache.
380 Optional. A closure (or reference to a function) that gets run to initialize
381 the cache when creating the tied variable.
385 Optional. Array reference with the arguments that should be passed to the
386 constructor function.
390 Optional. The cache timeout in seconds for the variable. Defaults to 600
395 Optional. Which type of cache to use for the variable. Defaults to whatever is
396 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
397 caching for the tied variable.
401 Optional. Boolean flag to allow the variable to be updated directly. When this
402 is set and the variable is used as an l-value, the cache will be updated
403 immediately with the new value. Using this is probably a bad idea on a
404 multi-threaded system. When I<allowupdate> is not set to true, using the
405 tied variable as an l-value will have no effect.
409 Optional. A closure (or reference to a function) that should be called when the
410 tied variable is destroyed.
414 Optional. Boolean flag to tell the object to remove the variable from the cache
415 when it is destroyed or goes out of scope.
419 Optional. Boolean flag to tell the object not to refresh the variable from the
420 cache every time the value is desired, but rather only when the I<local> copy
421 of the variable is older than the timeout.
427 my $scalar = Koha::Cache->create_scalar(\%params);
429 Create scalar tied to the cache.
434 my ( $self, $args ) = @_;
436 $self->_set_tied_defaults($args);
438 tie my $scalar, 'Koha::Cache::Object', $args;
443 my ( $self, $args ) = @_;
445 $self->_set_tied_defaults($args);
447 tie my %hash, 'Koha::Cache::Object', $args;
451 sub _set_tied_defaults {
452 my ( $self, $args ) = @_;
454 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
455 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
456 unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
457 $args->{'cache'} = $self;
458 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
474 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
475 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
476 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>