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, nocache => 1 } )
 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
 275     $L1_cache{ $key } = $value;
 276
 277     # We consider an expiry of 0 to be inifinite
 278     if ( $expiry ) {
 279         return $set_sub
 280           ? $set_sub->( $key, $value, $expiry )
 281           : $self->{$cache}->set( $key, $value, $expiry );
 282     }
 283     else {
 284         return $set_sub
 285           ? $set_sub->( $key, $value )
 286           : $self->{$cache}->set( $key, $value );
 287     }
 288 }
 289
 290 =head2 get_from_cache
 291
 292     my $value = $cache->get_from_cache($key, [ $options ]);
 293
 294 Retrieve the value stored under the specified key in the default cache.
 295
 296 The possible options are:
 297
 298 =over
 299
 300 =item unsafe
 301
 302 If set, this will avoid performing a deep copy of the item. This
 303 means that it won't be safe if something later modifies the result of the
 304 function. It should be used with caution, and could save processing time
 305 in some situations where is safe to use it. Make sure you know what you are doing!
 306
 307 =item cache
 308
 309 The cache object to use if you want to provide your own. It should be an
 310 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
 311
 312 =back
 313
 314 =cut
 315
 316 sub get_from_cache {
 317     my ( $self, $key, $options ) = @_;
 318     my $cache  = $options->{cache}  || 'cache';
 319     my $unsafe = $options->{unsafe} || 0;
 320     $key =~ s/[\x00-\x20]/_/g;
 321     croak "No key" unless $key;
 322     $ENV{DEBUG} && carp "get_from_cache for $key";
 323     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 324
 325     # Return L1 cache value if exists
 326     if ( exists $L1_cache{$key} ) {
 327         # No need to deep copy if it's a scalar
 328         # Or if we do not need to deep copy
 329         return $L1_cache{$key}
 330             if not ref $L1_cache{$key} or $unsafe;
 331         return dclone $L1_cache{$key};
 332     }
 333
 334     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
 335     my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
 336
 337     # Update the L1 cache when fetching the L2 cache
 338     # Otherwise the L1 cache won't ever be populated
 339     $L1_cache{$key} = $value;
 340
 341     $value = dclone $value if ref $L1_cache{$key} and not $unsafe;
 342
 343     return $value;
 344 }
 345
 346 =head2 clear_from_cache
 347
 348     $cache->clear_from_cache($key);
 349
 350 Remove the value identified by the specified key from the default cache.
 351
 352 =cut
 353
 354 sub clear_from_cache {
 355     my ( $self, $key, $cache ) = @_;
 356     $key =~ s/[\x00-\x20]/_/g;
 357     $cache ||= 'cache';
 358     croak "No key" unless $key;
 359     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 360
 361     # Clear from L1 cache
 362     delete $L1_cache{$key};
 363
 364     return $self->{$cache}->delete($key)
 365       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 366     return $self->{$cache}->remove($key);
 367 }
 368
 369 =head2 flush_all
 370
 371     $cache->flush_all();
 372
 373 Clear the entire default cache.
 374
 375 =cut
 376
 377 sub flush_all {
 378     my ( $self, $cache ) = shift;
 379     $cache ||= 'cache';
 380     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 381
 382     $self->flush_L1_cache();
 383
 384     return $self->{$cache}->flush_all()
 385       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 386     return $self->{$cache}->clear();
 387 }
 388
 389 sub flush_L1_cache {
 390     my( $self ) = @_;
 391     %L1_cache = ();
 392 }
 393
 394 =head1 TIED INTERFACE
 395
 396 Koha::Cache also provides a tied interface which enables users to provide a
 397 constructor closure and (after creation) treat cached data like normal reference
 398 variables and rely on the cache Just Working and getting updated when it
 399 expires, etc.
 400
 401     my $cache = Koha::Cache->new();
 402     my $data = 'whatever';
 403     my $scalar = Koha::Cache->create_scalar(
 404         {
 405             'key'         => 'whatever',
 406             'timeout'     => 2,
 407             'constructor' => sub { return $data; },
 408         }
 409     );
 410     print "$$scalar\n"; # Prints "whatever"
 411     $data = 'somethingelse';
 412     print "$$scalar\n"; # Prints "whatever" because it is cached
 413     sleep 2; # Wait until the cache entry has expired
 414     print "$$scalar\n"; # Prints "somethingelse"
 415
 416     my $hash = Koha::Cache->create_hash(
 417         {
 418             'key'         => 'whatever',
 419             'timeout'     => 2,
 420             'constructor' => sub { return $data; },
 421         }
 422     );
 423     print "$$variable\n"; # Prints "whatever"
 424
 425 The gotcha with this interface, of course, is that the variable returned by
 426 create_scalar and create_hash is a I<reference> to a tied variable and not a
 427 tied variable itself.
 428
 429 The tied variable is configured by means of a hashref passed in to the
 430 create_scalar and create_hash methods. The following parameters are supported:
 431
 432 =over
 433
 434 =item I<key>
 435
 436 Required. The key to use for identifying the variable in the cache.
 437
 438 =item I<constructor>
 439
 440 Required. A closure (or reference to a function) that will return the value that
 441 needs to be stored in the cache.
 442
 443 =item I<preload>
 444
 445 Optional. A closure (or reference to a function) that gets run to initialize
 446 the cache when creating the tied variable.
 447
 448 =item I<arguments>
 449
 450 Optional. Array reference with the arguments that should be passed to the
 451 constructor function.
 452
 453 =item I<timeout>
 454
 455 Optional. The cache timeout in seconds for the variable. Defaults to 600
 456 (ten minutes).
 457
 458 =item I<cache_type>
 459
 460 Optional. Which type of cache to use for the variable. Defaults to whatever is
 461 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 462 caching for the tied variable.
 463
 464 =item I<allowupdate>
 465
 466 Optional. Boolean flag to allow the variable to be updated directly. When this
 467 is set and the variable is used as an l-value, the cache will be updated
 468 immediately with the new value. Using this is probably a bad idea on a
 469 multi-threaded system. When I<allowupdate> is not set to true, using the
 470 tied variable as an l-value will have no effect.
 471
 472 =item I<destructor>
 473
 474 Optional. A closure (or reference to a function) that should be called when the
 475 tied variable is destroyed.
 476
 477 =item I<unset>
 478
 479 Optional. Boolean flag to tell the object to remove the variable from the cache
 480 when it is destroyed or goes out of scope.
 481
 482 =item I<inprocess>
 483
 484 Optional. Boolean flag to tell the object not to refresh the variable from the
 485 cache every time the value is desired, but rather only when the I<local> copy
 486 of the variable is older than the timeout.
 487
 488 =back
 489
 490 =head2 create_scalar
 491
 492     my $scalar = Koha::Cache->create_scalar(\%params);
 493
 494 Create scalar tied to the cache.
 495
 496 =cut
 497
 498 sub create_scalar {
 499     my ( $self, $args ) = @_;
 500
 501     $self->_set_tied_defaults($args);
 502
 503     tie my $scalar, 'Koha::Cache::Object', $args;
 504     return \$scalar;
 505 }
 506
 507 sub create_hash {
 508     my ( $self, $args ) = @_;
 509
 510     $self->_set_tied_defaults($args);
 511
 512     tie my %hash, 'Koha::Cache::Object', $args;
 513     return \%hash;
 514 }
 515
 516 sub _set_tied_defaults {
 517     my ( $self, $args ) = @_;
 518
 519     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 520     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 521     unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
 522         $args->{'cache'} = $self;
 523         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 524     }
 525
 526     return $args;
 527 }
 528
 529 =head1 EXPORT
 530
 531 None by default.
 532
 533 =head1 SEE ALSO
 534
 535 Koha::Cache::Object
 536
 537 =head1 AUTHOR
 538
 539 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 540 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 541 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 542
 543 =cut
 544
 545 1;
 546
 547 __END__