X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=Koha%2FCache.pm;h=ec153baff9fdb1b8c825e2ebabef7724e43d0f9b;hb=41a8005d1013815d312089c00e9e5464768e1332;hp=95ae9e02aba958c8f9f9915a905d1addbd2ca939;hpb=0c6f23a6ce45183c6396925f6018ec31090ed2cb;p=koha-ffzg.git diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 95ae9e02ab..ec153baff9 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -27,6 +27,8 @@ Koha::Cache - Handling caching of html and Objects for Koha 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. @@ -35,36 +37,26 @@ The first, traditional OO interface provides the following functions: =head1 FUNCTIONS =cut + use strict; use warnings; use Carp; -use Storable qw(dclone); 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 @@ -73,66 +65,44 @@ Create a new Koha::Cache object. This is required for all cache-related function =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, nocache => 1 } ) - && _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, @@ -140,64 +110,14 @@ sub _initialize_memcached { 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; } @@ -228,13 +148,6 @@ The possible options are: 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 @@ -245,14 +158,8 @@ instance of C and follow the same interface as L. =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 @@ -261,20 +168,29 @@ sub set_in_cache { 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}; $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 = clone( $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 + # 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{$self->{namespace}}{$key} = $value; + return if !defined $value; + } - # We consider an expiry of 0 to be inifinite + $value .= $flag; + # We consider an expiry of 0 to be infinite if ( $expiry ) { return $set_sub ? $set_sub->( $key, $value, $expiry ) @@ -291,7 +207,7 @@ sub set_in_cache { 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: @@ -319,28 +235,48 @@ sub get_from_cache { 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} ) { - # 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) { + # 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 $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 = clone $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; + # ONLY save thawed for unsafe calls !!! + $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 @@ -359,7 +295,7 @@ sub 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' ); @@ -388,7 +324,7 @@ sub flush_all { sub flush_L1_cache { my( $self ) = @_; - %L1_cache = (); + delete $L1_cache{$self->{namespace}}; } =head1 TIED INTERFACE