From d0d38ade99f78f85f3be8127b1a14229195ff6b4 Mon Sep 17 00:00:00 2001 From: Robin Sheat Date: Tue, 8 Apr 2014 17:51:01 +1200 Subject: [PATCH] Bug 12041 - improve Koha::Cache This makes Koha::Cache behave better by default. It will use memcached if available to do shared caching, if that's not available it will fall back to in-memory caching. It also allows for a singleton accessor to allow a single cache to be shared within a process. * Added tests to confirm UTF8-cleanness. * Added minor fixups to stop warnings. Test plan: * The t/Cache.t file runs successfully with and without the MEMCACHED_SERVERS envvar set (and memcached running in the environment.) Signed-off-by: Brendan Gallagher Signed-off-by: Jonathan Druart --- C4/External/OverDrive.pm | 6 +- Koha/Cache.pm | 150 +++++++++++++++++++++++++++++++++--------- Koha/Cache/Object.pm | 17 ++--- Koha/Template/Plugin/Cache.pm | 5 +- opac/svc/report | 10 +-- svc/report | 6 +- t/Cache.t | 24 +++++-- 7 files changed, 159 insertions(+), 59 deletions(-) diff --git a/C4/External/OverDrive.pm b/C4/External/OverDrive.pm index 4d56965..bed0d55 100644 --- a/C4/External/OverDrive.pm +++ b/C4/External/OverDrive.pm @@ -99,7 +99,7 @@ sub GetOverDriveToken { my $cache; - eval { $cache = Koha::Cache->new() }; + eval { $cache = Koha::Cache->get_instance() }; my $token; $cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token; @@ -124,7 +124,9 @@ sub GetOverDriveToken { $token = $contents->{'token_type'} . ' ' . $contents->{'access_token'}; # Fudge factor to prevent spurious failures - $cache and $cache->set_in_cache( 'overdrive_token', $token, $contents->{'expires_in'} - 5 ); + $cache + and $cache->set_in_cache( 'overdrive_token', $token, + { expiry => $contents->{'expires_in'} - 5 } ); return $token; } diff --git a/Koha/Cache.pm b/Koha/Cache.pm index e119bda..0b5e499 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -30,12 +30,11 @@ Koha::Cache - Handling caching of html and Objects for Koha =head1 DESCRIPTION Koha caching routines. This class provides two interfaces for cache access. -The first, traditional interface provides the following functions: +The first, traditional OO interface provides the following functions: =head1 FUNCTIONS =cut - use strict; use warnings; use Carp; @@ -47,6 +46,23 @@ use base qw(Class::Accessor); __PACKAGE__->mk_ro_accessors( qw( cache memcached_cache fastmmap_cache memory_cache )); +=head2 get_instance + + my $cache = Koha::Cache->get_instance(); + +This gets a shared instance of the cache, set up in a very default way. This is +the recommended way to fetch a cache object. If possible, it'll be +persistent across multiple instances. + +=cut + +our $singleton_cache; +sub get_instance { + my ($class) = @_; + $singleton_cache = $class->new() unless $singleton_cache; + return $singleton_cache; +} + =head2 new Create a new Koha::Cache object. This is required for all cache-related functionality. @@ -92,15 +108,19 @@ sub new { } } -# 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})); -# } -#} + # Unless a default has already been picked, we go through in best-to- + # least-best order, looking for something we can use. fastmmap_cache + # is excluded because it doesn't support expiry in a useful way. + unless ( defined( $self->{'cache'} ) ) { + foreach my $cachemember (qw(memcached_cache memory_cache )) { + if ( defined( $self->{$cachemember} ) ) { + $self->{'cache'} = $self->{$cachemember}; + last; + } + } + } + + $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none'); return bless $self, @@ -112,20 +132,28 @@ sub _initialize_memcached { my @servers = split /,/, $self->{'cache_servers'} ? $self->{'cache_servers'} - : $ENV{MEMCACHED_SERVERS}; + : ($ENV{MEMCACHED_SERVERS} || ''); + return if !@servers; $ENV{DEBUG} && carp "Memcached server settings: " . join( ', ', @servers ) . " with " . $self->{'namespace'}; - $self->{'memcached_cache'} = Cache::Memcached::Fast->new( + # Cache::Memcached::Fast doesn't allow a default expire time to be set + # so we force it on setting. + my $memcached = Cache::Memcached::Fast->new( { servers => \@servers, compress_threshold => 10_000, namespace => $self->{'namespace'}, + utf8 => 1, } ); + # Ensure we can actually talk to the memcached server + my $ismemcached = $memcached->set('ismemcached','1'); + return $self unless $ismemcached; + $self->{'memcached_cache'} = $memcached; return $self; } @@ -143,48 +171,103 @@ sub _initialize_fastmmap { sub _initialize_memory { my ($self) = @_; - $self->{'memory_cache'} = Cache::Memory->new( + # Default cache time for memory is _always_ short unless it's specially + # defined, to allow it to work reliably in a persistent environment. + my $cache = Cache::Memory->new( 'namespace' => $self->{'namespace'}, - 'default_expires' => $self->{'timeout'} + 'default_expires' => "$self->{'timeout'} sec" || "10 sec", ); + $self->{'memory_cache'} = $cache; + # Memory cache can't handle complex types for some reason, so we use its + # freeze and thaw functions. + $self->{ref($cache) . '_set'} = sub { + my ($key, $val, $exp) = @_; + # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing. + $exp = "$exp sec" if defined $exp; + # Because we need to use freeze, it must be a reference type. + $cache->freeze($key, [$val], $exp); + }; + $self->{ref($cache) . '_get'} = sub { + my $res = $cache->thaw(shift); + return unless defined $res; + return $res->[0]; + }; return $self; } =head2 is_cache_active -Routine that checks whether or not a caching system has been selected. This is -not an instance method. +Routine that checks whether or not a default caching method is active on this +object. =cut sub is_cache_active { - return $ENV{CACHING_SYSTEM} ? '1' : ''; + my $self = shift; + return $self->{'cache'} ? 1 : 0; } =head2 set_in_cache - $cache->set_in_cache($key, $value, [$expiry]); + $cache->set_in_cache($key, $value, [$options]); + +Save a value to the specified key in the cache. A hashref of options may be +specified. -Save a value to the specified key in the default cache, optionally with a -particular expiry. +The possible options are: + +=over + +=item expiry + +Expiry time of this cached entry in seconds. + +=item deepcopy + +If set, this will perform a deep copy of the item when it's retrieved. This +means that it'll be safe if something later modifies the result of the +function. Will be ignored in situations where the same behaviour comes from +the caching layer anyway. + +=item cache + +The cache object to use if you want to provide your own. It should be an +instance of C and follow the same interface as L. =cut sub set_in_cache { - my ( $self, $key, $value, $expiry, $cache ) = @_; - $cache ||= 'cache'; + my ( $self, $key, $value, $options, $_cache) = @_; + # This is a bit of a hack to support the old API in case things still use it + if (defined $options && (ref($options) ne 'HASH')) { + my $new_options; + $new_options->{expiry} = $options; + $new_options->{cache} = $_cache if defined $_cache; + $options = $new_options; + } + + # the key mustn't contain whitespace (or control characters) for memcache + # but shouldn't be any harm in applying it globally. + $key =~ s/[\x00-\x20]/_/g; + + my $cache = $options->{cache} || 'cache'; croak "No key" unless $key; $ENV{DEBUG} && carp "set_in_cache for $key"; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); - if ( defined $expiry ) { - if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) { - $expiry = "$expiry sec"; - } - return $self->{$cache}->set( $key, $value, $expiry ); + my $expiry = $options->{expiry}; + $expiry //= $self->{timeout}; + my $set_sub = $self->{ref($self->{$cache}) . "_set"}; + # We consider an expiry of 0 to be inifinite + if ( $expiry ) { + return $set_sub + ? $set_sub->( $key, $value, $expiry ) + : $self->{$cache}->set( $key, $value, $expiry ); } else { - return $self->{$cache}->set( $key, $value ); + return $set_sub + ? $set_sub->( $key, $value ) + : $self->{$cache}->set( $key, $value ); } } @@ -198,11 +281,13 @@ Retrieve the value stored under the specified key in the default cache. sub get_from_cache { my ( $self, $key, $cache ) = @_; + $key =~ s/[\x00-\x20]/_/g; $cache ||= 'cache'; croak "No key" unless $key; $ENV{DEBUG} && carp "get_from_cache for $key"; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); - return $self->{$cache}->get($key); + my $get_sub = $self->{ref($self->{$cache}) . "_get"}; + return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); } =head2 clear_from_cache @@ -215,11 +300,12 @@ Remove the value identified by the specified key from the default cache. sub clear_from_cache { my ( $self, $key, $cache ) = @_; + $key =~ s/[\x00-\x20]/_/g; $cache ||= 'cache'; croak "No key" unless $key; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); return $self->{$cache}->delete($key) - if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); + if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); return $self->{$cache}->remove($key); } @@ -236,7 +322,7 @@ sub flush_all { $cache ||= 'cache'; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); return $self->{$cache}->flush_all() - if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' ); + if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); return $self->{$cache}->clear(); } diff --git a/Koha/Cache/Object.pm b/Koha/Cache/Object.pm index f201e95..b5f947c 100644 --- a/Koha/Cache/Object.pm +++ b/Koha/Cache/Object.pm @@ -71,7 +71,7 @@ sub TIESCALAR { $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' ); + { expiry => $self->{'timeout'} } ); } $self->{'lastupdate'} = time; } @@ -90,9 +90,7 @@ sub FETCH { if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) ) && $self->{'cache'} ) { - $self->{'value'} = - $self->{'cache'} - ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' ); + $self->{'value'} = $self->{'cache'}->get_from_cache( $self->{'key'} ); $self->{'lastupdate'} = $now; } @@ -106,7 +104,7 @@ sub FETCH { $self->{'value'}, $index ); if ( defined( $self->{'cache'} ) ) { $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'}, - $self->{'timeout'}, $self->{'cache_type'} . '_cache' ); + { expiry => $self->{'timeout'} } ); } $self->{'lastupdate'} = $now; } @@ -130,9 +128,9 @@ sub STORE { && $self->{'allowupdate'} && defined( $self->{'cache'} ) ) { - $self->{'cache'} - ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'}, - $self->{'cache_type'} . '_cache' ); + $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'}, + { expiry => $self->{'timeout'} }, + ); } return $self->{'value'}; @@ -149,8 +147,7 @@ sub DESTROY { && $self->{'unset'} && defined( $self->{'cache'} ) ) { - $self->{'cache'}->clear_from_cache( $self->{'key'}, - $self->{'cache_type'} . '_cache' ); + $self->{'cache'}->clear_from_cache( $self->{'key'} ); } undef $self->{'value'}; diff --git a/Koha/Template/Plugin/Cache.pm b/Koha/Template/Plugin/Cache.pm index fb3a76a..3b8f96c 100644 --- a/Koha/Template/Plugin/Cache.pm +++ b/Koha/Template/Plugin/Cache.pm @@ -37,7 +37,7 @@ sub new { } else { require Koha::Cache; - $cache = Koha::Cache->new( { 'cache_type' => 'memcached', 'cache_servers' => C4::Context->config('memcached_servers') }); + $cache = Koha::Cache->get_instance(); } my $self = bless { CACHE => $cache, @@ -84,7 +84,8 @@ sub _cached_action { my $result = $self->{CACHE}->get_from_cache($key); if ( !$result ) { $result = $self->{CONTEXT}->$action( $params->{template} ); - $self->{CACHE}->set_in_cache( $key, $result, $params->{ttl} ); + $self->{CACHE} + ->set_in_cache( $key, $result, { expiry => $params->{ttl} } ); } return $result; } diff --git a/opac/svc/report b/opac/svc/report index 326e276..af6b712 100755 --- a/opac/svc/report +++ b/opac/svc/report @@ -41,14 +41,14 @@ die "Sorry this report is not public\n" unless $report_rec->{public}; my @sql_params = $query->param('sql_params'); -my $cache_active = Koha::Cache->is_cache_active; -my ( $cache_key, $cache, $json_text ); +my $cache = Koha::Cache->get_instance(); +my $cache_active = $cache->is_cache_active; +my ($cache_key, $json_text); if ($cache_active) { $cache_key = "opac:report:" . ( $report_name ? "name:$report_name" : "id:$report_id" ) - . @sql_params; - $cache = Koha::Cache->new(); + . join( '-', @sql_params ); $json_text = $cache->get_from_cache($cache_key); } @@ -74,7 +74,7 @@ unless ($json_text) { if ($cache_active) { $cache->set_in_cache( $cache_key, $json_text, - $report_rec->{cache_expiry} ); + { expiry => $report_rec->{cache_expiry} } ); } } else { diff --git a/svc/report b/svc/report index 45b68e1..818e6a0 100755 --- a/svc/report +++ b/svc/report @@ -46,11 +46,11 @@ my ( $template, $loggedinuser, $cookie ) = get_template_and_user( } ); -my $cache_active = Koha::Cache->is_cache_active; -my ($cache_key, $cache, $json_text); +my $cache = Koha::Cache->get_instance(); +my $cache_active = $cache->is_cache_active; +my ($cache_key, $json_text); if ($cache_active) { $cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id"); - $cache = Koha::Cache->new(); $json_text = $cache->get_from_cache($cache_key); } diff --git a/t/Cache.t b/t/Cache.t index 044206c..65cf52b 100644 --- a/t/Cache.t +++ b/t/Cache.t @@ -5,7 +5,7 @@ use strict; use warnings; -use Test::More tests => 29; +use Test::More tests => 32; my $destructorcount = 0; @@ -16,10 +16,10 @@ BEGIN { } SKIP: { - my $cache = Koha::Cache->new(); + my $cache = Koha::Cache->get_instance(); - skip "Cache not enabled", 25 - unless ( Koha::Cache->is_cache_active() && defined $cache ); + skip "Cache not enabled", 28 + unless ( $cache->is_cache_active() && defined $cache ); # test fetching an item that isnt in the cache is( $cache->get_from_cache("not in here"), @@ -134,12 +134,26 @@ SKIP: { $hash{'key'} = 'value'; is($myhash->{'key'}, 'value', 'retrieved value after clearing cache'); + + # UTF8 testing + my $utf8_str = "A Møøse once bit my sister"; + $cache->set_in_cache('utf8_1', $utf8_str); + is($cache->get_from_cache('utf8_1'), $utf8_str, 'Simple 8-bit UTF8 correctly retrieved'); + $utf8_str = "\x{20ac}"; # € + $cache->set_in_cache('utf8_1', $utf8_str); + my $utf8_res = $cache->get_from_cache('utf8_1'); + # This'll ensure that we're getting a unicode string back, rather than + # a couple of bytes. + is(length($utf8_res), 1, 'UTF8 string length correct'); + # ...and that it's really the character we intend + is(ord($utf8_res), 8364, 'UTF8 string value correct'); } END { SKIP: { + my $cache = Koha::Cache->get_instance(); skip "Cache not enabled", 1 - unless ( Koha::Cache->is_cache_active() ); + unless ( $cache->is_cache_active() ); is( $destructorcount, 1, 'Destructor run exactly once' ); } } -- 2.0.0.rc2