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