From b07f4debb73b01aa0a72a2b10506e171e79a8c05 Mon Sep 17 00:00:00 2001 From: Jared Camins-Esakov Date: Sat, 19 Jan 2013 13:59:47 -0500 Subject: [PATCH] Bug 9434: Introduce new tied cache system At the moment we cache numerous pieces of information in module-level variables which then do not get updated in other threads/processes when they are changed by the user. This is a serious usability issue. Examples of this include the way we treat sysprefs (there is now a method to disable the syspref cache, but by default it is enabled), notices, frameworks, field mappings, and koha-conf.xml, at least. This patch sets the stage for eliminating this problem by making it possible to convert module-level cache variables into variables that are actually backed by whatever caching system may be configured. This is done through a special Koha::Cache::Object class which can be tied to the variables that are being used for caching and provided with a constructor method/closure to allow the cache to be reloaded when it expires. For example: my $cache = Koha::Cache->new(); my $data = 'whatever'; my $variable = Koha::Cache->create_scalar( { 'key' => 'whatever', 'timeout' => 2, 'constructor' => sub { return $data; }, } ); print "$$variable\n"; # Prints "whatever" The one change this necessitates for accessing the data is that the variable must be dereferenced an additional time before use (i.e. $$variable instead of $variable). There is no difference when the variable tied is a hash (created with Koha::Cache->create_hash). This is a small price to pay for Koha working in a multi-threaded, persistent environment. This change will also make caching easier in general. CHI was incompatible with the variable tying, so this patch also removes the dependency on CHI, using instead Cache::Memcached::Fast, Cache::FastMmap, and Cache::Memory, when they are available. To test: 1) Apply patch. 2) Run unit test t/Cache.t (after setting the MEMCACHED_SERVERS and CACHING_SYSTEM environment variables). As no changes were made to the tests already in that file, this passing demonstrates there are no regressions. 3) With memcached caching enabled (you must set the MEMCACHED_SERVERS and CACHING_SYSTEM environment variables) and DEBUG turned on (i.e. the DEBUG environment variable set to 1), try running a report via the web service ([intranet]/cgi-bin/koha/svc/report?id=1 and check your web server logs to confirm that there are messages like "get_from_cache for intranet:report:id:1" in them. 4) If the reports worked, sign off. NOTE: Technically you could test this without needing memcached by installing libcache-fastmmap-perl and setting CACHING_SYSTEM to 'fastmmap' instead of 'memcached'. You could also install libcache-perl and set CACHING_SYSTEM to 'memory' but there would be little point as the cached variables would go out of scope in between runs. Signed-off-by: Jonathan Druart Signed-off-by: Paul Poulain Signed-off-by: Jared Camins-Esakov --- C4/Installer/PerlDependencies.pm | 8 +- Koha/Cache.pm | 366 ++++++++++++++++++++++++++----- Koha/Cache/Fastmmap.pm | 49 ----- Koha/Cache/Memcached.pm | 124 ----------- Koha/Cache/Memory.pm | 50 ----- Koha/Cache/Null.pm | 41 ---- Koha/Cache/Object.pm | 220 +++++++++++++++++++ t/00-load.t | 1 - t/Cache.t | 136 ++++++++++-- t/optional/Cache_Memcached.t | 14 -- 10 files changed, 650 insertions(+), 359 deletions(-) delete mode 100644 Koha/Cache/Fastmmap.pm delete mode 100644 Koha/Cache/Memcached.pm delete mode 100644 Koha/Cache/Memory.pm delete mode 100644 Koha/Cache/Null.pm create mode 100644 Koha/Cache/Object.pm delete mode 100755 t/optional/Cache_Memcached.t diff --git a/C4/Installer/PerlDependencies.pm b/C4/Installer/PerlDependencies.pm index f240f25f20..535a377e64 100644 --- a/C4/Installer/PerlDependencies.pm +++ b/C4/Installer/PerlDependencies.pm @@ -254,15 +254,15 @@ our $PERL_DEPS = { 'required' => '0', 'min_ver' => '0.17' }, - 'CHI' => { + 'Cache::FastMmap' => { 'usage' => 'Caching', 'required' => '0', - 'min_ver' => '0.36' + 'min_ver' => '1.34' }, - 'CHI::Driver::Memcached' => { + 'Cache::Memory' => { 'usage' => 'Caching', 'required' => '0', - 'min_ver' => '0.12' + 'min_ver' => '2.04' }, 'Net::LDAP::Filter' => { 'usage' => 'LDAP Interface Feature', diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 740a1335c8..e119bda250 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -1,6 +1,7 @@ package Koha::Cache; # Copyright 2009 Chris Cormack and The Koha Dev Team +# Parts copyright 2012-2013 C & P Bibliography Services # # This file is part of Koha. # @@ -23,24 +24,13 @@ Koha::Cache - Handling caching of html and Objects for Koha =head1 SYNOPSIS - use Koha::Cache (cache_type => $cache_type, %params ); + use Koha::Cache; + my $cache = Koha::Cache->new({cache_type => $cache_type, %params}); =head1 DESCRIPTION -Base class for Koha::Cache::X. Subclasses must provide the following methods - -B<_cache_handle ($params_hr)> - cache handle creator - -Subclasses may override the following methods if they are not using a -CHI-derived cache - -B - -B - -B - -B +Koha caching routines. This class provides two interfaces for cache access. +The first, traditional interface provides the following functions: =head1 FUNCTIONS @@ -50,90 +40,348 @@ use strict; use warnings; use Carp; use Module::Load::Conditional qw(can_load); -use Module::Load; +use Koha::Cache::Object; -my $have_chi = 0; +use base qw(Class::Accessor); -BEGIN: { - if ( can_load( modules => { CHI => undef } ) ) { - $have_chi = 1; - } -} +__PACKAGE__->mk_ro_accessors( + qw( cache memcached_cache fastmmap_cache memory_cache )); -use base qw(Class::Accessor); +=head2 new -__PACKAGE__->mk_ro_accessors(qw( cache )); +Create a new Koha::Cache object. This is required for all cache-related functionality. + +=cut sub new { - my $class = shift; - my $param = shift; - my $cache_type = - $ENV{CACHING_SYSTEM} - || $param->{cache_type} + my ( $class, $self ) = @_; + $self->{'default_type'} = + $self->{cache_type} + || $ENV{CACHING_SYSTEM} || 'memcached'; - my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type); - $param->{have_chi} = $have_chi; - unless ( can_load( modules => { $subclass => undef } ) ) { - $subclass = __PACKAGE__ . "::" . ucfirst('Null'); - load $subclass; + + $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}"; + + $self->{'timeout'} ||= 0; + $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha'; + + if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) { + _initialize_memcached($self); + if ( $self->{'default_type'} eq 'memcached' + && defined( $self->{'memcached_cache'} ) ) + { + $self->{'cache'} = $self->{'memcached_cache'}; + } + } + + if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) { + _initialize_fastmmap($self); + if ( $self->{'default_type'} eq 'fastmmap' + && defined( $self->{'fastmmap_cache'} ) ) + { + $self->{'cache'} = $self->{'fastmmap_cache'}; + } } - my $cache = $subclass->_cache_handle($param); + + if ( can_load( modules => { 'Cache::Memory' => undef } ) ) { + _initialize_memory($self); + if ( $self->{'default_type'} eq 'memory' + && defined( $self->{'memory_cache'} ) ) + { + $self->{'cache'} = $self->{'memory_cache'}; + } + } + +# NOTE: The following five lines could be uncommented if we wanted to +# fall back to any functioning cache. Commented out since this would +# represent a change in behavior. +# +#unless (defined($self->{'cache'})) { +# foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) { +# $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember})); +# } +#} + return - bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ), - $subclass; + bless $self, + $class; +} + +sub _initialize_memcached { + my ($self) = @_; + my @servers = + split /,/, $self->{'cache_servers'} + ? $self->{'cache_servers'} + : $ENV{MEMCACHED_SERVERS}; + + $ENV{DEBUG} + && carp "Memcached server settings: " + . join( ', ', @servers ) + . " with " + . $self->{'namespace'}; + $self->{'memcached_cache'} = Cache::Memcached::Fast->new( + { + servers => \@servers, + compress_threshold => 10_000, + namespace => $self->{'namespace'}, + } + ); + return $self; } +sub _initialize_fastmmap { + my ($self) = @_; + + $self->{'fastmmap_cache'} = Cache::FastMmap->new( + 'share_file' => "/tmp/sharefile-koha-$self->{'namespace'}", + 'expire_time' => $self->{'timeout'}, + 'unlink_on_exit' => 0, + ); + return $self; +} + +sub _initialize_memory { + my ($self) = @_; + + $self->{'memory_cache'} = Cache::Memory->new( + 'namespace' => $self->{'namespace'}, + 'default_expires' => $self->{'timeout'} + ); + return $self; +} + +=head2 is_cache_active + +Routine that checks whether or not a caching system has been selected. This is +not an instance method. + +=cut + sub is_cache_active { return $ENV{CACHING_SYSTEM} ? '1' : ''; } +=head2 set_in_cache + + $cache->set_in_cache($key, $value, [$expiry]); + +Save a value to the specified key in the default cache, optionally with a +particular expiry. + +=cut + sub set_in_cache { - my ( $self, $key, $value, $expiry ) = @_; + my ( $self, $key, $value, $expiry, $cache ) = @_; + $cache ||= 'cache'; croak "No key" unless $key; - $ENV{DEBUG} && warn "set_in_cache for $key"; - - return unless $self->{cache}; - return unless $self->{have_chi}; + $ENV{DEBUG} && carp "set_in_cache for $key"; + return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); if ( defined $expiry ) { - return $self->{cache}->set( $key, $value, $expiry ); + if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) { + $expiry = "$expiry sec"; + } + return $self->{$cache}->set( $key, $value, $expiry ); } else { - return $self->{cache}->set( $key, $value ); + return $self->{$cache}->set( $key, $value ); } } +=head2 get_from_cache + + my $value = $cache->get_from_cache($key); + +Retrieve the value stored under the specified key in the default cache. + +=cut + sub get_from_cache { - my ( $self, $key ) = @_; + my ( $self, $key, $cache ) = @_; + $cache ||= 'cache'; croak "No key" unless $key; - $ENV{DEBUG} && warn "get_from_cache for $key"; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->get($key); + $ENV{DEBUG} && carp "get_from_cache for $key"; + return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + return $self->{$cache}->get($key); } +=head2 clear_from_cache + + $cache->clear_from_cache($key); + +Remove the value identified by the specified key from the default cache. + +=cut + sub clear_from_cache { - my ( $self, $key ) = @_; + my ( $self, $key, $cache ) = @_; + $cache ||= 'cache'; croak "No key" unless $key; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->remove($key); + return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + return $self->{$cache}->delete($key) + if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); + return $self->{$cache}->remove($key); } +=head2 flush_all + + $cache->flush_all(); + +Clear the entire default cache. + +=cut + sub flush_all { - my $self = shift; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->clear(); + my ( $self, $cache ) = shift; + $cache ||= 'cache'; + return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + return $self->{$cache}->flush_all() + if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); + return $self->{$cache}->clear(); +} + +=head1 TIED INTERFACE + +Koha::Cache also provides a tied interface which enables users to provide a +constructor closure and (after creation) treat cached data like normal reference +variables and rely on the cache Just Working and getting updated when it +expires, etc. + + my $cache = Koha::Cache->new(); + my $data = 'whatever'; + my $scalar = Koha::Cache->create_scalar( + { + 'key' => 'whatever', + 'timeout' => 2, + 'constructor' => sub { return $data; }, + } + ); + print "$$scalar\n"; # Prints "whatever" + $data = 'somethingelse'; + print "$$scalar\n"; # Prints "whatever" because it is cached + sleep 2; # Wait until the cache entry has expired + print "$$scalar\n"; # Prints "somethingelse" + + my $hash = Koha::Cache->create_hash( + { + 'key' => 'whatever', + 'timeout' => 2, + 'constructor' => sub { return $data; }, + } + ); + print "$$variable\n"; # Prints "whatever" + +The gotcha with this interface, of course, is that the variable returned by +create_scalar and create_hash is a I to a tied variable and not a +tied variable itself. + +The tied variable is configured by means of a hashref passed in to the +create_scalar and create_hash methods. The following parameters are supported: + +=over + +=item I + +Required. The key to use for identifying the variable in the cache. + +=item I + +Required. A closure (or reference to a function) that will return the value that +needs to be stored in the cache. + +=item I + +Optional. A closure (or reference to a function) that gets run to initialize +the cache when creating the tied variable. + +=item I + +Optional. Array reference with the arguments that should be passed to the +constructor function. + +=item I + +Optional. The cache timeout in seconds for the variable. Defaults to 600 +(ten minutes). + +=item I + +Optional. Which type of cache to use for the variable. Defaults to whatever is +set in the environment variable CACHING_SYSTEM. If set to 'null', disables +caching for the tied variable. + +=item I + +Optional. Boolean flag to allow the variable to be updated directly. When this +is set and the variable is used as an l-value, the cache will be updated +immediately with the new value. Using this is probably a bad idea on a +multi-threaded system. When I is not set to true, using the +tied variable as an l-value will have no effect. + +=item I + +Optional. A closure (or reference to a function) that should be called when the +tied variable is destroyed. + +=item I + +Optional. Boolean flag to tell the object to remove the variable from the cache +when it is destroyed or goes out of scope. + +=item I + +Optional. Boolean flag to tell the object not to refresh the variable from the +cache every time the value is desired, but rather only when the I copy +of the variable is older than the timeout. + +=back + +=head2 create_scalar + + my $scalar = Koha::Cache->create_scalar(\%params); + +Create scalar tied to the cache. + +=cut + +sub create_scalar { + my ( $self, $args ) = @_; + + $self->_set_tied_defaults($args); + + tie my $scalar, 'Koha::Cache::Object', $args; + return \$scalar; +} + +sub create_hash { + my ( $self, $args ) = @_; + + $self->_set_tied_defaults($args); + + tie my %hash, 'Koha::Cache::Object', $args; + return \%hash; +} + +sub _set_tied_defaults { + my ( $self, $args ) = @_; + + $args->{'timeout'} = '600' unless defined( $args->{'timeout'} ); + $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} ); + unless ( lc( $args->{'cache_type'} ) eq 'null' ) { + $args->{'cache'} = $self; + $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'}; + } + + return $args; } -=head2 EXPORT +=head1 EXPORT None by default. =head1 SEE ALSO -Koha::Cache::Memcached +Koha::Cache::Object =head1 AUTHOR diff --git a/Koha/Cache/Fastmmap.pm b/Koha/Cache/Fastmmap.pm deleted file mode 100644 index c5838f0753..0000000000 --- a/Koha/Cache/Fastmmap.pm +++ /dev/null @@ -1,49 +0,0 @@ -package Koha::Cache::Fastmmap; - -# Copyright 2012 C & P Bibliography Services -# -# This file is part of Koha. -# -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. -# -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - -use strict; -use warnings; -use Carp; -use Module::Load::Conditional qw(can_load); - -use base qw(Koha::Cache); - -sub _cache_handle { - my $class = shift; - my $params = shift; - if ( can_load( modules => { CHI => undef } ) ) { - return CHI->new( - driver => 'FastMmap', - namespace => $params->{'namespace'} || 'koha', - expire_in => 600, - cache_size => $params->{'cachesize'} || '1m', - ); - } else { - return; - } -} - -1; -__END__ - -=head1 NAME - -Koha::Cache::Fastmmap - persistent interprocess mmap-based cache for Koha - -=cut diff --git a/Koha/Cache/Memcached.pm b/Koha/Cache/Memcached.pm deleted file mode 100644 index fe487259ef..0000000000 --- a/Koha/Cache/Memcached.pm +++ /dev/null @@ -1,124 +0,0 @@ -package Koha::Cache::Memcached; - -# Copyright 2012 C & P Bibliography Services -# -# This file is part of Koha. -# -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. -# -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - -use strict; -use warnings; -use Carp; -use Cache::Memcached::Fast; -use Module::Load::Conditional qw(can_load); - -use base qw(Koha::Cache); - -sub _cache_handle { - my $class = shift; - my $params = shift; - my @servers = split /,/, - $params->{'cache_servers'} - ? $params->{'cache_servers'} - : $ENV{MEMCACHED_SERVERS}; - my $namespace = - $ENV{MEMCACHED_NAMESPACE} - || $params->{'namespace'} - || 'koha'; - $ENV{DEBUG} - && warn "Caching server settings: " - . join( ', ', @servers ) - . " with " - . ( $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha' ); - if ( - $params->{have_chi} - && can_load( - modules => - { 'CHI' => undef, 'CHI::Driver::Memcached::Fast' => undef } - ) - ) - { - return CHI->new( - driver => 'Memcached::Fast', - servers => \@servers, - namespace => $namespace, - compress_threshold => 10_000, - l1_cache => - { driver => 'Memory', global => 1, max_size => 1024 * 1024 }, - ); - - # We use a 1MB L1 memory cache for added efficiency - } - else { - return Cache::Memcached::Fast->new( - { - servers => \@servers, - compress_threshold => 10_000, - namespace => $namespace, - } - ); - } -} - -sub set_in_cache { - my ( $self, $key, $value, $expiry ) = @_; - return $self->SUPER::set_in_cache( $key, $value, $expiry ) - if ( $self->{have_chi} ); - - # No CHI, we have to use Cache::Memcached::Fast directly - if ( defined $expiry ) { - return $self->cache->set( $key, $value, $expiry ); - } - else { - return $self->cache->set( $key, $value ); - } -} - -sub get_from_cache { - my ( $self, $key ) = @_; - return $self->SUPER::get_from_cache($key) if ( $self->{have_chi} ); - - # No CHI, we have to use Cache::Memcached::Fast directly - return $self->cache->get($key); -} - -sub clear_from_cache { - my ( $self, $key ) = @_; - return $self->SUPER::clear_from_cache($key) if ( $self->{have_chi} ); - - # No CHI, we have to use Cache::Memcached::Fast directly - return $self->cache->delete($key); -} - -# We have to overload flush_all because CHI::Driver::Memcached::Fast does not -# support the clear() method -sub flush_all { - my $self = shift; - if ( $self->{have_chi} ) { - $self->{cache}->l1_cache->clear(); - return $self->{cache}->memd->flush_all(); - } - else { - return $self->{cache}->flush_all; - } -} - -1; -__END__ - -=head1 NAME - -Koha::Cache::Memcached - memcached subclass of Koha::Cache - -=cut diff --git a/Koha/Cache/Memory.pm b/Koha/Cache/Memory.pm deleted file mode 100644 index 1ed1096b2c..0000000000 --- a/Koha/Cache/Memory.pm +++ /dev/null @@ -1,50 +0,0 @@ -package Koha::Cache::Memory; - -# Copyright 2012 C & P Bibliography Services -# -# This file is part of Koha. -# -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. -# -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - -use strict; -use warnings; -use Carp; -use Module::Load::Conditional qw(can_load); - -use base qw(Koha::Cache); - -sub _cache_handle { - my $class = shift; - my $params = shift; - if ( can_load( modules => { CHI => undef } ) ) { - return CHI->new( - driver => 'Memory', - namespace => $params->{'namespace'} || 'koha', - expire_in => 600, - max_size => $params->{'max_size'} || 8192 * 1024, - global => 1, - ); - } else { - return; - } -} - -1; -__END__ - -=head1 NAME - -Koha::Cache::Memory - in-process memory based cache for Koha - -=cut diff --git a/Koha/Cache/Null.pm b/Koha/Cache/Null.pm deleted file mode 100644 index bde6509f92..0000000000 --- a/Koha/Cache/Null.pm +++ /dev/null @@ -1,41 +0,0 @@ -package Koha::Cache::Null; - -# Copyright 2012 C & P Bibliography Services -# -# This file is part of Koha. -# -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. -# -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - -use strict; -use warnings; -use Carp; -use Module::Load; - -use base qw(Koha::Cache); - -sub _cache_handle { - my $class = shift; - my $params = shift; - load CHI if $params->{have_chi}; - return $params->{have_chi} ? CHI->new( driver => 'Null' ) : undef; -} - -1; -__END__ - -=head1 NAME - -Koha::Cache::Null - null (no-op) cache for Koha - -=cut diff --git a/Koha/Cache/Object.pm b/Koha/Cache/Object.pm new file mode 100644 index 0000000000..f201e95724 --- /dev/null +++ b/Koha/Cache/Object.pm @@ -0,0 +1,220 @@ +package Koha::Cache::Object; + +# Copyright 2013 C & P Bibliography Services +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +=head1 NAME + +Koha::Cache::Object - Tie-able class for caching objects + +=head1 SYNOPSIS + + my $cache = Koha::Cache->new(); + my $scalar = Koha::Cache->create_scalar( + { + 'key' => 'whatever', + 'timeout' => 2, + 'constructor' => sub { return 'stuff'; }, + } + ); + my %hash = Koha::Cache->create_hash( + { + 'key' => 'whateverelse', + 'timeout' => 2, + 'constructor' => sub { return { 'stuff' => 'nonsense' }; }, + } + ); + +=head1 DESCRIPTION + +Do not use this class directly. It is tied to variables by Koha::Cache +for transparent cache access. If you choose to ignore this warning, you +should be aware that it is disturbingly polymorphic and supports both +scalars and hashes, with arrays a potential future addition. + +=head1 TIE METHODS + +=cut + +use strict; +use warnings; +use Carp; + +use base qw(Class::Accessor); + +__PACKAGE__->mk_ro_accessors( + qw( allowupdate arguments cache cache_type constructor destructor inprocess key lastupdate timeout unset value ) +); + +# General/SCALAR routines + +sub TIESCALAR { + my ( $class, $self ) = @_; + + $self->{'datatype'} ||= 'SCALAR'; + $self->{'arguments'} ||= []; + if ( defined $self->{'preload'} ) { + $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } ); + if ( defined( $self->{'cache'} ) ) { + $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'}, + $self->{'timeout'}, $self->{'cache_type'} . '_cache' ); + } + $self->{'lastupdate'} = time; + } + return bless $self, $class; +} + +sub FETCH { + my ( $self, $index ) = @_; + + $ENV{DEBUG} + && $index + && carp "Retrieving cached hash member $index of $self->{'key'}"; + + my $now = time; + + if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) ) + && $self->{'cache'} ) + { + $self->{'value'} = + $self->{'cache'} + ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' ); + $self->{'lastupdate'} = $now; + } + + if ( !defined $self->{'value'} + || ( defined $index && !exists $self->{'value'}->{$index} ) + || !defined $self->{'lastupdate'} + || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) ) + { + $self->{'value'} = + &{ $self->{'constructor'} }( @{ $self->{'arguments'} }, + $self->{'value'}, $index ); + if ( defined( $self->{'cache'} ) ) { + $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'}, + $self->{'timeout'}, $self->{'cache_type'} . '_cache' ); + } + $self->{'lastupdate'} = $now; + } + if ( $self->{'datatype'} eq 'HASH' && defined $index ) { + return $self->{'value'}->{$index}; + } + return $self->{'value'}; +} + +sub STORE { + my $value = pop @_; + my ( $self, $index ) = @_; + + if ( $self->{'datatype'} eq 'HASH' && defined($index) ) { + $self->{'value'}->{$index} = $value; + } + else { + $self->{'value'} = $value; + } + if ( defined( $self->{'allowupdate'} ) + && $self->{'allowupdate'} + && defined( $self->{'cache'} ) ) + { + $self->{'cache'} + ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'}, + $self->{'cache_type'} . '_cache' ); + } + + return $self->{'value'}; +} + +sub DESTROY { + my ($self) = @_; + + if ( defined( $self->{'destructor'} ) ) { + &{ $self->{'destructor'} }( @{ $self->{'arguments'} } ); + } + + if ( defined( $self->{'unset'} ) + && $self->{'unset'} + && defined( $self->{'cache'} ) ) + { + $self->{'cache'}->clear_from_cache( $self->{'key'}, + $self->{'cache_type'} . '_cache' ); + } + + undef $self->{'value'}; + + return $self; +} + +# HASH-specific routines + +sub TIEHASH { + my ( $class, $self, @args ) = @_; + $self->{'datatype'} = 'HASH'; + return TIESCALAR( $class, $self, @args ); +} + +sub DELETE { + my ( $self, $index ) = @_; + delete $self->{'value'}->{$index}; + return $self->STORE( $self->{'value'} ); +} + +sub EXISTS { + my ( $self, $index ) = @_; + $self->FETCH($index); + return exists $self->{'value'}->{$index}; +} + +sub FIRSTKEY { + my ($self) = @_; + $self->FETCH; + $self->{'iterator'} = [ keys %{ $self->{'value'} } ]; + return $self->NEXTKEY; +} + +sub NEXTKEY { + my ($self) = @_; + return shift @{ $self->{'iterator'} }; +} + +sub SCALAR { + my ($self) = @_; + $self->FETCH; + return scalar %{ $self->{'value'} } + if ( ref( $self->{'value'} ) eq 'HASH' ); + return; +} + +sub CLEAR { + my ($self) = @_; + return $self->DESTROY; +} + +# ARRAY-specific routines + +=head1 SEE ALSO + +Koha::Cache, tie, perltie + +=head1 AUTHOR + +Jared Camins-Esakov, Ejcamins@cpbibliography.comE + +=cut + +1; + +__END__ diff --git a/t/00-load.t b/t/00-load.t index 6a5a223d1a..002a82d060 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -42,7 +42,6 @@ find( $m =~ s{^.*/Koha/}{Koha/}; $m =~ s{/}{::}g; return if $m =~ /Koha::SearchEngine/; # Koha::SearchEngine::* are experimental - return if $m =~ /Koha::Cache::Memcached/; # optional dependency use_ok($m) || BAIL_OUT("***** PROBLEMS LOADING FILE '$m'"); }, }, diff --git a/t/Cache.t b/t/Cache.t index d595dc98c9..5a54085797 100644 --- a/t/Cache.t +++ b/t/Cache.t @@ -5,39 +5,141 @@ use strict; use warnings; -use Test::More tests => 9; +use Test::More tests => 29; + +my $destructorcount = 0; BEGIN { - use_ok('Koha::Cache'); - use_ok('C4::Context'); + use_ok('Koha::Cache'); + use_ok('Koha::Cache::Object'); + use_ok('C4::Context'); } SKIP: { - my $cache = Koha::Cache->new (); + my $cache = Koha::Cache->new(); - skip "Cache not enabled", 7 unless (Koha::Cache->is_cache_active() && defined $cache); + skip "Cache not enabled", 13 + unless ( Koha::Cache->is_cache_active() && defined $cache ); # test fetching an item that isnt in the cache - is( $cache->get_from_cache("not in here"), undef, "fetching item NOT in cache"); + is( $cache->get_from_cache("not in here"), + undef, "fetching item NOT in cache" ); # test expiry time in cache - $cache->set_in_cache("timeout", "I AM DATA", 1); # expiry time of 1 second - sleep 1; - is( $cache->get_from_cache("timeout"), undef, "fetching expired item from cache"); + $cache->set_in_cache( "timeout", "I AM DATA", 1 ); # expiry time of 1 second + sleep 2; + is( $cache->get_from_cache("timeout"), + undef, "fetching expired item from cache" ); # test fetching a valid, non expired, item from cache - $cache->set_in_cache("clear_me", "I AM MORE DATA", 1000); # overly large expiry time, clear below - $cache->set_in_cache("dont_clear_me", "I AM MORE DATA22", 1000); # overly large expiry time, clear below - is( $cache->get_from_cache("clear_me"), "I AM MORE DATA", "fetching valid item from cache"); + $cache->set_in_cache( "clear_me", "I AM MORE DATA", 1000 ) + ; # overly large expiry time, clear below + $cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22", 1000 ) + ; # overly large expiry time, clear below + is( + $cache->get_from_cache("clear_me"), + "I AM MORE DATA", + "fetching valid item from cache" + ); # test clearing from cache $cache->clear_from_cache("clear_me"); - is( $cache->get_from_cache("clear_me"), undef, "fetching cleared item from cache"); - is( $cache->get_from_cache("dont_clear_me"), "I AM MORE DATA22", "fetching valid item from cache (after clearing another item)"); + is( $cache->get_from_cache("clear_me"), + undef, "fetching cleared item from cache" ); + is( + $cache->get_from_cache("dont_clear_me"), + "I AM MORE DATA22", + "fetching valid item from cache (after clearing another item)" + ); #test flushing from cache - $cache->set_in_cache("flush_me", "testing 1 data"); + $cache->set_in_cache( "flush_me", "testing 1 data" ); $cache->flush_all; - is( $cache->get_from_cache("flush_me"), undef, "fetching flushed item from cache"); - is( $cache->get_from_cache("dont_clear_me"), undef, "fetching flushed item from cache"); + is( $cache->get_from_cache("flush_me"), + undef, "fetching flushed item from cache" ); + is( $cache->get_from_cache("dont_clear_me"), + undef, "fetching flushed item from cache" ); + + my $constructorcount = 0; + my $myscalar = $cache->create_scalar( + { + 'key' => 'myscalar', + 'timeout' => 1, + 'allowupdate' => 1, + 'unset' => 1, + 'constructor' => sub { return ++$constructorcount; }, + 'destructor' => sub { return ++$destructorcount; }, + } + ); + ok( defined($myscalar), 'Created tied scalar' ); + is( $$myscalar, 1, 'Constructor called to first initialize' ); + is( $$myscalar, 1, 'Data retrieved from cache' ); + sleep 2; + is( $$myscalar, 2, 'Constructor called again when timeout reached' ); + $$myscalar = 5; + is( $$myscalar, 5, 'Stored new value to cache' ); + is( $constructorcount, 2, 'Constructor not called after storing value' ); + undef $myscalar; + + is( $cache->get_from_cache("myscalar"), + undef, 'Item removed from cache on destruction' ); + + my %hash = ( 'key' => 'value' ); + + my $myhash = $cache->create_hash( + { + 'key' => 'myhash', + 'timeout' => 1, + 'allowupdate' => 1, + 'unset' => 1, + 'constructor' => sub { return { %hash }; }, + } + ); + + ok(defined $myhash, 'Created tied hash'); + + is($myhash->{'key'}, 'value', 'Found expected value in hash'); + ok(exists $myhash->{'key'}, 'Exists works'); + $myhash->{'key2'} = 'surprise'; + is($myhash->{'key2'}, 'surprise', 'Setting hash member worked'); + $hash{'key2'} = 'nosurprise'; + sleep 2; + is($myhash->{'key2'}, 'nosurprise', 'Cache change caught'); + + + my $foundkeys = 0; + foreach my $key (keys %{$myhash}) { + $foundkeys++; + } + + is($foundkeys, 2, 'Found expected 2 keys when iterating through hash'); + + isnt(scalar %{$myhash}, undef, 'scalar knows the hash is not empty'); + + $hash{'anotherkey'} = 'anothervalue'; + + sleep 2; + + ok(exists $myhash->{'anotherkey'}, 'Cache reset properly'); + + delete $hash{'anotherkey'}; + delete $myhash->{'anotherkey'}; + + ok(!exists $myhash->{'anotherkey'}, 'Key successfully deleted'); + + undef %hash; + %{$myhash} = (); + + is(scalar %{$myhash}, 0, 'hash cleared'); + + $hash{'key'} = 'value'; + is($myhash->{'key'}, 'value', 'retrieved value after clearing cache'); +} + +END { + SKIP: { + skip "Cache not enabled", 1 + unless ( Koha::Cache->is_cache_active() ); + is( $destructorcount, 1, 'Destructor run exactly once' ); + } } diff --git a/t/optional/Cache_Memcached.t b/t/optional/Cache_Memcached.t deleted file mode 100755 index a9366cce10..0000000000 --- a/t/optional/Cache_Memcached.t +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/perl -# -# This Koha test module is a stub! -# Add more tests here!!! - -use strict; -use warnings; - -use Test::More tests => 1; - -BEGIN { - use_ok('Koha::Cache::Memcached'); -} - -- 2.39.5