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 =cut
 238
 239 sub set_in_cache {
 240     my ( $self, $key, $value, $options, $_cache) = @_;
 241     # This is a bit of a hack to support the old API in case things still use it
 242     if (defined $options && (ref($options) ne 'HASH')) {
 243         my $new_options;
 244         $new_options->{expiry} = $options;
 245         $new_options->{cache} = $_cache if defined $_cache;
 246         $options = $new_options;
 247     }
 248
 249     # the key mustn't contain whitespace (or control characters) for memcache
 250     # but shouldn't be any harm in applying it globally.
 251     $key =~ s/[\x00-\x20]/_/g;
 252
 253     my $cache = $options->{cache} || 'cache';
 254     croak "No key" unless $key;
 255     $ENV{DEBUG} && carp "set_in_cache for $key";
 256
 257     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 258     my $expiry = $options->{expiry};
 259     $expiry //= $self->{timeout};
 260     my $set_sub = $self->{ref($self->{$cache}) . "_set"};
 261     # We consider an expiry of 0 to be inifinite
 262     if ( $expiry ) {
 263         return $set_sub
 264           ? $set_sub->( $key, $value, $expiry )
 265           : $self->{$cache}->set( $key, $value, $expiry );
 266     }
 267     else {
 268         return $set_sub
 269           ? $set_sub->( $key, $value )
 270           : $self->{$cache}->set( $key, $value );
 271     }
 272 }
 273
 274 =head2 get_from_cache
 275
 276     my $value = $cache->get_from_cache($key);
 277
 278 Retrieve the value stored under the specified key in the default cache.
 279
 280 =cut
 281
 282 sub get_from_cache {
 283     my ( $self, $key, $cache ) = @_;
 284     $key =~ s/[\x00-\x20]/_/g;
 285     $cache ||= 'cache';
 286     croak "No key" unless $key;
 287     $ENV{DEBUG} && carp "get_from_cache for $key";
 288     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 289     my $get_sub = $self->{ref($self->{$cache}) . "_get"};
 290     return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
 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     return $self->{$cache}->delete($key)
 308       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 309     return $self->{$cache}->remove($key);
 310 }
 311
 312 =head2 flush_all
 313
 314     $cache->flush_all();
 315
 316 Clear the entire default cache.
 317
 318 =cut
 319
 320 sub flush_all {
 321     my ( $self, $cache ) = shift;
 322     $cache ||= 'cache';
 323     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 324     return $self->{$cache}->flush_all()
 325       if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
 326     return $self->{$cache}->clear();
 327 }
 328
 329 =head1 TIED INTERFACE
 330
 331 Koha::Cache also provides a tied interface which enables users to provide a
 332 constructor closure and (after creation) treat cached data like normal reference
 333 variables and rely on the cache Just Working and getting updated when it
 334 expires, etc.
 335
 336     my $cache = Koha::Cache->new();
 337     my $data = 'whatever';
 338     my $scalar = Koha::Cache->create_scalar(
 339         {
 340             'key'         => 'whatever',
 341             'timeout'     => 2,
 342             'constructor' => sub { return $data; },
 343         }
 344     );
 345     print "$$scalar\n"; # Prints "whatever"
 346     $data = 'somethingelse';
 347     print "$$scalar\n"; # Prints "whatever" because it is cached
 348     sleep 2; # Wait until the cache entry has expired
 349     print "$$scalar\n"; # Prints "somethingelse"
 350
 351     my $hash = Koha::Cache->create_hash(
 352         {
 353             'key'         => 'whatever',
 354             'timeout'     => 2,
 355             'constructor' => sub { return $data; },
 356         }
 357     );
 358     print "$$variable\n"; # Prints "whatever"
 359
 360 The gotcha with this interface, of course, is that the variable returned by
 361 create_scalar and create_hash is a I<reference> to a tied variable and not a
 362 tied variable itself.
 363
 364 The tied variable is configured by means of a hashref passed in to the
 365 create_scalar and create_hash methods. The following parameters are supported:
 366
 367 =over
 368
 369 =item I<key>
 370
 371 Required. The key to use for identifying the variable in the cache.
 372
 373 =item I<constructor>
 374
 375 Required. A closure (or reference to a function) that will return the value that
 376 needs to be stored in the cache.
 377
 378 =item I<preload>
 379
 380 Optional. A closure (or reference to a function) that gets run to initialize
 381 the cache when creating the tied variable.
 382
 383 =item I<arguments>
 384
 385 Optional. Array reference with the arguments that should be passed to the
 386 constructor function.
 387
 388 =item I<timeout>
 389
 390 Optional. The cache timeout in seconds for the variable. Defaults to 600
 391 (ten minutes).
 392
 393 =item I<cache_type>
 394
 395 Optional. Which type of cache to use for the variable. Defaults to whatever is
 396 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 397 caching for the tied variable.
 398
 399 =item I<allowupdate>
 400
 401 Optional. Boolean flag to allow the variable to be updated directly. When this
 402 is set and the variable is used as an l-value, the cache will be updated
 403 immediately with the new value. Using this is probably a bad idea on a
 404 multi-threaded system. When I<allowupdate> is not set to true, using the
 405 tied variable as an l-value will have no effect.
 406
 407 =item I<destructor>
 408
 409 Optional. A closure (or reference to a function) that should be called when the
 410 tied variable is destroyed.
 411
 412 =item I<unset>
 413
 414 Optional. Boolean flag to tell the object to remove the variable from the cache
 415 when it is destroyed or goes out of scope.
 416
 417 =item I<inprocess>
 418
 419 Optional. Boolean flag to tell the object not to refresh the variable from the
 420 cache every time the value is desired, but rather only when the I<local> copy
 421 of the variable is older than the timeout.
 422
 423 =back
 424
 425 =head2 create_scalar
 426
 427     my $scalar = Koha::Cache->create_scalar(\%params);
 428
 429 Create scalar tied to the cache.
 430
 431 =cut
 432
 433 sub create_scalar {
 434     my ( $self, $args ) = @_;
 435
 436     $self->_set_tied_defaults($args);
 437
 438     tie my $scalar, 'Koha::Cache::Object', $args;
 439     return \$scalar;
 440 }
 441
 442 sub create_hash {
 443     my ( $self, $args ) = @_;
 444
 445     $self->_set_tied_defaults($args);
 446
 447     tie my %hash, 'Koha::Cache::Object', $args;
 448     return \%hash;
 449 }
 450
 451 sub _set_tied_defaults {
 452     my ( $self, $args ) = @_;
 453
 454     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 455     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 456     unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
 457         $args->{'cache'} = $self;
 458         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 459     }
 460
 461     return $args;
 462 }
 463
 464 =head1 EXPORT
 465
 466 None by default.
 467
 468 =head1 SEE ALSO
 469
 470 Koha::Cache::Object
 471
 472 =head1 AUTHOR
 473
 474 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 475 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 476 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 477
 478 =cut
 479
 480 1;
 481
 482 __END__