X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=Koha%2FCache.pm;h=ec153baff9fdb1b8c825e2ebabef7724e43d0f9b;hb=41a8005d1013815d312089c00e9e5464768e1332;hp=39a16d08c081abd6464cc82bcde54b0f223bafa8;hpb=dda7a0a25ff480abda219084686e8138341fbba3;p=koha-ffzg.git

diff --git a/Koha/Cache.pm b/Koha/Cache.pm
index 39a16d08c0..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,35 +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 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
 
@@ -72,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,
@@ -153,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;
 }
 
@@ -241,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
@@ -258,14 +158,9 @@ instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
 =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.
@@ -273,17 +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"};
 
-    # 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 )
@@ -298,25 +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 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<Cache::*> and follow the same interface as L<Cache::Memcache>.
 
-Retrieve the value stored under the specified key in the default cache.
+=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
-    return $L1_cache{$key} if exists $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"};
-    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
@@ -335,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' );
@@ -364,7 +324,7 @@ sub flush_all {
 
 sub flush_L1_cache {
     my( $self ) = @_;
-    %L1_cache = ();
+    delete $L1_cache{$self->{namespace}};
 }
 
 =head1 TIED INTERFACE