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