@@ -, +, @@ 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" CACHING_SYSTEM environment variables). As no changes were made to the tests already in that file, this passing demonstrates there are no regressions. 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. --- 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 --- a/C4/Installer/PerlDependencies.pm +++ a/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', --- a/Koha/Cache.pm +++ a/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 --- a/Koha/Cache/Fastmmap.pm +++ a/Koha/Cache/Fastmmap.pm @@ -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 --- a/Koha/Cache/Memcached.pm +++ a/Koha/Cache/Memcached.pm @@ -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 --- a/Koha/Cache/Memory.pm +++ a/Koha/Cache/Memory.pm @@ -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 --- a/Koha/Cache/Null.pm +++ a/Koha/Cache/Null.pm @@ -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 --- a/Koha/Cache/Object.pm +++ a/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__ --- a/t/00-load.t +++ a/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'"); }, }, --- a/t/Cache.t +++ a/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' ); + } } --- a/t/optional/Cache_Memcached.t +++ a/t/optional/Cache_Memcached.t @@ -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'); -} - --