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