X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=Koha%2FCache.pm;h=ec153baff9fdb1b8c825e2ebabef7724e43d0f9b;hb=41a8005d1013815d312089c00e9e5464768e1332;hp=e119bda2500251a92b7770957f407843934cae51;hpb=2f3f5d9a3cb0102d0c9fa187d0fe8709e08f39e0;p=koha-ffzg.git diff --git a/Koha/Cache.pm b/Koha/Cache.pm index e119bda250..ec153baff9 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,10 +27,12 @@ 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. -The first, traditional interface provides the following functions: +The first, traditional OO interface provides the following functions: =head1 FUNCTIONS @@ -40,12 +42,21 @@ use strict; use warnings; use Carp; 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; +our $L1_encoder = Sereal::Encoder->new; +our $L1_decoder = Sereal::Decoder->new; =head2 new @@ -54,155 +65,218 @@ 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'}; - } + # 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'}; } - if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) { - _initialize_fastmmap($self); - if ( $self->{'default_type'} eq 'fastmmap' - && 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'}; - } - } - -# 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})); -# } -#} - return bless $self, $class; } sub _initialize_memcached { - my ($self) = @_; - my @servers = - split /,/, $self->{'cache_servers'} - ? $self->{'cache_servers'} - : $ENV{MEMCACHED_SERVERS}; - - $ENV{DEBUG} - && carp "Memcached server settings: " - . join( ', ', @servers ) - . " with " - . $self->{'namespace'}; - $self->{'memcached_cache'} = Cache::Memcached::Fast->new( + 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::Safe->new( { servers => \@servers, compress_threshold => 10_000, namespace => $self->{'namespace'}, + utf8 => 1, } ); - return $self; -} - -sub _initialize_fastmmap { - my ($self) = @_; - - $self->{'fastmmap_cache'} = Cache::FastMmap->new( - 'share_file' => "/tmp/sharefile-koha-$self->{'namespace'}", - 'expire_time' => $self->{'timeout'}, - 'unlink_on_exit' => 0, - ); - return $self; -} - -sub _initialize_memory { - my ($self) = @_; - $self->{'memory_cache'} = Cache::Memory->new( - 'namespace' => $self->{'namespace'}, - 'default_expires' => $self->{'timeout'} - ); + # Ensure we can actually talk to the memcached server + my $ismemcached = $memcached->set('ismemcached','1'); + 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; } =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. + +The possible options are: + +=over + +=item expiry + +Expiry time of this cached entry in seconds. -Save a value to the specified key in the default cache, optionally with a -particular expiry. +=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 set_in_cache { - my ( $self, $key, $value, $expiry, $cache ) = @_; - $cache ||= 'cache'; + 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. + $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"}; + + 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 ) + : $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 ); } } =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 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 -Retrieve the value stored under the specified key in the default 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 ) = @_; - $cache ||= 'cache'; + my ( $self, $key, $options ) = @_; + my $cache = $options->{cache} || '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 $self->{$cache}->get($key); + + # 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"}; + 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 @@ -215,11 +289,16 @@ Remove the value identified by the specified key from the default 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::/ ); + + # Clear from L1 cache + delete $L1_cache{$self->{namespace}}{$key}; + 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); } @@ -235,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} ) eq 'Cache::Memcached::Fast' ); + 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 @@ -367,7 +454,7 @@ sub _set_tied_defaults { $args->{'timeout'} = '600' unless defined( $args->{'timeout'} ); $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} ); - unless ( lc( $args->{'cache_type'} ) eq 'null' ) { + unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) { $args->{'cache'} = $self; $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'}; }