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