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