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 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
  11 # version.
  12 #
  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.
  16 #
  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.
  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 ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
  85         _initialize_memcached($self);
  86         if ( $self->{'default_type'} eq 'memcached'
  87             && defined( $self->{'memcached_cache'} ) )
  88         {
  89             $self->{'cache'} = $self->{'memcached_cache'};
  90         }
  91     }
  92
  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'} ) )
  98         {
  99             $self->{'cache'} = $self->{'fastmmap_cache'};
 100         }
 101     }
 102
 103     if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
 104         _initialize_memory($self);
 105         if ( $self->{'default_type'} eq 'memory'
 106             && defined( $self->{'memory_cache'} ) )
 107         {
 108             $self->{'cache'} = $self->{'memory_cache'};
 109         }
 110     }
 111
 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;
 120             }
 121         }
 122     }
 123
 124     $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
 125
 126     return
 127       bless $self,
 128       $class;
 129 }
 130
 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;
 138
 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(
 147         {
 148             servers            => \@servers,
 149             compress_threshold => 10_000,
 150             namespace          => $self->{'namespace'},
 151             utf8               => 1,
 152         }
 153     );
 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;
 159 }
 160
 161 sub _initialize_fastmmap {
 162     my ($self) = @_;
 163     my ($cache, $share_file);
 164
 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') );
 172
 173         $cache = Cache::FastMmap->new(
 174             'share_file'  => $share_file,
 175             'expire_time' => $self->{'timeout'},
 176             'unlink_on_exit' => 0,
 177         );
 178     };
 179     if ( $@ ) {
 180         warn "FastMmap cache initialization failed: $@";
 181         return;
 182     }
 183     return unless defined $cache;
 184     $self->{'fastmmap_cache'} = $cache;
 185     return $self;
 186 }
 187
 188 sub _initialize_memory {
 189     my ($self) = @_;
 190
 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",
 196     );
 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);
 206     };
 207     $self->{ref($cache) . '_get'} = sub {
 208         my $res = $cache->thaw(shift);
 209         return unless defined $res;
 210         return $res->[0];
 211     };
 212     return $self;
 213 }
 214
 215 =head2 is_cache_active
 216
 217 Routine that checks whether or not a default caching method is active on this
 218 object.
 219
 220 =cut
 221
 222 sub is_cache_active {
 223     my $self = shift;
 224     return $self->{'cache'} ? 1 : 0;
 225 }
 226
 227 =head2 set_in_cache
 228
 229     $cache->set_in_cache($key, $value, [$options]);
 230
 231 Save a value to the specified key in the cache. A hashref of options may be
 232 specified.
 233
 234 The possible options are:
 235
 236 =over
 237
 238 =item expiry
 239
 240 Expiry time of this cached entry in seconds.
 241
 242 =item deepcopy
 243
 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.
 248
 249 =item cache
 250
 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>.
 253
 254 =back
 255
 256 =cut
 257
 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;
 266     }
 267
 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;
 271
 272     my $cache = $options->{cache} || 'cache';
 273     croak "No key" unless $key;
 274     $ENV{DEBUG} && carp "set_in_cache for $key";
 275
 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 );
 285     }
 286     else {
 287         return $set_sub
 288           ? $set_sub->( $key, $value )
 289           : $self->{$cache}->set( $key, $value );
 290     }
 291 }
 292
 293 =head2 get_from_cache
 294
 295     my $value = $cache->get_from_cache($key);
 296
 297 Retrieve the value stored under the specified key in the default cache.
 298
 299 =cut
 300
 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);
 310 }
 311
 312 =head2 clear_from_cache
 313
 314     $cache->clear_from_cache($key);
 315
 316 Remove the value identified by the specified key from the default cache.
 317
 318 =cut
 319
 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);
 329 }
 330
 331 =head2 flush_all
 332
 333     $cache->flush_all();
 334
 335 Clear the entire default cache.
 336
 337 =cut
 338
 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();
 346 }
 347
 348 =head1 TIED INTERFACE
 349
 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.
 354
 355     my $cache = Koha::Cache->new();
 356     my $data = 'whatever';
 357     my $scalar = Koha::Cache->create_scalar(
 358         {
 359             'key'         => 'whatever',
 360             'timeout'     => 2,
 361             'constructor' => sub { return $data; },
 362         }
 363     );
 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"
 369
 370     my $hash = Koha::Cache->create_hash(
 371         {
 372             'key'         => 'whatever',
 373             'timeout'     => 2,
 374             'constructor' => sub { return $data; },
 375         }
 376     );
 377     print "$$variable\n"; # Prints "whatever"
 378
 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.
 382
 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:
 385
 386 =over
 387
 388 =item I<key>
 389
 390 Required. The key to use for identifying the variable in the cache.
 391
 392 =item I<constructor>
 393
 394 Required. A closure (or reference to a function) that will return the value that
 395 needs to be stored in the cache.
 396
 397 =item I<preload>
 398
 399 Optional. A closure (or reference to a function) that gets run to initialize
 400 the cache when creating the tied variable.
 401
 402 =item I<arguments>
 403
 404 Optional. Array reference with the arguments that should be passed to the
 405 constructor function.
 406
 407 =item I<timeout>
 408
 409 Optional. The cache timeout in seconds for the variable. Defaults to 600
 410 (ten minutes).
 411
 412 =item I<cache_type>
 413
 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.
 417
 418 =item I<allowupdate>
 419
 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.
 425
 426 =item I<destructor>
 427
 428 Optional. A closure (or reference to a function) that should be called when the
 429 tied variable is destroyed.
 430
 431 =item I<unset>
 432
 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.
 435
 436 =item I<inprocess>
 437
 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.
 441
 442 =back
 443
 444 =head2 create_scalar
 445
 446     my $scalar = Koha::Cache->create_scalar(\%params);
 447
 448 Create scalar tied to the cache.
 449
 450 =cut
 451
 452 sub create_scalar {
 453     my ( $self, $args ) = @_;
 454
 455     $self->_set_tied_defaults($args);
 456
 457     tie my $scalar, 'Koha::Cache::Object', $args;
 458     return \$scalar;
 459 }
 460
 461 sub create_hash {
 462     my ( $self, $args ) = @_;
 463
 464     $self->_set_tied_defaults($args);
 465
 466     tie my %hash, 'Koha::Cache::Object', $args;
 467     return \%hash;
 468 }
 469
 470 sub _set_tied_defaults {
 471     my ( $self, $args ) = @_;
 472
 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'};
 478     }
 479
 480     return $args;
 481 }
 482
 483 =head1 EXPORT
 484
 485 None by default.
 486
 487 =head1 SEE ALSO
 488
 489 Koha::Cache::Object
 490
 491 =head1 AUTHOR
 492
 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>
 496
 497 =cut
 498
 499 1;
 500
 501 __END__