Bug 16715: Use Sereal::Decoder and Sereal::Encoder instead of Sereal

[koha-ffzg.git] / Koha / Cache.pm

diff --git a/Koha/Cache.pm b/Koha/Cache.pm
index 6f10b00..fa4f136 100644 (file)
--- a/Koha/Cache.pm
+++ b/Koha/Cache.pm
@@ -38,9 +38,10 @@ The first, traditional OO interface provides the following functions:
 use strict;
 use warnings;
 use Carp;
-use Storable qw(dclone);
 use Module::Load::Conditional qw(can_load);
 use Koha::Cache::Object;
+use Sereal::Encoder;
+use Sereal::Decoder;
 
 use base qw(Class::Accessor);
 
@@ -48,6 +49,8 @@ __PACKAGE__->mk_ro_accessors(
     qw( cache memcached_cache fastmmap_cache memory_cache ));
 
 our %L1_cache;
+our $L1_encoder = Sereal::Encoder->new;
+our $L1_decoder = Sereal::Decoder->new;
 
 =head2 get_instance
 
@@ -228,13 +231,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
@@ -253,7 +249,6 @@ sub set_in_cache {
         $new_options->{cache} = $_cache if defined $_cache;
         $options = $new_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.
@@ -268,12 +263,19 @@ sub set_in_cache {
     $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 = dclone( $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, initially only in frozen form (for performance reasons)
+        $value = $L1_encoder->encode($value);
+        $L1_cache{$key}->{frozen} = $value;
+        $flag = '-CF1';
+    } else {
+        # Set in L1 cache as a scalar; exit if we are caching an undef
+        $L1_cache{$key} = $value;
+        return if !defined $value;
+    }
 
+    $value .= $flag;
     # We consider an expiry of 0 to be inifinite
     if ( $expiry ) {
         return $set_sub
@@ -291,7 +293,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:
 
@@ -324,23 +326,42 @@ sub get_from_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 (ref($L1_cache{$key})) {
+            if ($unsafe) {
+                $L1_cache{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$key}->{frozen});
+                return $L1_cache{$key}->{thawed};
+            } else {
+                return $L1_decoder->decode($L1_cache{$key}->{frozen});
+            }
+        } else {
+            # No need to thaw if it's a scalar
+            return $L1_cache{$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 = dclone $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{$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{$key}->{frozen} = $L2_value;
+        $L1_cache{$key}->{thawed} = $thawed if $unsafe;
+        return $thawed;
+    }
 
-    return $value;
+    # Unknown value / data type returned from L2 cache
+    return;
 }
 
 =head2 clear_from_cache