Bug 16166: Improve L1 cache performance and safety

Bug 16044 introduced two-level caching mechanism to Koha::Cache. By
default, get_from_cache() returns a deep copy of the data structures
stored in L1 cache (aka "safe mode"). For extremely big and/or complex
data structures (like MARC framework hash-of-hashes-of-hashes returned
by GetMarcStructure() ), deep-cloning is currently sub-optimal;
this patch addresses that particular issue. It also provides an
ability to intermix "safe" and "unsafe" cache feches, in such
way that they don't interfere with each other (i.e., eliminating
the risk involved with "unsafe" calls possibly compromising
further "safe" calls).

Test plan:

1) apply patch
2) flush L2 cache if necessary (restart memcached daemon)
3) profile GetMarcStructure() calls before / after patch, e.g. by
running some script which calls it often (like catalogue search
w/ XSLT processing turned on, etc.) - GetMarcStructure() should be
faster than before, in all possible circumstances (eg. 18 msec
per call -> 10 msec p/call)
4) after testing, before returning to the master branch, flush L2 cache
again (restart memcached daemon) - otherwise all system preferences
returned from L2 cache would be suffixed with '-CF0'

Signed-off-by: Jonathan Druart <jonathan.druart@bugs.koha-community.org>

Signed-off-by: Kyle M Hall <kyle@bywatersolutions.com>

Signed-off-by: Jesse Weaver <jweaver@bywatersolutions.com>

Koha/Cache.pm

@@ -38,7 +38,7 @@ The first, traditional OO interface provides the following functions:
 use strict;
 use warnings;
 use Carp;
-use Storable qw(dclone);
+use Storable qw(freeze thaw);
 use Module::Load::Conditional qw(can_load);
 use Koha::Cache::Object;
 
@@ -228,13 +228,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 +246,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,14 +260,20 @@ 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;
+    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 = freeze($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;
+    }
 
-    # Set in L1 cache; exit if we are caching an undef
-    $L1_cache{ $key } = $value;
-    return if !defined $value;
-
-    # We consider an expiry of 0 to be infinite
+    $value .= $flag;
+    # We consider an expiry of 0 to be inifinite
     if ( $expiry ) {
         return $set_sub
           ? $set_sub->( $key, $value, $expiry )
@@ -292,7 +290,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:
 
@@ -325,23 +323,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} ||= thaw($L1_cache{$key}->{frozen});
+                return $L1_cache{$key}->{thawed};
+            } else {
+                return thaw($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);
+    my $L2_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;
+    return if ref($L2_value);
+    return unless (defined($L2_value) && length($L2_value) >= 4);
 
-    $value = dclone $value if ref $L1_cache{$key} and not $unsafe;
+    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 = thaw($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