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