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