X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=Koha%2FCache.pm;h=2186d827438fb8fd325c3053400b49afa32cecf6;hb=65cffa9619a319447dfee8ec3f73ab82978696cb;hp=5611c5224b04e35fe4aecb4bd87b3ef8fc5e2659;hpb=9e701294dd6ccf4fa5d8b24d1a7da15be353992e;p=koha-ffzg.git diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 5611c5224b..2186d82743 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -5,18 +5,18 @@ package Koha::Cache; # # This file is part of Koha. # -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. +# Koha is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. # -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# Koha is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +# You should have received a copy of the GNU General Public License +# along with Koha; if not, see . =head1 NAME @@ -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,34 +37,26 @@ The first, traditional OO interface provides the following functions: =head1 FUNCTIONS =cut + use strict; use warnings; -use Carp; -use Module::Load::Conditional qw(can_load); -use Koha::Cache::Object; +use Carp qw( croak ); +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 )); -=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_cache; +our $L1_encoder = Sereal::Encoder->new; +our $L1_decoder = Sereal::Decoder->new; =head2 new @@ -71,80 +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'; - - if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) { - _initialize_memcached($self); - if ( $self->{'default_type'} eq 'memcached' - && 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); - if ( defined( $self->{'fastmmap_cache'} ) ) - { - $self->{'cache'} = $self->{'fastmmap_cache'}; - } - } - - if ( can_load( modules => { 'Cache::Memory' => undef } ) ) { - _initialize_memory($self); - if ( $self->{'default_type'} eq 'memory' - && defined( $self->{'memory_cache'} ) ) - { - $self->{'cache'} = $self->{'memory_cache'}; - } - } - - # 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; - } - } + # 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::Safe' => undef } ) + && _initialize_memcached($self, @servers) + && defined( $self->{'memcached_cache'} ) ) + { + $self->{'cache'} = $self->{'memcached_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, @@ -152,55 +110,17 @@ sub _initialize_memcached { utf8 => 1, } ); + # Ensure we can actually talk to the memcached server my $ismemcached = $memcached->set('ismemcached','1'); - return $self unless $ismemcached; + 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; + } $self->{'memcached_cache'} = $memcached; return $self; } -sub _initialize_fastmmap { - my ($self) = @_; - my $share_file = join( '-', - "/tmp/sharefile-koha", $self->{'namespace'}, - C4::Context->config('hostname'), C4::Context->config('database'), - "" . getpwuid($>) ); - - $self->{'fastmmap_cache'} = Cache::FastMmap->new( - 'share_file' => $share_file, - 'expire_time' => $self->{'timeout'}, - 'unlink_on_exit' => 0, - ); - 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]; - }; - return $self; -} - =head2 is_cache_active Routine that checks whether or not a default caching method is active on this @@ -228,13 +148,6 @@ The possible options are: 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 @@ -245,14 +158,9 @@ 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 # but shouldn't be any harm in applying it globally. @@ -260,13 +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"}; - # We consider an expiry of 0 to be inifinite + + 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; + } + + $value .= $flag; + # We consider an expiry of 0 to be infinite if ( $expiry ) { return $set_sub ? $set_sub->( $key, $value, $expiry ) @@ -281,21 +205,78 @@ sub set_in_cache { =head2 get_from_cache - my $value = $cache->get_from_cache($key); + 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: + +=over + +=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. Make sure you know what you are doing! + +=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. + +=back =cut sub get_from_cache { - my ( $self, $key, $cache ) = @_; + my ( $self, $key, $options ) = @_; + my $cache = $options->{cache} || 'cache'; + my $unsafe = $options->{unsafe} || 0; $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 L1 cache value if exists + 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"}; - return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); + 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; + } + + # Unknown value / data type returned from L2 cache + return; } =head2 clear_from_cache @@ -312,6 +293,10 @@ sub clear_from_cache { $cache ||= 'cache'; croak "No key" unless $key; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + + # Clear from L1 cache + delete $L1_cache{$self->{namespace}}{$key}; + return $self->{$cache}->delete($key) if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); return $self->{$cache}->remove($key); @@ -329,11 +314,19 @@ sub flush_all { my ( $self, $cache ) = shift; $cache ||= 'cache'; return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + + $self->flush_L1_cache(); + return $self->{$cache}->flush_all() if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); return $self->{$cache}->clear(); } +sub flush_L1_cache { + my( $self ) = @_; + delete $L1_cache{$self->{namespace}}; +} + =head1 TIED INTERFACE Koha::Cache also provides a tied interface which enables users to provide a