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