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