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 interface provides the following functions:
  34
  35 =head1 FUNCTIONS
  36
  37 =cut
  38
  39 use strict;
  40 use warnings;
  41 use Carp;
  42 use Module::Load::Conditional qw(can_load);
  43 use Koha::Cache::Object;
  44
  45 use base qw(Class::Accessor);
  46
  47 __PACKAGE__->mk_ro_accessors(
  48     qw( cache memcached_cache fastmmap_cache memory_cache ));
  49
  50 =head2 new
  51
  52 Create a new Koha::Cache object. This is required for all cache-related functionality.
  53
  54 =cut
  55
  56 sub new {
  57     my ( $class, $self ) = @_;
  58     $self->{'default_type'} =
  59          $self->{cache_type}
  60       || $ENV{CACHING_SYSTEM}
  61       || 'memcached';
  62
  63     $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
  64
  65     $self->{'timeout'}   ||= 0;
  66     $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
  67
  68     if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
  69         _initialize_memcached($self);
  70         if ( $self->{'default_type'} eq 'memcached'
  71             && defined( $self->{'memcached_cache'} ) )
  72         {
  73             $self->{'cache'} = $self->{'memcached_cache'};
  74         }
  75     }
  76
  77     if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
  78         _initialize_fastmmap($self);
  79         if ( $self->{'default_type'} eq 'fastmmap'
  80             && defined( $self->{'fastmmap_cache'} ) )
  81         {
  82             $self->{'cache'} = $self->{'fastmmap_cache'};
  83         }
  84     }
  85
  86     if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
  87         _initialize_memory($self);
  88         if ( $self->{'default_type'} eq 'memory'
  89             && defined( $self->{'memory_cache'} ) )
  90         {
  91             $self->{'cache'} = $self->{'memory_cache'};
  92         }
  93     }
  94
  95 # NOTE: The following five lines could be uncommented if we wanted to
  96 #       fall back to any functioning cache. Commented out since this would
  97 #       represent a change in behavior.
  98 #
  99 #unless (defined($self->{'cache'})) {
 100 #    foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) {
 101 #        $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember}));
 102 #    }
 103 #}
 104
 105     return
 106       bless $self,
 107       $class;
 108 }
 109
 110 sub _initialize_memcached {
 111     my ($self) = @_;
 112     my @servers =
 113       split /,/, $self->{'cache_servers'}
 114       ? $self->{'cache_servers'}
 115       : $ENV{MEMCACHED_SERVERS};
 116
 117     $ENV{DEBUG}
 118       && carp "Memcached server settings: "
 119       . join( ', ', @servers )
 120       . " with "
 121       . $self->{'namespace'};
 122     $self->{'memcached_cache'} = Cache::Memcached::Fast->new(
 123         {
 124             servers            => \@servers,
 125             compress_threshold => 10_000,
 126             namespace          => $self->{'namespace'},
 127         }
 128     );
 129     return $self;
 130 }
 131
 132 sub _initialize_fastmmap {
 133     my ($self) = @_;
 134
 135     $self->{'fastmmap_cache'} = Cache::FastMmap->new(
 136         'share_file'  => "/tmp/sharefile-koha-$self->{'namespace'}",
 137         'expire_time' => $self->{'timeout'},
 138         'unlink_on_exit' => 0,
 139     );
 140     return $self;
 141 }
 142
 143 sub _initialize_memory {
 144     my ($self) = @_;
 145
 146     $self->{'memory_cache'} = Cache::Memory->new(
 147         'namespace'       => $self->{'namespace'},
 148         'default_expires' => $self->{'timeout'}
 149     );
 150     return $self;
 151 }
 152
 153 =head2 is_cache_active
 154
 155 Routine that checks whether or not a caching system has been selected. This is
 156 not an instance method.
 157
 158 =cut
 159
 160 sub is_cache_active {
 161     return $ENV{CACHING_SYSTEM} ? '1' : '';
 162 }
 163
 164 =head2 set_in_cache
 165
 166     $cache->set_in_cache($key, $value, [$expiry]);
 167
 168 Save a value to the specified key in the default cache, optionally with a
 169 particular expiry.
 170
 171 =cut
 172
 173 sub set_in_cache {
 174     my ( $self, $key, $value, $expiry, $cache ) = @_;
 175     $cache ||= 'cache';
 176     croak "No key" unless $key;
 177     $ENV{DEBUG} && carp "set_in_cache for $key";
 178
 179     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 180     if ( defined $expiry ) {
 181         if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {
 182             $expiry = "$expiry sec";
 183         }
 184         return $self->{$cache}->set( $key, $value, $expiry );
 185     }
 186     else {
 187         return $self->{$cache}->set( $key, $value );
 188     }
 189 }
 190
 191 =head2 get_from_cache
 192
 193     my $value = $cache->get_from_cache($key);
 194
 195 Retrieve the value stored under the specified key in the default cache.
 196
 197 =cut
 198
 199 sub get_from_cache {
 200     my ( $self, $key, $cache ) = @_;
 201     $cache ||= 'cache';
 202     croak "No key" unless $key;
 203     $ENV{DEBUG} && carp "get_from_cache for $key";
 204     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 205     return $self->{$cache}->get($key);
 206 }
 207
 208 =head2 clear_from_cache
 209
 210     $cache->clear_from_cache($key);
 211
 212 Remove the value identified by the specified key from the default cache.
 213
 214 =cut
 215
 216 sub clear_from_cache {
 217     my ( $self, $key, $cache ) = @_;
 218     $cache ||= 'cache';
 219     croak "No key" unless $key;
 220     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 221     return $self->{$cache}->delete($key)
 222       if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
 223     return $self->{$cache}->remove($key);
 224 }
 225
 226 =head2 flush_all
 227
 228     $cache->flush_all();
 229
 230 Clear the entire default cache.
 231
 232 =cut
 233
 234 sub flush_all {
 235     my ( $self, $cache ) = shift;
 236     $cache ||= 'cache';
 237     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 238     return $self->{$cache}->flush_all()
 239       if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
 240     return $self->{$cache}->clear();
 241 }
 242
 243 =head1 TIED INTERFACE
 244
 245 Koha::Cache also provides a tied interface which enables users to provide a
 246 constructor closure and (after creation) treat cached data like normal reference
 247 variables and rely on the cache Just Working and getting updated when it
 248 expires, etc.
 249
 250     my $cache = Koha::Cache->new();
 251     my $data = 'whatever';
 252     my $scalar = Koha::Cache->create_scalar(
 253         {
 254             'key'         => 'whatever',
 255             'timeout'     => 2,
 256             'constructor' => sub { return $data; },
 257         }
 258     );
 259     print "$$scalar\n"; # Prints "whatever"
 260     $data = 'somethingelse';
 261     print "$$scalar\n"; # Prints "whatever" because it is cached
 262     sleep 2; # Wait until the cache entry has expired
 263     print "$$scalar\n"; # Prints "somethingelse"
 264
 265     my $hash = Koha::Cache->create_hash(
 266         {
 267             'key'         => 'whatever',
 268             'timeout'     => 2,
 269             'constructor' => sub { return $data; },
 270         }
 271     );
 272     print "$$variable\n"; # Prints "whatever"
 273
 274 The gotcha with this interface, of course, is that the variable returned by
 275 create_scalar and create_hash is a I<reference> to a tied variable and not a
 276 tied variable itself.
 277
 278 The tied variable is configured by means of a hashref passed in to the
 279 create_scalar and create_hash methods. The following parameters are supported:
 280
 281 =over
 282
 283 =item I<key>
 284
 285 Required. The key to use for identifying the variable in the cache.
 286
 287 =item I<constructor>
 288
 289 Required. A closure (or reference to a function) that will return the value that
 290 needs to be stored in the cache.
 291
 292 =item I<preload>
 293
 294 Optional. A closure (or reference to a function) that gets run to initialize
 295 the cache when creating the tied variable.
 296
 297 =item I<arguments>
 298
 299 Optional. Array reference with the arguments that should be passed to the
 300 constructor function.
 301
 302 =item I<timeout>
 303
 304 Optional. The cache timeout in seconds for the variable. Defaults to 600
 305 (ten minutes).
 306
 307 =item I<cache_type>
 308
 309 Optional. Which type of cache to use for the variable. Defaults to whatever is
 310 set in the environment variable CACHING_SYSTEM. If set to 'null', disables
 311 caching for the tied variable.
 312
 313 =item I<allowupdate>
 314
 315 Optional. Boolean flag to allow the variable to be updated directly. When this
 316 is set and the variable is used as an l-value, the cache will be updated
 317 immediately with the new value. Using this is probably a bad idea on a
 318 multi-threaded system. When I<allowupdate> is not set to true, using the
 319 tied variable as an l-value will have no effect.
 320
 321 =item I<destructor>
 322
 323 Optional. A closure (or reference to a function) that should be called when the
 324 tied variable is destroyed.
 325
 326 =item I<unset>
 327
 328 Optional. Boolean flag to tell the object to remove the variable from the cache
 329 when it is destroyed or goes out of scope.
 330
 331 =item I<inprocess>
 332
 333 Optional. Boolean flag to tell the object not to refresh the variable from the
 334 cache every time the value is desired, but rather only when the I<local> copy
 335 of the variable is older than the timeout.
 336
 337 =back
 338
 339 =head2 create_scalar
 340
 341     my $scalar = Koha::Cache->create_scalar(\%params);
 342
 343 Create scalar tied to the cache.
 344
 345 =cut
 346
 347 sub create_scalar {
 348     my ( $self, $args ) = @_;
 349
 350     $self->_set_tied_defaults($args);
 351
 352     tie my $scalar, 'Koha::Cache::Object', $args;
 353     return \$scalar;
 354 }
 355
 356 sub create_hash {
 357     my ( $self, $args ) = @_;
 358
 359     $self->_set_tied_defaults($args);
 360
 361     tie my %hash, 'Koha::Cache::Object', $args;
 362     return \%hash;
 363 }
 364
 365 sub _set_tied_defaults {
 366     my ( $self, $args ) = @_;
 367
 368     $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
 369     $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
 370     unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
 371         $args->{'cache'} = $self;
 372         $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
 373     }
 374
 375     return $args;
 376 }
 377
 378 =head1 EXPORT
 379
 380 None by default.
 381
 382 =head1 SEE ALSO
 383
 384 Koha::Cache::Object
 385
 386 =head1 AUTHOR
 387
 388 Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
 389 Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
 390 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 391
 392 =cut
 393
 394 1;
 395
 396 __END__