From af6e26b3f10d65f4249feb51e99772acf00313f4 Mon Sep 17 00:00:00 2001 From: Jonathan Druart Date: Wed, 22 Jun 2016 16:01:46 +0100 Subject: [PATCH] Bug 17189: Add the ability to define several memcached namespaces - Koha::Caches We need to define 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 --- 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..00bf5b3 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 397998f..fd70509 100644 --- a/debian/templates/plack.psgi +++ b/debian/templates/plack.psgi @@ -36,7 +36,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; @@ -48,7 +48,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