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