Bug 17189: Use delete to flush a L1 cache namespace
[koha.git] / Koha / Cache.pm
1 package Koha::Cache;
2
3 # Copyright 2009 Chris Cormack and The Koha Dev Team
4 # Parts copyright 2012-2013 C & P Bibliography Services
5 #
6 # This file is part of Koha.
7 #
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.
12 #
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.
17 #
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>.
20
21 =head1 NAME
22
23 Koha::Cache - Handling caching of html and Objects for Koha
24
25 =head1 SYNOPSIS
26
27   use Koha::Cache;
28   my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
29
30 =head1 DESCRIPTION
31
32 Koha caching routines. This class provides two interfaces for cache access.
33 The first, traditional OO interface provides the following functions:
34
35 =head1 FUNCTIONS
36
37 =cut
38 use strict;
39 use warnings;
40 use Carp;
41 use Module::Load::Conditional qw(can_load);
42 use Koha::Cache::Object;
43 use Sereal::Encoder;
44 use Sereal::Decoder;
45
46 use base qw(Class::Accessor);
47
48 __PACKAGE__->mk_ro_accessors(
49     qw( cache memcached_cache fastmmap_cache memory_cache ));
50
51 our %L1_cache;
52 our $L1_encoder = Sereal::Encoder->new;
53 our $L1_decoder = Sereal::Decoder->new;
54
55 =head2 get_instance
56
57     my $cache = Koha::Caches->get_instance();
58
59 This gets a shared instance of the cache, set up in a very default way. This is
60 the recommended way to fetch a cache object. If possible, it'll be
61 persistent across multiple instances.
62
63 =cut
64
65 =head2 new
66
67 Create a new Koha::Cache object. This is required for all cache-related functionality.
68
69 =cut
70
71 sub new {
72     my ( $class, $self, $subnamespace ) = @_;
73     $self->{'default_type'} =
74          $self->{cache_type}
75       || $ENV{CACHING_SYSTEM}
76       || 'memcached';
77
78     $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
79
80     $self->{'timeout'}   ||= 0;
81     $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
82     $self->{namespace} .= ":$subnamespace:";
83
84     if ( $self->{'default_type'} eq 'memcached'
85         && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
86         && _initialize_memcached($self)
87         && defined( $self->{'memcached_cache'} ) )
88     {
89         $self->{'cache'} = $self->{'memcached_cache'};
90     }
91
92     if ( $self->{'default_type'} eq 'fastmmap'
93       && defined( $ENV{GATEWAY_INTERFACE} )
94       && can_load( modules => { 'Cache::FastMmap' => undef } )
95       && _initialize_fastmmap($self)
96       && defined( $self->{'fastmmap_cache'} ) )
97     {
98         $self->{'cache'} = $self->{'fastmmap_cache'};
99     }
100
101     # Unless memcache or fastmmap has already been picked, use memory_cache
102     unless ( defined( $self->{'cache'} ) ) {
103         if ( can_load( modules => { 'Cache::Memory' => undef } )
104             && _initialize_memory($self) )
105         {
106                 $self->{'cache'} = $self->{'memory_cache'};
107         }
108     }
109
110     $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
111
112     return
113       bless $self,
114       $class;
115 }
116
117 sub _initialize_memcached {
118     my ($self) = @_;
119     my @servers =
120       split /,/, $self->{'cache_servers'}
121       ? $self->{'cache_servers'}
122       : ($ENV{MEMCACHED_SERVERS} || '');
123     return if !@servers;
124
125     $ENV{DEBUG}
126       && carp "Memcached server settings: "
127       . join( ', ', @servers )
128       . " with "
129       . $self->{'namespace'};
130     # Cache::Memcached::Fast doesn't allow a default expire time to be set
131     # so we force it on setting.
132     my $memcached = Cache::Memcached::Fast->new(
133         {
134             servers            => \@servers,
135             compress_threshold => 10_000,
136             namespace          => $self->{'namespace'},
137             utf8               => 1,
138         }
139     );
140     # Ensure we can actually talk to the memcached server
141     my $ismemcached = $memcached->set('ismemcached','1');
142     return $self unless $ismemcached;
143     $self->{'memcached_cache'} = $memcached;
144     return $self;
145 }
146
147 sub _initialize_fastmmap {
148     my ($self) = @_;
149     my ($cache, $share_file);
150
151     # Temporary workaround to catch fatal errors when: C4::Context module
152     # is not loaded beforehand, or Cache::FastMmap init fails for whatever
153     # other reason (e.g. due to permission issues - see Bug 13431)
154     eval {
155         $share_file = join( '-',
156             "/tmp/sharefile-koha", $self->{'namespace'},
157             C4::Context->config('hostname'), C4::Context->config('database') );
158
159         $cache = Cache::FastMmap->new(
160             'share_file'  => $share_file,
161             'expire_time' => $self->{'timeout'},
162             'unlink_on_exit' => 0,
163         );
164     };
165     if ( $@ ) {
166         warn "FastMmap cache initialization failed: $@";
167         return;
168     }
169     return unless defined $cache;
170     $self->{'fastmmap_cache'} = $cache;
171     return $self;
172 }
173
174 sub _initialize_memory {
175     my ($self) = @_;
176
177     # Default cache time for memory is _always_ short unless it's specially
178     # defined, to allow it to work reliably in a persistent environment.
179     my $cache = Cache::Memory->new(
180         'namespace'       => $self->{'namespace'},
181         'default_expires' => "$self->{'timeout'} sec" || "10 sec",
182     );
183     $self->{'memory_cache'} = $cache;
184     # Memory cache can't handle complex types for some reason, so we use its
185     # freeze and thaw functions.
186     $self->{ref($cache) . '_set'} = sub {
187         my ($key, $val, $exp) = @_;
188         # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
189         $exp = "$exp sec" if defined $exp;
190         # Because we need to use freeze, it must be a reference type.
191         $cache->freeze($key, [$val], $exp);
192     };
193     $self->{ref($cache) . '_get'} = sub {
194         my $res = $cache->thaw(shift);
195         return unless defined $res;
196         return $res->[0];
197     };
198     return $self;
199 }
200
201 =head2 is_cache_active
202
203 Routine that checks whether or not a default caching method is active on this
204 object.
205
206 =cut
207
208 sub is_cache_active {
209     my $self = shift;
210     return $self->{'cache'} ? 1 : 0;
211 }
212
213 =head2 set_in_cache
214
215     $cache->set_in_cache($key, $value, [$options]);
216
217 Save a value to the specified key in the cache. A hashref of options may be
218 specified.
219
220 The possible options are:
221
222 =over
223
224 =item expiry
225
226 Expiry time of this cached entry in seconds.
227
228 =item cache
229
230 The cache object to use if you want to provide your own. It should be an
231 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
232
233 =back
234
235 =cut
236
237 sub set_in_cache {
238     my ( $self, $key, $value, $options, $_cache) = @_;
239     # This is a bit of a hack to support the old API in case things still use it
240     if (defined $options && (ref($options) ne 'HASH')) {
241         my $new_options;
242         $new_options->{expiry} = $options;
243         $new_options->{cache} = $_cache if defined $_cache;
244         $options = $new_options;
245     }
246
247     # the key mustn't contain whitespace (or control characters) for memcache
248     # but shouldn't be any harm in applying it globally.
249     $key =~ s/[\x00-\x20]/_/g;
250
251     my $cache = $options->{cache} || 'cache';
252     croak "No key" unless $key;
253     $ENV{DEBUG} && carp "set_in_cache for $key";
254
255     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
256     my $expiry = $options->{expiry};
257     $expiry //= $self->{timeout};
258     my $set_sub = $self->{ref($self->{$cache}) . "_set"};
259
260     my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
261     if (ref($value)) {
262         # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
263         $value = $L1_encoder->encode($value);
264         $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
265         $flag = '-CF1';
266     } else {
267         # Set in L1 cache as a scalar; exit if we are caching an undef
268         $L1_cache{$self->{namespace}}{$key} = $value;
269         return if !defined $value;
270     }
271
272     $value .= $flag;
273     # We consider an expiry of 0 to be inifinite
274     if ( $expiry ) {
275         return $set_sub
276           ? $set_sub->( $key, $value, $expiry )
277           : $self->{$cache}->set( $key, $value, $expiry );
278     }
279     else {
280         return $set_sub
281           ? $set_sub->( $key, $value )
282           : $self->{$cache}->set( $key, $value );
283     }
284 }
285
286 =head2 get_from_cache
287
288     my $value = $cache->get_from_cache($key, [ $options ]);
289
290 Retrieve the value stored under the specified key in the cache.
291
292 The possible options are:
293
294 =over
295
296 =item unsafe
297
298 If set, this will avoid performing a deep copy of the item. This
299 means that it won't be safe if something later modifies the result of the
300 function. It should be used with caution, and could save processing time
301 in some situations where is safe to use it. Make sure you know what you are doing!
302
303 =item cache
304
305 The cache object to use if you want to provide your own. It should be an
306 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
307
308 =back
309
310 =cut
311
312 sub get_from_cache {
313     my ( $self, $key, $options ) = @_;
314     my $cache  = $options->{cache}  || 'cache';
315     my $unsafe = $options->{unsafe} || 0;
316     $key =~ s/[\x00-\x20]/_/g;
317     croak "No key" unless $key;
318     $ENV{DEBUG} && carp "get_from_cache for $key";
319     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
320
321     # Return L1 cache value if exists
322     if ( exists $L1_cache{$self->{namespace}}{$key} ) {
323         if (ref($L1_cache{$self->{namespace}}{$key})) {
324             if ($unsafe) {
325                 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
326                 return $L1_cache{$self->{namespace}}{$key}->{thawed};
327             } else {
328                 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
329             }
330         } else {
331             # No need to thaw if it's a scalar
332             return $L1_cache{$self->{namespace}}{$key};
333         }
334     }
335
336     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
337     my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
338
339     return if ref($L2_value);
340     return unless (defined($L2_value) && length($L2_value) >= 4);
341
342     my $flag = substr($L2_value, -4, 4, '');
343     if ($flag eq '-CF0') {
344         # it's a scalar
345         $L1_cache{$self->{namespace}}{$key} = $L2_value;
346         return $L2_value;
347     } elsif ($flag eq '-CF1') {
348         # it's a frozen data structure
349         my $thawed;
350         eval { $thawed = $L1_decoder->decode($L2_value); };
351         return if $@;
352         $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
353         $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
354         return $thawed;
355     }
356
357     # Unknown value / data type returned from L2 cache
358     return;
359 }
360
361 =head2 clear_from_cache
362
363     $cache->clear_from_cache($key);
364
365 Remove the value identified by the specified key from the default cache.
366
367 =cut
368
369 sub clear_from_cache {
370     my ( $self, $key, $cache ) = @_;
371     $key =~ s/[\x00-\x20]/_/g;
372     $cache ||= 'cache';
373     croak "No key" unless $key;
374     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
375
376     # Clear from L1 cache
377     delete $L1_cache{$self->{namespace}}{$key};
378
379     return $self->{$cache}->delete($key)
380       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
381     return $self->{$cache}->remove($key);
382 }
383
384 =head2 flush_all
385
386     $cache->flush_all();
387
388 Clear the entire default cache.
389
390 =cut
391
392 sub flush_all {
393     my ( $self, $cache ) = shift;
394     $cache ||= 'cache';
395     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
396
397     $self->flush_L1_cache();
398
399     return $self->{$cache}->flush_all()
400       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
401     return $self->{$cache}->clear();
402 }
403
404 sub flush_L1_cache {
405     my( $self ) = @_;
406     delete $L1_cache{$self->{namespace}};
407 }
408
409 =head1 TIED INTERFACE
410
411 Koha::Cache also provides a tied interface which enables users to provide a
412 constructor closure and (after creation) treat cached data like normal reference
413 variables and rely on the cache Just Working and getting updated when it
414 expires, etc.
415
416     my $cache = Koha::Cache->new();
417     my $data = 'whatever';
418     my $scalar = Koha::Cache->create_scalar(
419         {
420             'key'         => 'whatever',
421             'timeout'     => 2,
422             'constructor' => sub { return $data; },
423         }
424     );
425     print "$$scalar\n"; # Prints "whatever"
426     $data = 'somethingelse';
427     print "$$scalar\n"; # Prints "whatever" because it is cached
428     sleep 2; # Wait until the cache entry has expired
429     print "$$scalar\n"; # Prints "somethingelse"
430
431     my $hash = Koha::Cache->create_hash(
432         {
433             'key'         => 'whatever',
434             'timeout'     => 2,
435             'constructor' => sub { return $data; },
436         }
437     );
438     print "$$variable\n"; # Prints "whatever"
439
440 The gotcha with this interface, of course, is that the variable returned by
441 create_scalar and create_hash is a I<reference> to a tied variable and not a
442 tied variable itself.
443
444 The tied variable is configured by means of a hashref passed in to the
445 create_scalar and create_hash methods. The following parameters are supported:
446
447 =over
448
449 =item I<key>
450
451 Required. The key to use for identifying the variable in the cache.
452
453 =item I<constructor>
454
455 Required. A closure (or reference to a function) that will return the value that
456 needs to be stored in the cache.
457
458 =item I<preload>
459
460 Optional. A closure (or reference to a function) that gets run to initialize
461 the cache when creating the tied variable.
462
463 =item I<arguments>
464
465 Optional. Array reference with the arguments that should be passed to the
466 constructor function.
467
468 =item I<timeout>
469
470 Optional. The cache timeout in seconds for the variable. Defaults to 600
471 (ten minutes).
472
473 =item I<cache_type>
474
475 Optional. Which type of cache to use for the variable. Defaults to whatever is
476 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
477 caching for the tied variable.
478
479 =item I<allowupdate>
480
481 Optional. Boolean flag to allow the variable to be updated directly. When this
482 is set and the variable is used as an l-value, the cache will be updated
483 immediately with the new value. Using this is probably a bad idea on a
484 multi-threaded system. When I<allowupdate> is not set to true, using the
485 tied variable as an l-value will have no effect.
486
487 =item I<destructor>
488
489 Optional. A closure (or reference to a function) that should be called when the
490 tied variable is destroyed.
491
492 =item I<unset>
493
494 Optional. Boolean flag to tell the object to remove the variable from the cache
495 when it is destroyed or goes out of scope.
496
497 =item I<inprocess>
498
499 Optional. Boolean flag to tell the object not to refresh the variable from the
500 cache every time the value is desired, but rather only when the I<local> copy
501 of the variable is older than the timeout.
502
503 =back
504
505 =head2 create_scalar
506
507     my $scalar = Koha::Cache->create_scalar(\%params);
508
509 Create scalar tied to the cache.
510
511 =cut
512
513 sub create_scalar {
514     my ( $self, $args ) = @_;
515
516     $self->_set_tied_defaults($args);
517
518     tie my $scalar, 'Koha::Cache::Object', $args;
519     return \$scalar;
520 }
521
522 sub create_hash {
523     my ( $self, $args ) = @_;
524
525     $self->_set_tied_defaults($args);
526
527     tie my %hash, 'Koha::Cache::Object', $args;
528     return \%hash;
529 }
530
531 sub _set_tied_defaults {
532     my ( $self, $args ) = @_;
533
534     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
535     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
536     unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
537         $args->{'cache'} = $self;
538         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
539     }
540
541     return $args;
542 }
543
544 =head1 EXPORT
545
546 None by default.
547
548 =head1 SEE ALSO
549
550 Koha::Cache::Object
551
552 =head1 AUTHOR
553
554 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
555 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
556 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
557
558 =cut
559
560 1;
561
562 __END__