use Koha::Cache;
my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
+ # see also Koha::Caches->get_instance;
+
=head1 DESCRIPTION
Koha caching routines. This class provides two interfaces for cache access.
=head1 FUNCTIONS
=cut
+
use strict;
use warnings;
use Carp;
-use Storable qw(freeze thaw);
use Module::Load::Conditional qw(can_load);
+use Sereal::Encoder;
+use Sereal::Decoder;
+
+use C4::Context;
use Koha::Cache::Object;
+use Koha::Config;
use base qw(Class::Accessor);
__PACKAGE__->mk_ro_accessors(
- qw( cache memcached_cache fastmmap_cache memory_cache ));
+ qw( cache memcached_cache ));
our %L1_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;
-}
+our $L1_encoder = Sereal::Encoder->new;
+our $L1_decoder = Sereal::Decoder->new;
=head2 new
=cut
sub new {
- my ( $class, $self ) = @_;
+ my ( $class, $self, $params ) = @_;
$self->{'default_type'} =
$self->{cache_type}
- || $ENV{CACHING_SYSTEM}
+ || $ENV{CACHING_SYSTEM} # DELME What about this?
|| 'memcached';
- $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
+ my $subnamespace = $params->{subnamespace} // '';
$self->{'timeout'} ||= 0;
- $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
+ # Should we continue to support MEMCACHED ENV vars?
+ $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
+ my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
+ $self->{namespace} ||= C4::Context->config('memcached_namespace') || 'koha';
+ @servers = split /,/, C4::Context->config('memcached_servers') // ''
+ unless @servers;
+ $self->{namespace} .= ":$subnamespace:";
if ( $self->{'default_type'} eq 'memcached'
- && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
- && _initialize_memcached($self)
+ && can_load( modules => { 'Cache::Memcached::Fast::Safe' => undef } )
+ && _initialize_memcached($self, @servers)
&& defined( $self->{'memcached_cache'} ) )
{
$self->{'cache'} = $self->{'memcached_cache'};
}
- if ( $self->{'default_type'} eq 'fastmmap'
- && defined( $ENV{GATEWAY_INTERFACE} )
- && can_load( modules => { 'Cache::FastMmap' => undef } )
- && _initialize_fastmmap($self)
- && defined( $self->{'fastmmap_cache'} ) )
- {
- $self->{'cache'} = $self->{'fastmmap_cache'};
- }
-
- # Unless memcache or fastmmap has already been picked, use memory_cache
- unless ( defined( $self->{'cache'} ) ) {
- if ( can_load( modules => { 'Cache::Memory' => undef } )
- && _initialize_memory($self) )
- {
- $self->{'cache'} = $self->{'memory_cache'};
- }
- }
-
- $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
-
return
bless $self,
$class;
}
sub _initialize_memcached {
- my ($self) = @_;
- my @servers =
- split /,/, $self->{'cache_servers'}
- ? $self->{'cache_servers'}
- : ($ENV{MEMCACHED_SERVERS} || '');
- return if !@servers;
-
- $ENV{DEBUG}
- && carp "Memcached server settings: "
- . join( ', ', @servers )
- . " with "
- . $self->{'namespace'};
- # Cache::Memcached::Fast doesn't allow a default expire time to be set
+ my ($self, @servers) = @_;
+
+ return unless @servers;
+
+ # Cache::Memcached::Fast::Safe doesn't allow a default expire time to be set
# so we force it on setting.
- my $memcached = Cache::Memcached::Fast->new(
+ my $memcached = Cache::Memcached::Fast::Safe->new(
{
servers => \@servers,
compress_threshold => 10_000,
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_fastmmap {
- my ($self) = @_;
- my ($cache, $share_file);
-
- # Temporary workaround to catch fatal errors when: C4::Context module
- # is not loaded beforehand, or Cache::FastMmap init fails for whatever
- # other reason (e.g. due to permission issues - see Bug 13431)
- eval {
- $share_file = join( '-',
- "/tmp/sharefile-koha", $self->{'namespace'},
- C4::Context->config('hostname'), C4::Context->config('database') );
-
- $cache = Cache::FastMmap->new(
- 'share_file' => $share_file,
- 'expire_time' => $self->{'timeout'},
- 'unlink_on_exit' => 0,
- );
- };
- if ( $@ ) {
- warn "FastMmap cache initialization failed: $@";
- return;
+ unless ($ismemcached) {
+ warn "\nConnection to the memcached servers '@servers' failed. Are the unix socket permissions set properly? Is the host reachable?\nIf you ignore this warning, you will face performance issues\n";
+ return $self;
}
- return unless defined $cache;
- $self->{'fastmmap_cache'} = $cache;
- return $self;
-}
-
-sub _initialize_memory {
- my ($self) = @_;
-
- # 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'} 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];
- };
+ $self->{'memcached_cache'} = $memcached;
return $self;
}
=cut
sub set_in_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;
- }
+ my ( $self, $key, $value, $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.
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::/ );
my $expiry = $options->{expiry};
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 = freeze($value);
- $L1_cache{$key}->{frozen} = $value;
+ # Set in L1 cache as a data structure
+ # We only save the frozen form: we do want to save $value in L1
+ # directly in order to protect it. And thawing now may not be
+ # needed, so improves performance.
+ $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{$key} = $value;
+ $L1_cache{$self->{namespace}}{$key} = $value;
return if !defined $value;
}
$value .= $flag;
- # We consider an expiry of 0 to be inifinite
+ # We consider an expiry of 0 to be infinite
if ( $expiry ) {
return $set_sub
? $set_sub->( $key, $value, $expiry )
my $unsafe = $options->{unsafe} || 0;
$key =~ s/[\x00-\x20]/_/g;
croak "No key" unless $key;
- $ENV{DEBUG} && carp "get_from_cache for $key";
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
# Return L1 cache value if exists
- if ( exists $L1_cache{$key} ) {
- if (ref($L1_cache{$key})) {
+ if ( exists $L1_cache{$self->{namespace}}{$key} ) {
+ if (ref($L1_cache{$self->{namespace}}{$key})) {
if ($unsafe) {
- $L1_cache{$key}->{thawed} ||= thaw($L1_cache{$key}->{frozen});
- return $L1_cache{$key}->{thawed};
+ # ONLY use thawed for unsafe calls !!!
+ $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
+ return $L1_cache{$self->{namespace}}{$key}->{thawed};
} else {
- return thaw($L1_cache{$key}->{frozen});
+ return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
}
} else {
# No need to thaw if it's a scalar
- return $L1_cache{$key};
+ return $L1_cache{$self->{namespace}}{$key};
}
}
my $flag = substr($L2_value, -4, 4, '');
if ($flag eq '-CF0') {
# it's a scalar
- $L1_cache{$key} = $L2_value;
+ $L1_cache{$self->{namespace}}{$key} = $L2_value;
return $L2_value;
} elsif ($flag eq '-CF1') {
# it's a frozen data structure
my $thawed;
- eval { $thawed = thaw($L2_value); };
+ eval { $thawed = $L1_decoder->decode($L2_value); };
return if $@;
- $L1_cache{$key}->{frozen} = $L2_value;
- $L1_cache{$key}->{thawed} = $thawed if $unsafe;
+ $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
+ # ONLY save thawed for unsafe calls !!!
+ $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
return $thawed;
}
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