@@ -, +, @@ Koha::Caches - launch the tests without interfering with other cache values - and flush the sysprefs cache without flushing all other values --- 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 --- a/C4/Context.pm +++ a/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); --- a/Koha/Cache.pm +++ a/Koha/Cache.pm @@ -51,7 +51,7 @@ our %L1_cache; =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 @@ -59,13 +59,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. @@ -73,7 +66,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} @@ -83,6 +76,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 } ) @@ -261,11 +255,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 = freeze($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; } @@ -319,17 +313,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} ||= thaw($L1_cache{$key}->{frozen}); - return $L1_cache{$key}->{thawed}; + $L1_cache{$self->{namespace}}{$key}->{thawed} ||= thaw($L1_cache{$self->{namespace}}{$key}->{frozen}); + return $L1_cache{$self->{namespace}}{$key}->{thawed}; } else { - return thaw($L1_cache{$key}->{frozen}); + return thaw($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}; } } @@ -342,15 +336,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 = thaw($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; } @@ -374,7 +368,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' ); @@ -403,7 +397,7 @@ sub flush_all { sub flush_L1_cache { my( $self ) = @_; - %L1_cache = (); + $L1_cache{$self->{namespace}} = (); } =head1 TIED INTERFACE --- a/Koha/Caches.pm +++ a/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; --- a/debian/templates/plack.psgi +++ a/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; }; --- a/misc/plack/koha.psgi +++ a/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 --- a/t/Cache.t +++ a/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' ); --