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