=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;
__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.
}
}
-# 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,
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;
}
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<Cache::*> and follow the same interface as L<Cache::Memcache>.
=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 );
}
}
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
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);
}
$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();
}
$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;
}
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;
}
$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;
}
&& $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'};
&& $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'};
use strict;
use warnings;
-use Test::More tests => 29;
+use Test::More tests => 32;
my $destructorcount = 0;
}
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"),
$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' );
}
}
projects / koha.git / commitdiff