use strict;
use warnings;
use Carp;
-use Storable qw(dclone);
use Module::Load::Conditional qw(can_load);
use Koha::Cache::Object;
+use Sereal::Encoder;
+use Sereal::Decoder;
use base qw(Class::Accessor);
qw( cache memcached_cache fastmmap_cache memory_cache ));
our %L1_cache;
+our $L1_encoder = Sereal::Encoder->new;
+our $L1_decoder = Sereal::Decoder->new;
=head2 get_instance
- my $cache = Koha::Cache->get_instance();
+ my $cache = Koha::Caches->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
=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.
=cut
sub new {
- my ( $class, $self ) = @_;
+ my ( $class, $self, $subnamespace ) = @_;
$self->{'default_type'} =
$self->{cache_type}
|| $ENV{CACHING_SYSTEM}
$self->{'timeout'} ||= 0;
$self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
+ $self->{namespace} .= ":$subnamespace:";
if ( $self->{'default_type'} eq 'memcached'
&& can_load( modules => { 'Cache::Memcached::Fast' => undef } )
# Unless memcache or fastmmap has already been picked, use memory_cache
unless ( defined( $self->{'cache'} ) ) {
- if ( can_load( modules => { 'Cache::Memory' => undef, nocache => 1 } )
+ if ( can_load( modules => { 'Cache::Memory' => undef } )
&& _initialize_memory($self) )
{
$self->{'cache'} = $self->{'memory_cache'};
Expiry time of this cached entry in seconds.
-=item unsafe
-
-If set, this will avoid performing a deep copy of the item. This
-means that it won't be safe if something later modifies the result of the
-function. It should be used with caution, and could save processing time
-in some situations where is safe to use it.
-
=item cache
The cache object to use if you want to provide your own. It should be an
$new_options->{cache} = $_cache if defined $_cache;
$options = $new_options;
}
- my $unsafe = $options->{unsafe} || 0;
# the key mustn't contain whitespace (or control characters) for memcache
# but shouldn't be any harm in applying it globally.
$expiry //= $self->{timeout};
my $set_sub = $self->{ref($self->{$cache}) . "_set"};
- # Deep copy if it's not a scalar and unsafe is not passed
- $value = dclone( $value ) if ref($value) and not $unsafe;
-
- # Set in L1 cache
- $L1_cache{ $key } = $value;
+ my $flag = '-CF0'; # 0: scalar, 1: frozen data structure
+ if (ref($value)) {
+ # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
+ $value = $L1_encoder->encode($value);
+ $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
+ $flag = '-CF1';
+ } else {
+ # Set in L1 cache as a scalar; exit if we are caching an undef
+ $L1_cache{$self->{namespace}}{$key} = $value;
+ return if !defined $value;
+ }
+ $value .= $flag;
# We consider an expiry of 0 to be inifinite
if ( $expiry ) {
return $set_sub
my $value = $cache->get_from_cache($key, [ $options ]);
-Retrieve the value stored under the specified key in the default cache.
+Retrieve the value stored under the specified key in the cache.
The possible options are:
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
# Return L1 cache value if exists
- if ( exists $L1_cache{$key} ) {
- # No need to deep copy if it's a scalar
- # Or if we do not need to deep copy
- return $L1_cache{$key}
- if not ref $L1_cache{$key} or $unsafe;
- return dclone $L1_cache{$key};
+ if ( exists $L1_cache{$self->{namespace}}{$key} ) {
+ if (ref($L1_cache{$self->{namespace}}{$key})) {
+ if ($unsafe) {
+ $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
+ return $L1_cache{$self->{namespace}}{$key}->{thawed};
+ } else {
+ return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
+ }
+ } else {
+ # No need to thaw if it's a scalar
+ return $L1_cache{$self->{namespace}}{$key};
+ }
}
my $get_sub = $self->{ref($self->{$cache}) . "_get"};
- my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
-
- # Update the L1 cache when fetching the L2 cache
- # Otherwise the L1 cache won't ever be populated
- $L1_cache{$key} = $value;
-
- $value = dclone $value if ref $L1_cache{$key} and not $unsafe;
+ my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
+
+ return if ref($L2_value);
+ return unless (defined($L2_value) && length($L2_value) >= 4);
+
+ my $flag = substr($L2_value, -4, 4, '');
+ if ($flag eq '-CF0') {
+ # it's a scalar
+ $L1_cache{$self->{namespace}}{$key} = $L2_value;
+ return $L2_value;
+ } elsif ($flag eq '-CF1') {
+ # it's a frozen data structure
+ my $thawed;
+ eval { $thawed = $L1_decoder->decode($L2_value); };
+ return if $@;
+ $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
+ $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
+ return $thawed;
+ }
- return $value;
+ # Unknown value / data type returned from L2 cache
+ return;
}
=head2 clear_from_cache
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
# Clear from L1 cache
- delete $L1_cache{$key};
+ delete $L1_cache{$self->{namespace}}{$key};
return $self->{$cache}->delete($key)
if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
sub flush_L1_cache {
my( $self ) = @_;
- %L1_cache = ();
+ delete $L1_cache{$self->{namespace}};
}
=head1 TIED INTERFACE
projects / koha-ffzg.git / blobdiff