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 under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 2 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  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
  44 use base qw(Class::Accessor);
  45
  46 __PACKAGE__->mk_ro_accessors(
  47     qw( cache memcached_cache fastmmap_cache memory_cache ));
  48
  49 =head2 get_instance
  50
  51     my $cache = Koha::Cache->get_instance();
  52
  53 This gets a shared instance of the cache, set up in a very default way. This is
  54 the recommended way to fetch a cache object. If possible, it'll be
  55 persistent across multiple instances.
  56
  57 =cut
  58
  59 our $singleton_cache;
  60 sub get_instance {
  61     my ($class) = @_;
  62     $singleton_cache = $class->new() unless $singleton_cache;
  63     return $singleton_cache;
  64 }
  65
  66 =head2 new
  67
  68 Create a new Koha::Cache object. This is required for all cache-related functionality.
  69
  70 =cut
  71
  72 sub new {
  73     my ( $class, $self ) = @_;
  74     $self->{'default_type'} =
  75          $self->{cache_type}
  76       || $ENV{CACHING_SYSTEM}
  77       || 'memcached';
  78
  79     $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
  80
  81     $self->{'timeout'}   ||= 0;
  82     $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
  83
  84     if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
  85         _initialize_memcached($self);
  86         if ( $self->{'default_type'} eq 'memcached'
  87             && defined( $self->{'memcached_cache'} ) )
  88         {
  89             $self->{'cache'} = $self->{'memcached_cache'};
  90         }
  91     }
  92
  93     if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
  94         _initialize_fastmmap($self);
  95         if ( $self->{'default_type'} eq 'fastmmap'
  96             && defined( $self->{'fastmmap_cache'} ) )
  97         {
  98             $self->{'cache'} = $self->{'fastmmap_cache'};
  99         }
 100     }
 101
 102     if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
 103         _initialize_memory($self);
 104         if ( $self->{'default_type'} eq 'memory'
 105             && defined( $self->{'memory_cache'} ) )
 106         {
 107             $self->{'cache'} = $self->{'memory_cache'};
 108         }
 109     }
 110
 111     # Unless a default has already been picked, we go through in best-to-
 112     # least-best order, looking for something we can use. fastmmap_cache
 113     # is excluded because it doesn't support expiry in a useful way.
 114     unless ( defined( $self->{'cache'} ) ) {
 115         foreach my $cachemember (qw(memcached_cache memory_cache )) {
 116             if ( defined( $self->{$cachemember} ) ) {
 117                 $self->{'cache'} = $self->{$cachemember};
 118                 last;
 119             }
 120         }
 121     }
 122
 123     $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
 124
 125     return
 126       bless $self,
 127       $class;
 128 }
 129
 130 sub _initialize_memcached {
 131     my ($self) = @_;
 132     my @servers =
 133       split /,/, $self->{'cache_servers'}
 134       ? $self->{'cache_servers'}
 135       : ($ENV{MEMCACHED_SERVERS} || '');
 136     return if !@servers;
 137
 138     $ENV{DEBUG}
 139       && carp "Memcached server settings: "
 140       . join( ', ', @servers )
 141       . " with "
 142       . $self->{'namespace'};
 143     # Cache::Memcached::Fast doesn't allow a default expire time to be set
 144     # so we force it on setting.
 145     my $memcached = Cache::Memcached::Fast->new(
 146         {
 147             servers            => \@servers,
 148             compress_threshold => 10_000,
 149             namespace          => $self->{'namespace'},
 150             utf8               => 1,
 151         }
 152     );
 153     # Ensure we can actually talk to the memcached server
 154     my $ismemcached = $memcached->set('ismemcached','1');
 155     return $self unless $ismemcached;
 156     $self->{'memcached_cache'} = $memcached;
 157     return $self;
 158 }
 159
 160 sub _initialize_fastmmap {
 161     my ($self) = @_;
 162
 163     $self->{'fastmmap_cache'} = Cache::FastMmap->new(
 164         'share_file'  => "/tmp/sharefile-koha-$self->{'namespace'}",
 165         'expire_time' => $self->{'timeout'},
 166         'unlink_on_exit' => 0,
 167     );
 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 deepcopy
 226
 227 If set, this will perform a deep copy of the item when it's retrieved. This
 228 means that it'll be safe if something later modifies the result of the
 229 function. Will be ignored in situations where the same behaviour comes from
 230 the caching layer anyway.
 231
 232 =item cache
 233
 234 The cache object to use if you want to provide your own. It should be an
 235 instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
 236
 237 =back
 238
 239 =cut
 240
 241 sub set_in_cache {
 242     my ( $self, $key, $value, $options, $_cache) = @_;
 243     # This is a bit of a hack to support the old API in case things still use it
 244     if (defined $options && (ref($options) ne 'HASH')) {
 245         my $new_options;
 246         $new_options->{expiry} = $options;
 247         $new_options->{cache} = $_cache if defined $_cache;
 248         $options = $new_options;
 249     }
 250
 251     # the key mustn't contain whitespace (or control characters) for memcache
 252     # but shouldn't be any harm in applying it globally.
 253     $key =~ s/[\x00-\x20]/_/g;
 254
 255     my $cache = $options->{cache} || 'cache';
 256     croak "No key" unless $key;
 257     $ENV{DEBUG} && carp "set_in_cache for $key";
 258
 259     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 260     my $expiry = $options->{expiry};
 261     $expiry //= $self->{timeout};
 262     my $set_sub = $self->{ref($self->{$cache}) . "_set"};
 263     # We consider an expiry of 0 to be inifinite
 264     if ( $expiry ) {
 265         return $set_sub
 266           ? $set_sub->( $key, $value, $expiry )
 267           : $self->{$cache}->set( $key, $value, $expiry );
 268     }
 269     else {
 270         return $set_sub
 271           ? $set_sub->( $key, $value )
 272           : $self->{$cache}->set( $key, $value );
 273     }
 274 }
 275
 276 =head2 get_from_cache
 277
 278     my $value = $cache->get_from_cache($key);
 279
 280 Retrieve the value stored under the specified key in the default cache.
 281
 282 =cut
 283
 284 sub get_from_cache {
 285     my ( $self, $key, $cache ) = @_;
 286     $key =~ s/[\x00-\x20]/_/g;
 287     $cache ||= 'cache';
 288     croak "No key" unless $key;
 289     $ENV{DEBUG} && carp "get_from_cache for $key";
 290     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 291     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
 292     return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
 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     return $self->{$cache}->delete($key)
 310       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 311     return $self->{$cache}->remove($key);
 312 }
 313
 314 =head2 flush_all
 315
 316     $cache->flush_all();
 317
 318 Clear the entire default cache.
 319
 320 =cut
 321
 322 sub flush_all {
 323     my ( $self, $cache ) = shift;
 324     $cache ||= 'cache';
 325     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 326     return $self->{$cache}->flush_all()
 327       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 328     return $self->{$cache}->clear();
 329 }
 330
 331 =head1 TIED INTERFACE
 332
 333 Koha::Cache also provides a tied interface which enables users to provide a
 334 constructor closure and (after creation) treat cached data like normal reference
 335 variables and rely on the cache Just Working and getting updated when it
 336 expires, etc.
 337
 338     my $cache = Koha::Cache->new();
 339     my $data = 'whatever';
 340     my $scalar = Koha::Cache->create_scalar(
 341         {
 342             'key'         => 'whatever',
 343             'timeout'     => 2,
 344             'constructor' => sub { return $data; },
 345         }
 346     );
 347     print "$$scalar\n"; # Prints "whatever"
 348     $data = 'somethingelse';
 349     print "$$scalar\n"; # Prints "whatever" because it is cached
 350     sleep 2; # Wait until the cache entry has expired
 351     print "$$scalar\n"; # Prints "somethingelse"
 352
 353     my $hash = Koha::Cache->create_hash(
 354         {
 355             'key'         => 'whatever',
 356             'timeout'     => 2,
 357             'constructor' => sub { return $data; },
 358         }
 359     );
 360     print "$$variable\n"; # Prints "whatever"
 361
 362 The gotcha with this interface, of course, is that the variable returned by
 363 create_scalar and create_hash is a I<reference> to a tied variable and not a
 364 tied variable itself.
 365
 366 The tied variable is configured by means of a hashref passed in to the
 367 create_scalar and create_hash methods. The following parameters are supported:
 368
 369 =over
 370
 371 =item I<key>
 372
 373 Required. The key to use for identifying the variable in the cache.
 374
 375 =item I<constructor>
 376
 377 Required. A closure (or reference to a function) that will return the value that
 378 needs to be stored in the cache.
 379
 380 =item I<preload>
 381
 382 Optional. A closure (or reference to a function) that gets run to initialize
 383 the cache when creating the tied variable.
 384
 385 =item I<arguments>
 386
 387 Optional. Array reference with the arguments that should be passed to the
 388 constructor function.
 389
 390 =item I<timeout>
 391
 392 Optional. The cache timeout in seconds for the variable. Defaults to 600
 393 (ten minutes).
 394
 395 =item I<cache_type>
 396
 397 Optional. Which type of cache to use for the variable. Defaults to whatever is
 398 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 399 caching for the tied variable.
 400
 401 =item I<allowupdate>
 402
 403 Optional. Boolean flag to allow the variable to be updated directly. When this
 404 is set and the variable is used as an l-value, the cache will be updated
 405 immediately with the new value. Using this is probably a bad idea on a
 406 multi-threaded system. When I<allowupdate> is not set to true, using the
 407 tied variable as an l-value will have no effect.
 408
 409 =item I<destructor>
 410
 411 Optional. A closure (or reference to a function) that should be called when the
 412 tied variable is destroyed.
 413
 414 =item I<unset>
 415
 416 Optional. Boolean flag to tell the object to remove the variable from the cache
 417 when it is destroyed or goes out of scope.
 418
 419 =item I<inprocess>
 420
 421 Optional. Boolean flag to tell the object not to refresh the variable from the
 422 cache every time the value is desired, but rather only when the I<local> copy
 423 of the variable is older than the timeout.
 424
 425 =back
 426
 427 =head2 create_scalar
 428
 429     my $scalar = Koha::Cache->create_scalar(\%params);
 430
 431 Create scalar tied to the cache.
 432
 433 =cut
 434
 435 sub create_scalar {
 436     my ( $self, $args ) = @_;
 437
 438     $self->_set_tied_defaults($args);
 439
 440     tie my $scalar, 'Koha::Cache::Object', $args;
 441     return \$scalar;
 442 }
 443
 444 sub create_hash {
 445     my ( $self, $args ) = @_;
 446
 447     $self->_set_tied_defaults($args);
 448
 449     tie my %hash, 'Koha::Cache::Object', $args;
 450     return \%hash;
 451 }
 452
 453 sub _set_tied_defaults {
 454     my ( $self, $args ) = @_;
 455
 456     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 457     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 458     unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
 459         $args->{'cache'} = $self;
 460         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 461     }
 462
 463     return $args;
 464 }
 465
 466 =head1 EXPORT
 467
 468 None by default.
 469
 470 =head1 SEE ALSO
 471
 472 Koha::Cache::Object
 473
 474 =head1 AUTHOR
 475
 476 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 477 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 478 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 479
 480 =cut
 481
 482 1;
 483
 484 __END__