Bugzilla – Attachment 14894 Details for
Bug 9434
Introduce new tied cache system
Home
|
New
|
Browse
|
Search
|
[?]
|
Reports
|
Help
|
New Account
|
Log In
[x]
|
Forgot Password
Login:
[x]
[patch]
Bug 9434: Introduce new tied cache system
Bug-9434-Introduce-new-tied-cache-system.patch (text/plain), 36.90 KB, created by
Jonathan Druart
on 2013-01-28 14:42:57 UTC
(
hide
)
Description:
Bug 9434: Introduce new tied cache system
Filename:
MIME Type:
Creator:
Jonathan Druart
Created:
2013-01-28 14:42:57 UTC
Size:
36.90 KB
patch
obsolete
>From 573cbd3999f2d132c5bda8714c6e66345fed15fb Mon Sep 17 00:00:00 2001 >From: Jared Camins-Esakov <jcamins@cpbibliography.com> >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 <jonathan.druart@biblibre.com> >--- > 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 41fa8db..b4c3ff5 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 740a133..e119bda 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<set_in_cache ($key, $value, $expiry)> >- >-B<get_from_cache ($key)> >- >-B<clear_from_cache ($key)> >- >-B<flush_all ()> >+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<reference> 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<key> >+ >+Required. The key to use for identifying the variable in the cache. >+ >+=item I<constructor> >+ >+Required. A closure (or reference to a function) that will return the value that >+needs to be stored in the cache. >+ >+=item I<preload> >+ >+Optional. A closure (or reference to a function) that gets run to initialize >+the cache when creating the tied variable. >+ >+=item I<arguments> >+ >+Optional. Array reference with the arguments that should be passed to the >+constructor function. >+ >+=item I<timeout> >+ >+Optional. The cache timeout in seconds for the variable. Defaults to 600 >+(ten minutes). >+ >+=item I<cache_type> >+ >+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<allowupdate> >+ >+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<allowupdate> is not set to true, using the >+tied variable as an l-value will have no effect. >+ >+=item I<destructor> >+ >+Optional. A closure (or reference to a function) that should be called when the >+tied variable is destroyed. >+ >+=item I<unset> >+ >+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<inprocess> >+ >+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<local> 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 c5838f0..0000000 >--- 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 fe48725..0000000 >--- 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 1ed1096..0000000 >--- 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 bde6509..0000000 >--- 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 0000000..f201e95 >--- /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, E<lt>jcamins@cpbibliography.comE<gt> >+ >+=cut >+ >+1; >+ >+__END__ >diff --git a/t/00-load.t b/t/00-load.t >index 6a5a223..002a82d 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 d595dc9..5a54085 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 a9366cc..0000000 >--- 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'); >-} >- >-- >1.7.10.4
You cannot view the attachment while viewing its details because your browser does not support IFRAMEs.
View the attachment on a separate page
.
View Attachment As Diff
View Attachment As Raw
Actions:
View
|
Diff
|
Splinter Review
Attachments on
bug 9434
:
14764
|
14786
|
14894
|
16547