X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=Koha%2FCache.pm;h=ec153baff9fdb1b8c825e2ebabef7724e43d0f9b;hb=41a8005d1013815d312089c00e9e5464768e1332;hp=740a1335c81a4c462d528ceb7836567ccf5dfa0f;hpb=bb4ab3ee765e5664f2d1645efd4b5e5e973a9d56;p=koha-ffzg.git diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 740a1335c8..ec153baff9 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -1,21 +1,22 @@ package Koha::Cache; # Copyright 2009 Chris Cormack and The Koha Dev Team +# Parts copyright 2012-2013 C & P Bibliography Services # # 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 @@ -23,24 +24,15 @@ Koha::Cache - Handling caching of html and Objects for Koha =head1 SYNOPSIS - use Koha::Cache (cache_type => $cache_type, %params ); + use Koha::Cache; + my $cache = Koha::Cache->new({cache_type => $cache_type, %params}); -=head1 DESCRIPTION - -Base class for Koha::Cache::X. Subclasses must provide the following methods - -B<_cache_handle ($params_hr)> - cache handle creator - -Subclasses may override the following methods if they are not using a -CHI-derived cache + # see also Koha::Caches->get_instance; -B - -B - -B +=head1 DESCRIPTION -B +Koha caching routines. This class provides two interfaces for cache access. +The first, traditional OO interface provides the following functions: =head1 FUNCTIONS @@ -50,90 +42,433 @@ use strict; use warnings; use Carp; use Module::Load::Conditional qw(can_load); -use Module::Load; +use Sereal::Encoder; +use Sereal::Decoder; -my $have_chi = 0; - -BEGIN: { - if ( can_load( modules => { CHI => undef } ) ) { - $have_chi = 1; - } -} +use C4::Context; +use Koha::Cache::Object; +use Koha::Config; use base qw(Class::Accessor); -__PACKAGE__->mk_ro_accessors(qw( cache )); +__PACKAGE__->mk_ro_accessors( + qw( cache memcached_cache )); + +our %L1_cache; +our $L1_encoder = Sereal::Encoder->new; +our $L1_decoder = Sereal::Decoder->new; + +=head2 new + +Create a new Koha::Cache object. This is required for all cache-related functionality. + +=cut sub new { - my $class = shift; - my $param = shift; - my $cache_type = - $ENV{CACHING_SYSTEM} - || $param->{cache_type} + my ( $class, $self, $params ) = @_; + $self->{'default_type'} = + $self->{cache_type} + || $ENV{CACHING_SYSTEM} # DELME What about this? || 'memcached'; - my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type); - $param->{have_chi} = $have_chi; - unless ( can_load( modules => { $subclass => undef } ) ) { - $subclass = __PACKAGE__ . "::" . ucfirst('Null'); - load $subclass; + + my $subnamespace = $params->{subnamespace} // ''; + + $self->{'timeout'} ||= 0; + # 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'}; } - my $cache = $subclass->_cache_handle($param); + return - bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ), - $subclass; + bless $self, + $class; +} + +sub _initialize_memcached { + 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, + } + ); + + # 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 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, [$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. + +=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 ) = @_; + 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} && warn "set_in_cache for $key"; - return unless $self->{cache}; - return unless $self->{have_chi}; + return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); + 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; + } - if ( defined $expiry ) { - return $self->{cache}->set( $key, $value, $expiry ); + $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, [ $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 + +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 ) = @_; + 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} && warn "get_from_cache for $key"; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->get($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"}; + 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 + + $cache->clear_from_cache($key); + +Remove the value identified by the specified key from the default cache. + +=cut + sub clear_from_cache { - my ( $self, $key ) = @_; + my ( $self, $key, $cache ) = @_; + $key =~ s/[\x00-\x20]/_/g; + $cache ||= 'cache'; croak "No key" unless $key; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->remove($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); } +=head2 flush_all + + $cache->flush_all(); + +Clear the entire default cache. + +=cut + sub flush_all { - my $self = shift; - return unless $self->{cache}; - return unless $self->{have_chi}; - return $self->{cache}->clear(); + 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 +constructor closure and (after creation) treat cached data like normal reference +variables and rely on the cache Just Working and getting updated when it +expires, etc. + + my $cache = Koha::Cache->new(); + my $data = 'whatever'; + my $scalar = Koha::Cache->create_scalar( + { + 'key' => 'whatever', + 'timeout' => 2, + 'constructor' => sub { return $data; }, + } + ); + print "$$scalar\n"; # Prints "whatever" + $data = 'somethingelse'; + print "$$scalar\n"; # Prints "whatever" because it is cached + sleep 2; # Wait until the cache entry has expired + print "$$scalar\n"; # Prints "somethingelse" + + my $hash = Koha::Cache->create_hash( + { + 'key' => 'whatever', + 'timeout' => 2, + 'constructor' => sub { return $data; }, + } + ); + print "$$variable\n"; # Prints "whatever" + +The gotcha with this interface, of course, is that the variable returned by +create_scalar and create_hash is a I to a tied variable and not a +tied variable itself. + +The tied variable is configured by means of a hashref passed in to the +create_scalar and create_hash methods. The following parameters are supported: + +=over + +=item I + +Required. The key to use for identifying the variable in the cache. + +=item I + +Required. A closure (or reference to a function) that will return the value that +needs to be stored in the cache. + +=item I + +Optional. A closure (or reference to a function) that gets run to initialize +the cache when creating the tied variable. + +=item I + +Optional. Array reference with the arguments that should be passed to the +constructor function. + +=item I + +Optional. The cache timeout in seconds for the variable. Defaults to 600 +(ten minutes). + +=item I + +Optional. Which type of cache to use for the variable. Defaults to whatever is +set in the environment variable CACHING_SYSTEM. If set to 'null', disables +caching for the tied variable. + +=item I + +Optional. Boolean flag to allow the variable to be updated directly. When this +is set and the variable is used as an l-value, the cache will be updated +immediately with the new value. Using this is probably a bad idea on a +multi-threaded system. When I is not set to true, using the +tied variable as an l-value will have no effect. + +=item I + +Optional. A closure (or reference to a function) that should be called when the +tied variable is destroyed. + +=item I + +Optional. Boolean flag to tell the object to remove the variable from the cache +when it is destroyed or goes out of scope. + +=item I + +Optional. Boolean flag to tell the object not to refresh the variable from the +cache every time the value is desired, but rather only when the I copy +of the variable is older than the timeout. + +=back + +=head2 create_scalar + + my $scalar = Koha::Cache->create_scalar(\%params); + +Create scalar tied to the cache. + +=cut + +sub create_scalar { + my ( $self, $args ) = @_; + + $self->_set_tied_defaults($args); + + tie my $scalar, 'Koha::Cache::Object', $args; + return \$scalar; +} + +sub create_hash { + my ( $self, $args ) = @_; + + $self->_set_tied_defaults($args); + + tie my %hash, 'Koha::Cache::Object', $args; + return \%hash; +} + +sub _set_tied_defaults { + my ( $self, $args ) = @_; + + $args->{'timeout'} = '600' unless defined( $args->{'timeout'} ); + $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} ); + unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) { + $args->{'cache'} = $self; + $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'}; + } + + return $args; } -=head2 EXPORT +=head1 EXPORT None by default. =head1 SEE ALSO -Koha::Cache::Memcached +Koha::Cache::Object =head1 AUTHOR