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
 272         # We only save the frozen form: we do want to save $value in L1
 273         # directly in order to protect it. And thawing now may not be
 274         # needed, so improves performance.
 275         $value = $L1_encoder->encode($value);
 276         $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
 277         $flag = '-CF1';
 278     } else {
 279         # Set in L1 cache as a scalar; exit if we are caching an undef
 280         $L1_cache{$self->{namespace}}{$key} = $value;
 281         return if !defined $value;
 282     }
 283
 284     $value .= $flag;
 285     # We consider an expiry of 0 to be infinite
 286     if ( $expiry ) {
 287         return $set_sub
 288           ? $set_sub->( $key, $value, $expiry )
 289           : $self->{$cache}->set( $key, $value, $expiry );
 290     }
 291     else {
 292         return $set_sub
 293           ? $set_sub->( $key, $value )
 294           : $self->{$cache}->set( $key, $value );
 295     }
 296 }
 297
 298 =head2 get_from_cache
 299
 300     my $value = $cache->get_from_cache($key, [ $options ]);
 301
 302 Retrieve the value stored under the specified key in the cache.
 303
 304 The possible options are:
 305
 306 =over
 307
 308 =item unsafe
 309
 310 If set, this will avoid performing a deep copy of the item. This
 311 means that it won't be safe if something later modifies the result of the
 312 function. It should be used with caution, and could save processing time
 313 in some situations where is safe to use it. Make sure you know what you are doing!
 314
 315 =item cache
 316
 317 The cache object to use if you want to provide your own. It should be an
 318 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
 319
 320 =back
 321
 322 =cut
 323
 324 sub get_from_cache {
 325     my ( $self, $key, $options ) = @_;
 326     my $cache  = $options->{cache}  || 'cache';
 327     my $unsafe = $options->{unsafe} || 0;
 328     $key =~ s/[\x00-\x20]/_/g;
 329     croak "No key" unless $key;
 330     $ENV{DEBUG} && carp "get_from_cache for $key";
 331     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 332
 333     # Return L1 cache value if exists
 334     if ( exists $L1_cache{$self->{namespace}}{$key} ) {
 335         if (ref($L1_cache{$self->{namespace}}{$key})) {
 336             if ($unsafe) {
 337                 # ONLY use thawed for unsafe calls !!!
 338                 $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
 339                 return $L1_cache{$self->{namespace}}{$key}->{thawed};
 340             } else {
 341                 return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
 342             }
 343         } else {
 344             # No need to thaw if it's a scalar
 345             return $L1_cache{$self->{namespace}}{$key};
 346         }
 347     }
 348
 349     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
 350     my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
 351
 352     return if ref($L2_value);
 353     return unless (defined($L2_value) && length($L2_value) >= 4);
 354
 355     my $flag = substr($L2_value, -4, 4, '');
 356     if ($flag eq '-CF0') {
 357         # it's a scalar
 358         $L1_cache{$self->{namespace}}{$key} = $L2_value;
 359         return $L2_value;
 360     } elsif ($flag eq '-CF1') {
 361         # it's a frozen data structure
 362         my $thawed;
 363         eval { $thawed = $L1_decoder->decode($L2_value); };
 364         return if $@;
 365         $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
 366         # ONLY save thawed for unsafe calls !!!
 367         $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
 368         return $thawed;
 369     }
 370
 371     # Unknown value / data type returned from L2 cache
 372     return;
 373 }
 374
 375 =head2 clear_from_cache
 376
 377     $cache->clear_from_cache($key);
 378
 379 Remove the value identified by the specified key from the default cache.
 380
 381 =cut
 382
 383 sub clear_from_cache {
 384     my ( $self, $key, $cache ) = @_;
 385     $key =~ s/[\x00-\x20]/_/g;
 386     $cache ||= 'cache';
 387     croak "No key" unless $key;
 388     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 389
 390     # Clear from L1 cache
 391     delete $L1_cache{$self->{namespace}}{$key};
 392
 393     return $self->{$cache}->delete($key)
 394       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 395     return $self->{$cache}->remove($key);
 396 }
 397
 398 =head2 flush_all
 399
 400     $cache->flush_all();
 401
 402 Clear the entire default cache.
 403
 404 =cut
 405
 406 sub flush_all {
 407     my ( $self, $cache ) = shift;
 408     $cache ||= 'cache';
 409     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 410
 411     $self->flush_L1_cache();
 412
 413     return $self->{$cache}->flush_all()
 414       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 415     return $self->{$cache}->clear();
 416 }
 417
 418 sub flush_L1_cache {
 419     my( $self ) = @_;
 420     delete $L1_cache{$self->{namespace}};
 421 }
 422
 423 =head1 TIED INTERFACE
 424
 425 Koha::Cache also provides a tied interface which enables users to provide a
 426 constructor closure and (after creation) treat cached data like normal reference
 427 variables and rely on the cache Just Working and getting updated when it
 428 expires, etc.
 429
 430     my $cache = Koha::Cache->new();
 431     my $data = 'whatever';
 432     my $scalar = Koha::Cache->create_scalar(
 433         {
 434             'key'         => 'whatever',
 435             'timeout'     => 2,
 436             'constructor' => sub { return $data; },
 437         }
 438     );
 439     print "$$scalar\n"; # Prints "whatever"
 440     $data = 'somethingelse';
 441     print "$$scalar\n"; # Prints "whatever" because it is cached
 442     sleep 2; # Wait until the cache entry has expired
 443     print "$$scalar\n"; # Prints "somethingelse"
 444
 445     my $hash = Koha::Cache->create_hash(
 446         {
 447             'key'         => 'whatever',
 448             'timeout'     => 2,
 449             'constructor' => sub { return $data; },
 450         }
 451     );
 452     print "$$variable\n"; # Prints "whatever"
 453
 454 The gotcha with this interface, of course, is that the variable returned by
 455 create_scalar and create_hash is a I<reference> to a tied variable and not a
 456 tied variable itself.
 457
 458 The tied variable is configured by means of a hashref passed in to the
 459 create_scalar and create_hash methods. The following parameters are supported:
 460
 461 =over
 462
 463 =item I<key>
 464
 465 Required. The key to use for identifying the variable in the cache.
 466
 467 =item I<constructor>
 468
 469 Required. A closure (or reference to a function) that will return the value that
 470 needs to be stored in the cache.
 471
 472 =item I<preload>
 473
 474 Optional. A closure (or reference to a function) that gets run to initialize
 475 the cache when creating the tied variable.
 476
 477 =item I<arguments>
 478
 479 Optional. Array reference with the arguments that should be passed to the
 480 constructor function.
 481
 482 =item I<timeout>
 483
 484 Optional. The cache timeout in seconds for the variable. Defaults to 600
 485 (ten minutes).
 486
 487 =item I<cache_type>
 488
 489 Optional. Which type of cache to use for the variable. Defaults to whatever is
 490 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 491 caching for the tied variable.
 492
 493 =item I<allowupdate>
 494
 495 Optional. Boolean flag to allow the variable to be updated directly. When this
 496 is set and the variable is used as an l-value, the cache will be updated
 497 immediately with the new value. Using this is probably a bad idea on a
 498 multi-threaded system. When I<allowupdate> is not set to true, using the
 499 tied variable as an l-value will have no effect.
 500
 501 =item I<destructor>
 502
 503 Optional. A closure (or reference to a function) that should be called when the
 504 tied variable is destroyed.
 505
 506 =item I<unset>
 507
 508 Optional. Boolean flag to tell the object to remove the variable from the cache
 509 when it is destroyed or goes out of scope.
 510
 511 =item I<inprocess>
 512
 513 Optional. Boolean flag to tell the object not to refresh the variable from the
 514 cache every time the value is desired, but rather only when the I<local> copy
 515 of the variable is older than the timeout.
 516
 517 =back
 518
 519 =head2 create_scalar
 520
 521     my $scalar = Koha::Cache->create_scalar(\%params);
 522
 523 Create scalar tied to the cache.
 524
 525 =cut
 526
 527 sub create_scalar {
 528     my ( $self, $args ) = @_;
 529
 530     $self->_set_tied_defaults($args);
 531
 532     tie my $scalar, 'Koha::Cache::Object', $args;
 533     return \$scalar;
 534 }
 535
 536 sub create_hash {
 537     my ( $self, $args ) = @_;
 538
 539     $self->_set_tied_defaults($args);
 540
 541     tie my %hash, 'Koha::Cache::Object', $args;
 542     return \%hash;
 543 }
 544
 545 sub _set_tied_defaults {
 546     my ( $self, $args ) = @_;
 547
 548     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 549     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 550     unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
 551         $args->{'cache'} = $self;
 552         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 553     }
 554
 555     return $args;
 556 }
 557
 558 =head1 EXPORT
 559
 560 None by default.
 561
 562 =head1 SEE ALSO
 563
 564 Koha::Cache::Object
 565
 566 =head1 AUTHOR
 567
 568 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 569 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 570 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 571
 572 =cut
 573
 574 1;
 575
 576 __END__