From abdf7620615948300c39293572222e109c088fe1 Mon Sep 17 00:00:00 2001
From: Jonathan Druart <jonathan.druart@bugs.koha-community.org>
Date: Wed, 22 Jun 2016 16:01:46 +0100
Subject: [PATCH] Bug XXXXX_2: Add the ability to define several namespaces -
 Koha::Caches

We need to define take into account several namespaces for our cache
system. For instance sysprefs, koha conf (koha-conf.xml) and unit tests
should be defined in a separate namespace. This will permit to
- launch the tests without interfering with other cache values
- and flush the sysprefs cache without flushing all other values

To do so, we need to store different Koha::Cache objects at a package
level. That's why this patch adds a new Koha::Caches module.

FIXME: There is an architecture problem here: the L1 cache should be
defined in Koha::Cache

https://bugs.koha-community.org/show_bug.cgi?id=16579
---
 C4/Context.pm               |  2 +-
 Koha/Cache.pm               | 38 ++++++++++++++++----------------------
 Koha/Caches.pm              | 21 +++++++++++++++++++++
 debian/templates/plack.psgi |  4 ++--
 misc/plack/koha.psgi        |  4 ++--
 t/Cache.t                   | 11 ++++++-----
 6 files changed, 48 insertions(+), 32 deletions(-)
 create mode 100644 Koha/Caches.pm

diff --git a/C4/Context.pm b/C4/Context.pm
index 4ff47af..baed482 100644
--- a/C4/Context.pm
+++ b/C4/Context.pm
@@ -108,7 +108,7 @@ BEGIN {
 use Encode;
 use ZOOM;
 use XML::Simple;
-use Koha::Cache;
+use Koha::Caches;
 use POSIX ();
 use DateTime::TimeZone;
 use Module::Load::Conditional qw(can_load);
diff --git a/Koha/Cache.pm b/Koha/Cache.pm
index 34c793f..113e79e 100644
--- a/Koha/Cache.pm
+++ b/Koha/Cache.pm
@@ -54,7 +54,7 @@ our $L1_decoder = Sereal::Decoder->new;
 
 =head2 get_instance
 
-    my $cache = Koha::Cache->get_instance();
+    my $cache = Koha::Caches->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
@@ -62,13 +62,6 @@ persistent across multiple instances.
 
 =cut
 
-our $singleton_cache;
-sub get_instance {
-    my ($class) = @_;
-    $singleton_cache = $class->new() unless $singleton_cache;
-    return $singleton_cache;
-}
-
 =head2 new
 
 Create a new Koha::Cache object. This is required for all cache-related functionality.
@@ -76,7 +69,7 @@ Create a new Koha::Cache object. This is required for all cache-related function
 =cut
 
 sub new {
-    my ( $class, $self ) = @_;
+    my ( $class, $self, $subnamespace ) = @_;
     $self->{'default_type'} =
          $self->{cache_type}
       || $ENV{CACHING_SYSTEM}
@@ -86,6 +79,7 @@ sub new {
 
     $self->{'timeout'}   ||= 0;
     $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
+    $self->{namespace} .= ":$subnamespace:";
 
     if ( $self->{'default_type'} eq 'memcached'
         && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
@@ -264,11 +258,11 @@ sub set_in_cache {
     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;
+        $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{$key} = $value;
+        $L1_cache{$self->{namespace}}{$key} = $value;
         return if !defined $value;
     }
 
@@ -322,17 +316,17 @@ sub get_from_cache {
     return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
 
     # Return L1 cache value if exists
-    if ( exists $L1_cache{$key} ) {
-        if (ref($L1_cache{$key})) {
+    if ( exists $L1_cache{$self->{namespace}}{$key} ) {
+        if (ref($L1_cache{$self->{namespace}}{$key})) {
             if ($unsafe) {
-                $L1_cache{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$key}->{frozen});
-                return $L1_cache{$key}->{thawed};
+                $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{$key}->{frozen});
+                return $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
             }
         } else {
             # No need to thaw if it's a scalar
-            return $L1_cache{$key};
+            return $L1_cache{$self->{namespace}}{$key};
         }
     }
 
@@ -345,15 +339,15 @@ sub get_from_cache {
     my $flag = substr($L2_value, -4, 4, '');
     if ($flag eq '-CF0') {
         # it's a scalar
-        $L1_cache{$key} = $L2_value;
+        $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{$key}->{frozen} = $L2_value;
-        $L1_cache{$key}->{thawed} = $thawed if $unsafe;
+        $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
+        $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
         return $thawed;
     }
 
@@ -377,7 +371,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' );
@@ -406,7 +400,7 @@ sub flush_all {
 
 sub flush_L1_cache {
     my( $self ) = @_;
-    %L1_cache = ();
+    $L1_cache{$self->{namespace}} = ();
 }
 
 =head1 TIED INTERFACE
diff --git a/Koha/Caches.pm b/Koha/Caches.pm
new file mode 100644
index 0000000..338ccd2
--- /dev/null
+++ b/Koha/Caches.pm
@@ -0,0 +1,21 @@
+package Koha::Caches;
+
+use Modern::Perl;
+use Koha::Cache;
+
+our $singleton_caches;
+sub get_instance {
+    my ($class, $subnamespace) = @_;
+    $subnamespace //= '';
+    $singleton_caches->{$subnamespace} = Koha::Cache->new({}, $subnamespace) unless $singleton_caches->{$subnamespace};
+    return $singleton_caches->{$subnamespace};
+}
+
+sub flush_L1_caches {
+    return unless $singleton_caches;
+    for my $cache ( values %$singleton_caches ) {
+        $cache->flush_L1_cache;
+    }
+}
+
+1;
diff --git a/debian/templates/plack.psgi b/debian/templates/plack.psgi
index 704b91b..1df826c 100644
--- a/debian/templates/plack.psgi
+++ b/debian/templates/plack.psgi
@@ -34,7 +34,7 @@ use C4::Languages;
 use C4::Letters;
 use C4::Members;
 use C4::XSLT;
-use Koha::Cache;
+use Koha::Caches;
 use Koha::Cache::Memory::Lite;
 use Koha::Database;
 use Koha::DateUtils;
@@ -46,7 +46,7 @@ use CGI qw(-utf8 ); # we will loose -utf8 under plack, otherwise
     *CGI::new = sub {
         my $q = $old_new->( @_ );
         $CGI::PARAM_UTF8 = 1;
-        Koha::Cache->flush_L1_cache();
+        Koha::Caches->flush_L1_caches();
         Koha::Cache::Memory::Lite->flush();
         return $q;
     };
diff --git a/misc/plack/koha.psgi b/misc/plack/koha.psgi
index 20c6ca8..e24df26 100644
--- a/misc/plack/koha.psgi
+++ b/misc/plack/koha.psgi
@@ -12,7 +12,7 @@ use CGI qw(-utf8 ); # we will lose -utf8 under plack
     *CGI::new = sub {
         my $q = $old_new->( @_ );
         $CGI::PARAM_UTF8 = 1;
-        Koha::Cache->flush_L1_cache();
+        Koha::Caches->flush_L1_caches();
         Koha::Cache::Memory::Lite->flush();
         return $q;
     };
@@ -46,7 +46,7 @@ use C4::XSLT;
 use C4::Branch;
 use C4::Category;
 use Koha::DateUtils;
-use Koha::Cache;
+use Koha::Caches;
 use Koha::Cache::Memory::Lite;
 =for preload
 use C4::Tags; # FIXME
diff --git a/t/Cache.t b/t/Cache.t
index 759e993..be36a80 100644
--- a/t/Cache.t
+++ b/t/Cache.t
@@ -17,13 +17,14 @@
 
 use Modern::Perl;
 
-use Test::More tests => 43;
+use Test::More tests => 44;
 use Test::Warn;
 
 my $destructorcount = 0;
 
 BEGIN {
     use_ok('Koha::Cache');
+    use_ok('Koha::Caches');
     use_ok('Koha::Cache::Object');
     use_ok('Koha::Cache::Memory::Lite');
     use_ok('C4::Context');
@@ -33,7 +34,7 @@ SKIP: {
     # Set a special namespace for testing, to avoid breaking
     # if test is run with a different user than Apache's.
     $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
-    my $cache = Koha::Cache->get_instance();
+    my $cache = Koha::Caches->get_instance();
 
     skip "Cache not enabled", 36
       unless ( $cache->is_cache_active() && defined $cache );
@@ -258,8 +259,8 @@ subtest 'Koha::Cache::Memory::Lite' => sub {
 
 subtest 'Koha::Caches' => sub {
     plan tests => 8;
-    my $default_cache = Koha::Cache->get_instance();
-    my $another_cache = Koha::Cache->get_instance('another_cache');
+    my $default_cache = Koha::Caches->get_instance();
+    my $another_cache = Koha::Caches->get_instance('another_cache');
     $default_cache->set_in_cache('key_a', 'value_a');
     $default_cache->set_in_cache('key_b', 'value_b');
     $another_cache->set_in_cache('key_a', 'another_value_a');
@@ -279,7 +280,7 @@ subtest 'Koha::Caches' => sub {
 END {
   SKIP: {
         $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
-        my $cache = Koha::Cache->get_instance();
+        my $cache = Koha::Caches->get_instance();
         skip "Cache not enabled", 1
           unless ( $cache->is_cache_active() );
         is( $destructorcount, 1, 'Destructor run exactly once' );
-- 
2.8.1