Browse Source

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

Signed-off-by: Jacek Ablewicz <abl@biblos.pk.edu.pl>
Signed-off-by: Tomas Cohen Arazi <tomascohen@theke.io>

https://bugs.koha-community.org/show_bug.cgi?id=11921

Signed-off-by: Kyle M Hall <kyle@bywatersolutions.com>
16.11.x
Jonathan Druart 6 years ago
committed by Kyle M Hall
parent
commit
9d1dbb96cb
  1. 2
      C4/Context.pm
  2. 38
      Koha/Cache.pm
  3. 21
      Koha/Caches.pm
  4. 4
      debian/templates/plack.psgi
  5. 4
      misc/plack/koha.psgi
  6. 11
      t/Cache.t

2
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);

38
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 } )
@ -267,11 +261,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;
}
@ -325,17 +319,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};
}
}
@ -348,15 +342,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;
}
@ -380,7 +374,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' );
@ -409,7 +403,7 @@ sub flush_all {
sub flush_L1_cache {
my( $self ) = @_;
%L1_cache = ();
$L1_cache{$self->{namespace}} = ();
}
=head1 TIED INTERFACE

21
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;

4
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;
};

4
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

11
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' );

Loading…
Cancel
Save