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