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 =head2 get_instance
  50
  51     my $cache = Koha::Cache->get_instance();
  52
  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.
  56
  57 =cut
  58
  59 our $singleton_cache;
  60 sub get_instance {
  61     my ($class) = @_;
  62     $singleton_cache = $class->new() unless $singleton_cache;
  63     return $singleton_cache;
  64 }
  65
  66 =head2 new
  67
  68 Create a new Koha::Cache object. This is required for all cache-related functionality.
  69
  70 =cut
  71
  72 sub new {
  73     my ( $class, $self ) = @_;
  74     $self->{'default_type'} =
  75          $self->{cache_type}
  76       || $ENV{CACHING_SYSTEM}
  77       || 'memcached';
  78
  79     $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
  80
  81     $self->{'timeout'}   ||= 0;
  82     $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
  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 deepcopy
 229
 230 If set, this will perform a deep copy of the item when it's retrieved. This
 231 means that it'll be safe if something later modifies the result of the
 232 function. Will be ignored in situations where the same behaviour comes from
 233 the caching layer anyway.
 234
 235 =item cache
 236
 237 The cache object to use if you want to provide your own. It should be an
 238 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
 239
 240 =back
 241
 242 =cut
 243
 244 sub set_in_cache {
 245     my ( $self, $key, $value, $options, $_cache) = @_;
 246     # This is a bit of a hack to support the old API in case things still use it
 247     if (defined $options && (ref($options) ne 'HASH')) {
 248         my $new_options;
 249         $new_options->{expiry} = $options;
 250         $new_options->{cache} = $_cache if defined $_cache;
 251         $options = $new_options;
 252     }
 253
 254     # the key mustn't contain whitespace (or control characters) for memcache
 255     # but shouldn't be any harm in applying it globally.
 256     $key =~ s/[\x00-\x20]/_/g;
 257
 258     my $cache = $options->{cache} || 'cache';
 259     croak "No key" unless $key;
 260     $ENV{DEBUG} && carp "set_in_cache for $key";
 261
 262     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 263     my $expiry = $options->{expiry};
 264     $expiry //= $self->{timeout};
 265     my $set_sub = $self->{ref($self->{$cache}) . "_set"};
 266     # We consider an expiry of 0 to be inifinite
 267     if ( $expiry ) {
 268         return $set_sub
 269           ? $set_sub->( $key, $value, $expiry )
 270           : $self->{$cache}->set( $key, $value, $expiry );
 271     }
 272     else {
 273         return $set_sub
 274           ? $set_sub->( $key, $value )
 275           : $self->{$cache}->set( $key, $value );
 276     }
 277 }
 278
 279 =head2 get_from_cache
 280
 281     my $value = $cache->get_from_cache($key);
 282
 283 Retrieve the value stored under the specified key in the default cache.
 284
 285 =cut
 286
 287 sub get_from_cache {
 288     my ( $self, $key, $cache ) = @_;
 289     $key =~ s/[\x00-\x20]/_/g;
 290     $cache ||= 'cache';
 291     croak "No key" unless $key;
 292     $ENV{DEBUG} && carp "get_from_cache for $key";
 293     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 294     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
 295     return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
 296 }
 297
 298 =head2 clear_from_cache
 299
 300     $cache->clear_from_cache($key);
 301
 302 Remove the value identified by the specified key from the default cache.
 303
 304 =cut
 305
 306 sub clear_from_cache {
 307     my ( $self, $key, $cache ) = @_;
 308     $key =~ s/[\x00-\x20]/_/g;
 309     $cache ||= 'cache';
 310     croak "No key" unless $key;
 311     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 312     return $self->{$cache}->delete($key)
 313       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 314     return $self->{$cache}->remove($key);
 315 }
 316
 317 =head2 flush_all
 318
 319     $cache->flush_all();
 320
 321 Clear the entire default cache.
 322
 323 =cut
 324
 325 sub flush_all {
 326     my ( $self, $cache ) = shift;
 327     $cache ||= 'cache';
 328     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 329     return $self->{$cache}->flush_all()
 330       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 331     return $self->{$cache}->clear();
 332 }
 333
 334 =head1 TIED INTERFACE
 335
 336 Koha::Cache also provides a tied interface which enables users to provide a
 337 constructor closure and (after creation) treat cached data like normal reference
 338 variables and rely on the cache Just Working and getting updated when it
 339 expires, etc.
 340
 341     my $cache = Koha::Cache->new();
 342     my $data = 'whatever';
 343     my $scalar = Koha::Cache->create_scalar(
 344         {
 345             'key'         => 'whatever',
 346             'timeout'     => 2,
 347             'constructor' => sub { return $data; },
 348         }
 349     );
 350     print "$$scalar\n"; # Prints "whatever"
 351     $data = 'somethingelse';
 352     print "$$scalar\n"; # Prints "whatever" because it is cached
 353     sleep 2; # Wait until the cache entry has expired
 354     print "$$scalar\n"; # Prints "somethingelse"
 355
 356     my $hash = Koha::Cache->create_hash(
 357         {
 358             'key'         => 'whatever',
 359             'timeout'     => 2,
 360             'constructor' => sub { return $data; },
 361         }
 362     );
 363     print "$$variable\n"; # Prints "whatever"
 364
 365 The gotcha with this interface, of course, is that the variable returned by
 366 create_scalar and create_hash is a I<reference> to a tied variable and not a
 367 tied variable itself.
 368
 369 The tied variable is configured by means of a hashref passed in to the
 370 create_scalar and create_hash methods. The following parameters are supported:
 371
 372 =over
 373
 374 =item I<key>
 375
 376 Required. The key to use for identifying the variable in the cache.
 377
 378 =item I<constructor>
 379
 380 Required. A closure (or reference to a function) that will return the value that
 381 needs to be stored in the cache.
 382
 383 =item I<preload>
 384
 385 Optional. A closure (or reference to a function) that gets run to initialize
 386 the cache when creating the tied variable.
 387
 388 =item I<arguments>
 389
 390 Optional. Array reference with the arguments that should be passed to the
 391 constructor function.
 392
 393 =item I<timeout>
 394
 395 Optional. The cache timeout in seconds for the variable. Defaults to 600
 396 (ten minutes).
 397
 398 =item I<cache_type>
 399
 400 Optional. Which type of cache to use for the variable. Defaults to whatever is
 401 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 402 caching for the tied variable.
 403
 404 =item I<allowupdate>
 405
 406 Optional. Boolean flag to allow the variable to be updated directly. When this
 407 is set and the variable is used as an l-value, the cache will be updated
 408 immediately with the new value. Using this is probably a bad idea on a
 409 multi-threaded system. When I<allowupdate> is not set to true, using the
 410 tied variable as an l-value will have no effect.
 411
 412 =item I<destructor>
 413
 414 Optional. A closure (or reference to a function) that should be called when the
 415 tied variable is destroyed.
 416
 417 =item I<unset>
 418
 419 Optional. Boolean flag to tell the object to remove the variable from the cache
 420 when it is destroyed or goes out of scope.
 421
 422 =item I<inprocess>
 423
 424 Optional. Boolean flag to tell the object not to refresh the variable from the
 425 cache every time the value is desired, but rather only when the I<local> copy
 426 of the variable is older than the timeout.
 427
 428 =back
 429
 430 =head2 create_scalar
 431
 432     my $scalar = Koha::Cache->create_scalar(\%params);
 433
 434 Create scalar tied to the cache.
 435
 436 =cut
 437
 438 sub create_scalar {
 439     my ( $self, $args ) = @_;
 440
 441     $self->_set_tied_defaults($args);
 442
 443     tie my $scalar, 'Koha::Cache::Object', $args;
 444     return \$scalar;
 445 }
 446
 447 sub create_hash {
 448     my ( $self, $args ) = @_;
 449
 450     $self->_set_tied_defaults($args);
 451
 452     tie my %hash, 'Koha::Cache::Object', $args;
 453     return \%hash;
 454 }
 455
 456 sub _set_tied_defaults {
 457     my ( $self, $args ) = @_;
 458
 459     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 460     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 461     unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
 462         $args->{'cache'} = $self;
 463         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 464     }
 465
 466     return $args;
 467 }
 468
 469 =head1 EXPORT
 470
 471 None by default.
 472
 473 =head1 SEE ALSO
 474
 475 Koha::Cache::Object
 476
 477 =head1 AUTHOR
 478
 479 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 480 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 481 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 482
 483 =cut
 484
 485 1;
 486
 487 __END__