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