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