Bug 15036: Do not overwrite complete status in basket ops
[koha.git] / Koha / Cache.pm
blob9856e80b839a04a11aaec6ecd1a326eb4dac362f
1 package Koha::Cache;
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>.
21 =head1 NAME
23 Koha::Cache - Handling caching of html and Objects for Koha
25 =head1 SYNOPSIS
27 use Koha::Cache;
28 my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
30 =head1 DESCRIPTION
32 Koha caching routines. This class provides two interfaces for cache access.
33 The first, traditional OO interface provides the following functions:
35 =head1 FUNCTIONS
37 =cut
38 use strict;
39 use warnings;
40 use Carp;
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 ));
49 =head2 get_instance
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.
57 =cut
59 our $singleton_cache;
60 sub get_instance {
61 my ($class) = @_;
62 $singleton_cache = $class->new() unless $singleton_cache;
63 return $singleton_cache;
66 =head2 new
68 Create a new Koha::Cache object. This is required for all cache-related functionality.
70 =cut
72 sub new {
73 my ( $class, $self ) = @_;
74 $self->{'default_type'} =
75 $self->{cache_type}
76 || $ENV{CACHING_SYSTEM}
77 || 'memcached';
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 ( $self->{'default_type'} eq 'fastmmap'
94 && defined( $ENV{GATEWAY_INTERFACE} )
95 && can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
96 _initialize_fastmmap($self);
97 if ( defined( $self->{'fastmmap_cache'} ) )
99 $self->{'cache'} = $self->{'fastmmap_cache'};
103 if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
104 _initialize_memory($self);
105 if ( $self->{'default_type'} eq 'memory'
106 && defined( $self->{'memory_cache'} ) )
108 $self->{'cache'} = $self->{'memory_cache'};
112 # Unless a default has already been picked, we go through in best-to-
113 # least-best order, looking for something we can use. fastmmap_cache
114 # is excluded because it doesn't support expiry in a useful way.
115 unless ( defined( $self->{'cache'} ) ) {
116 foreach my $cachemember (qw(memcached_cache memory_cache )) {
117 if ( defined( $self->{$cachemember} ) ) {
118 $self->{'cache'} = $self->{$cachemember};
119 last;
124 $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
126 return
127 bless $self,
128 $class;
131 sub _initialize_memcached {
132 my ($self) = @_;
133 my @servers =
134 split /,/, $self->{'cache_servers'}
135 ? $self->{'cache_servers'}
136 : ($ENV{MEMCACHED_SERVERS} || '');
137 return if !@servers;
139 $ENV{DEBUG}
140 && carp "Memcached server settings: "
141 . join( ', ', @servers )
142 . " with "
143 . $self->{'namespace'};
144 # Cache::Memcached::Fast doesn't allow a default expire time to be set
145 # so we force it on setting.
146 my $memcached = Cache::Memcached::Fast->new(
148 servers => \@servers,
149 compress_threshold => 10_000,
150 namespace => $self->{'namespace'},
151 utf8 => 1,
154 # Ensure we can actually talk to the memcached server
155 my $ismemcached = $memcached->set('ismemcached','1');
156 return $self unless $ismemcached;
157 $self->{'memcached_cache'} = $memcached;
158 return $self;
161 sub _initialize_fastmmap {
162 my ($self) = @_;
163 my ($cache, $share_file);
165 # Temporary workaround to catch fatal errors when: C4::Context module
166 # is not loaded beforehand, or Cache::FastMmap init fails for whatever
167 # other reason (e.g. due to permission issues - see Bug 13431)
168 eval {
169 $share_file = join( '-',
170 "/tmp/sharefile-koha", $self->{'namespace'},
171 C4::Context->config('hostname'), C4::Context->config('database') );
173 $cache = Cache::FastMmap->new(
174 'share_file' => $share_file,
175 'expire_time' => $self->{'timeout'},
176 'unlink_on_exit' => 0,
179 if ( $@ ) {
180 warn "FastMmap cache initialization failed: $@";
181 return;
183 return unless defined $cache;
184 $self->{'fastmmap_cache'} = $cache;
185 return $self;
188 sub _initialize_memory {
189 my ($self) = @_;
191 # Default cache time for memory is _always_ short unless it's specially
192 # defined, to allow it to work reliably in a persistent environment.
193 my $cache = Cache::Memory->new(
194 'namespace' => $self->{'namespace'},
195 'default_expires' => "$self->{'timeout'} sec" || "10 sec",
197 $self->{'memory_cache'} = $cache;
198 # Memory cache can't handle complex types for some reason, so we use its
199 # freeze and thaw functions.
200 $self->{ref($cache) . '_set'} = sub {
201 my ($key, $val, $exp) = @_;
202 # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
203 $exp = "$exp sec" if defined $exp;
204 # Because we need to use freeze, it must be a reference type.
205 $cache->freeze($key, [$val], $exp);
207 $self->{ref($cache) . '_get'} = sub {
208 my $res = $cache->thaw(shift);
209 return unless defined $res;
210 return $res->[0];
212 return $self;
215 =head2 is_cache_active
217 Routine that checks whether or not a default caching method is active on this
218 object.
220 =cut
222 sub is_cache_active {
223 my $self = shift;
224 return $self->{'cache'} ? 1 : 0;
227 =head2 set_in_cache
229 $cache->set_in_cache($key, $value, [$options]);
231 Save a value to the specified key in the cache. A hashref of options may be
232 specified.
234 The possible options are:
236 =over
238 =item expiry
240 Expiry time of this cached entry in seconds.
242 =item deepcopy
244 If set, this will perform a deep copy of the item when it's retrieved. This
245 means that it'll be safe if something later modifies the result of the
246 function. Will be ignored in situations where the same behaviour comes from
247 the caching layer anyway.
249 =item cache
251 The cache object to use if you want to provide your own. It should be an
252 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
254 =back
256 =cut
258 sub set_in_cache {
259 my ( $self, $key, $value, $options, $_cache) = @_;
260 # This is a bit of a hack to support the old API in case things still use it
261 if (defined $options && (ref($options) ne 'HASH')) {
262 my $new_options;
263 $new_options->{expiry} = $options;
264 $new_options->{cache} = $_cache if defined $_cache;
265 $options = $new_options;
268 # the key mustn't contain whitespace (or control characters) for memcache
269 # but shouldn't be any harm in applying it globally.
270 $key =~ s/[\x00-\x20]/_/g;
272 my $cache = $options->{cache} || 'cache';
273 croak "No key" unless $key;
274 $ENV{DEBUG} && carp "set_in_cache for $key";
276 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
277 my $expiry = $options->{expiry};
278 $expiry //= $self->{timeout};
279 my $set_sub = $self->{ref($self->{$cache}) . "_set"};
280 # We consider an expiry of 0 to be inifinite
281 if ( $expiry ) {
282 return $set_sub
283 ? $set_sub->( $key, $value, $expiry )
284 : $self->{$cache}->set( $key, $value, $expiry );
286 else {
287 return $set_sub
288 ? $set_sub->( $key, $value )
289 : $self->{$cache}->set( $key, $value );
293 =head2 get_from_cache
295 my $value = $cache->get_from_cache($key);
297 Retrieve the value stored under the specified key in the default cache.
299 =cut
301 sub get_from_cache {
302 my ( $self, $key, $cache ) = @_;
303 $key =~ s/[\x00-\x20]/_/g;
304 $cache ||= 'cache';
305 croak "No key" unless $key;
306 $ENV{DEBUG} && carp "get_from_cache for $key";
307 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
308 my $get_sub = $self->{ref($self->{$cache}) . "_get"};
309 return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
312 =head2 clear_from_cache
314 $cache->clear_from_cache($key);
316 Remove the value identified by the specified key from the default cache.
318 =cut
320 sub clear_from_cache {
321 my ( $self, $key, $cache ) = @_;
322 $key =~ s/[\x00-\x20]/_/g;
323 $cache ||= 'cache';
324 croak "No key" unless $key;
325 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
326 return $self->{$cache}->delete($key)
327 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
328 return $self->{$cache}->remove($key);
331 =head2 flush_all
333 $cache->flush_all();
335 Clear the entire default cache.
337 =cut
339 sub flush_all {
340 my ( $self, $cache ) = shift;
341 $cache ||= 'cache';
342 return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
343 return $self->{$cache}->flush_all()
344 if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
345 return $self->{$cache}->clear();
348 =head1 TIED INTERFACE
350 Koha::Cache also provides a tied interface which enables users to provide a
351 constructor closure and (after creation) treat cached data like normal reference
352 variables and rely on the cache Just Working and getting updated when it
353 expires, etc.
355 my $cache = Koha::Cache->new();
356 my $data = 'whatever';
357 my $scalar = Koha::Cache->create_scalar(
359 'key' => 'whatever',
360 'timeout' => 2,
361 'constructor' => sub { return $data; },
364 print "$$scalar\n"; # Prints "whatever"
365 $data = 'somethingelse';
366 print "$$scalar\n"; # Prints "whatever" because it is cached
367 sleep 2; # Wait until the cache entry has expired
368 print "$$scalar\n"; # Prints "somethingelse"
370 my $hash = Koha::Cache->create_hash(
372 'key' => 'whatever',
373 'timeout' => 2,
374 'constructor' => sub { return $data; },
377 print "$$variable\n"; # Prints "whatever"
379 The gotcha with this interface, of course, is that the variable returned by
380 create_scalar and create_hash is a I<reference> to a tied variable and not a
381 tied variable itself.
383 The tied variable is configured by means of a hashref passed in to the
384 create_scalar and create_hash methods. The following parameters are supported:
386 =over
388 =item I<key>
390 Required. The key to use for identifying the variable in the cache.
392 =item I<constructor>
394 Required. A closure (or reference to a function) that will return the value that
395 needs to be stored in the cache.
397 =item I<preload>
399 Optional. A closure (or reference to a function) that gets run to initialize
400 the cache when creating the tied variable.
402 =item I<arguments>
404 Optional. Array reference with the arguments that should be passed to the
405 constructor function.
407 =item I<timeout>
409 Optional. The cache timeout in seconds for the variable. Defaults to 600
410 (ten minutes).
412 =item I<cache_type>
414 Optional. Which type of cache to use for the variable. Defaults to whatever is
415 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
416 caching for the tied variable.
418 =item I<allowupdate>
420 Optional. Boolean flag to allow the variable to be updated directly. When this
421 is set and the variable is used as an l-value, the cache will be updated
422 immediately with the new value. Using this is probably a bad idea on a
423 multi-threaded system. When I<allowupdate> is not set to true, using the
424 tied variable as an l-value will have no effect.
426 =item I<destructor>
428 Optional. A closure (or reference to a function) that should be called when the
429 tied variable is destroyed.
431 =item I<unset>
433 Optional. Boolean flag to tell the object to remove the variable from the cache
434 when it is destroyed or goes out of scope.
436 =item I<inprocess>
438 Optional. Boolean flag to tell the object not to refresh the variable from the
439 cache every time the value is desired, but rather only when the I<local> copy
440 of the variable is older than the timeout.
442 =back
444 =head2 create_scalar
446 my $scalar = Koha::Cache->create_scalar(\%params);
448 Create scalar tied to the cache.
450 =cut
452 sub create_scalar {
453 my ( $self, $args ) = @_;
455 $self->_set_tied_defaults($args);
457 tie my $scalar, 'Koha::Cache::Object', $args;
458 return \$scalar;
461 sub create_hash {
462 my ( $self, $args ) = @_;
464 $self->_set_tied_defaults($args);
466 tie my %hash, 'Koha::Cache::Object', $args;
467 return \%hash;
470 sub _set_tied_defaults {
471 my ( $self, $args ) = @_;
473 $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
474 $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
475 unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
476 $args->{'cache'} = $self;
477 $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
480 return $args;
483 =head1 EXPORT
485 None by default.
487 =head1 SEE ALSO
489 Koha::Cache::Object
491 =head1 AUTHOR
493 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
494 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
495 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
497 =cut
501 __END__