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