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