Koha-community/Koha
13
7
Fork 0
Code Issues Releases Wiki Activity

Bug 8092: Convert Koha::Cache to use CHI

Browse source 
Implements cache handlers for Memcached, mmap shared-file persistent,
and in-process memory caches. If CHI is unavailable, Koha::Cache::Memcached
will fall back to using Cache::Memcached::Fast, or caching will be skipped
without croaking.

To test: run t/Cache.t with the following options, before and after
installing CHI:

2. Tests 3-9 should be skipped with the following:
export CACHING_SYSTEM=

2. You should receive two failures with the following if CHI is not installed:
export CACHING_SYSTEM=memory

3. You should receive two failures with the following if CHI is not installed:
export CACHING_SYSTEM=fastmmap

4. You will need memcached activated for the following to work (but it
   will work both with and without CHI):
export CACHING_SYSTEM=memcached
export MEMCACHED_SERVERS=127.0.0.1:11211
export MEMCACHED_NAMESPACE=KOHA

5. You should receive two failures with the following:
export CACHING_SYSTEM=thisdoesntexist

Signed-off-by: Chris Cormack <chris@bigballofwax.co.nz>

Works as advertised, now we need a follow up to add the new dependency.

http://bugs.koha-community.org/show_bug.cgi?id=8029
This commit is contained in:
Jared Camins-Esakov 2012-05-15 13:03:30 -04:00 committed by Paul Poulain
parent b76ab0ec66
commit d5d6daad1c
6 changed files with 266 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

77
Koha/Cache.pm
View file

@ -27,10 +27,13 @@ Koha::Cache - Handling caching of html and Objects for Koha
=head1 DESCRIPTION
Base class for Koha::Cache::X. Subclasses need to provide the following methods
Base class for Koha::Cache::X. Subclasses must provide the following methods
B<_cache_handle ($params_hr)> - cache handle creator
Subclasses may override the following methods if they are not using a
CHI-derived cache
B<set_in_cache ($key, $value, $expiry)>
B<get_from_cache ($key)>
@ -46,25 +49,78 @@ B<flush_all ()>
use strict;
use warnings;
use Carp;
use Module::Load::Conditional qw(can_load);
use Module::Load;
my $have_chi = 0;
BEGIN: {
if ( can_load( modules => { CHI => undef } ) ) {
$have_chi = 1;
}
}
use base qw(Class::Accessor);
use Koha::Cache::Memcached;
__PACKAGE__->mk_ro_accessors( qw( cache ) );
__PACKAGE__->mk_ro_accessors(qw( cache ));
sub new {
my $class = shift;
my $param = shift;
my $cache_type = $ENV{CACHING_SYSTEM} || $param->{cache_type} || 'memcached';
my $subclass = __PACKAGE__."::".ucfirst($cache_type);
my $cache = $subclass->_cache_handle($param)
or croak "Cannot create cache handle for '$cache_type'";
return bless $class->SUPER::new({cache => $cache}), $subclass;
my $cache_type =
$ENV{CACHING_SYSTEM}
|| $param->{cache_type}
|| 'memcached';
my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type);
$param->{have_chi} = $have_chi;
unless ( can_load( modules => { $subclass => undef } ) ) {
$subclass = __PACKAGE__ . "::" . ucfirst('Null');
load $subclass;
}
my $cache = $subclass->_cache_handle($param);
return
bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ),
$subclass;
}
sub is_cache_active {
return $ENV{CACHING_SYSTEM} ? '1' : '' ;
return $ENV{CACHING_SYSTEM} ? '1' : '';
}
sub set_in_cache {
my ( $self, $key, $value, $expiry ) = @_;
croak "No key" unless $key;
$ENV{DEBUG} && warn "set_in_cache for $key";
return unless $self->{have_chi};
if ( defined $expiry ) {
return $self->{cache}->set( $key, $value, $expiry );
}
else {
return $self->{cache}->set( $key, $value );
}
}
sub get_from_cache {
my ( $self, $key ) = @_;
croak "No key" unless $key;
$ENV{DEBUG} && warn "get_from_cache for $key";
return unless $self->{have_chi};
return $self->{cache}->get($key);
}
sub clear_from_cache {
my ( $self, $key ) = @_;
croak "No key" unless $key;
return unless $self->{have_chi};
return $self->{cache}->remove($key);
}
sub flush_all {
my $self = shift;
return unless $self->{have_chi};
return $self->{cache}->clear();
}
=head2 EXPORT
@ -79,6 +135,7 @@ Koha::Cache::Memcached
Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
=cut

45
Koha/Cache/Fastmmap.pm Normal file
View file

@ -0,0 +1,45 @@
package Koha::Cache::Fastmmap;
# Copyright 2012 C & P Bibliography Services
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
use warnings;
use Carp;
use CHI;
use base qw(Koha::Cache);
sub _cache_handle {
my $class = shift;
my $params = shift;
return CHI->new(
driver => 'FastMmap',
namespace => $params->{'namespace'} || 'koha',
expire_in => 600,
cache_size => $params->{'cachesize'} || '1m',
);
}
1;
__END__
=head1 NAME
Koha::Cache::Fastmmap - persistent interprocess mmap-based cache for Koha
=cut

85
Koha/Cache/Memcached.pm
View file

@ -1,6 +1,6 @@
package Koha::Cache::Memcached;
# Copyright 2009 Chris Cormack and The Koha Dev Team
# Copyright 2012 C & P Bibliography Services
#
# This file is part of Koha.
#
@ -20,31 +20,63 @@ package Koha::Cache::Memcached;
use strict;
use warnings;
use Carp;
use Cache::Memcached;
use Cache::Memcached::Fast;
use Module::Load::Conditional qw(can_load);
use base qw(Koha::Cache);
sub _cache_handle {
my $class = shift;
my $params = shift;
my @servers = split /,/, $params->{'cache_servers'}?$params->{'cache_servers'}:$ENV{MEMCACHED_SERVERS};
$ENV{DEBUG} && warn "Caching server settings: ".join(', ',@servers)." with ".($ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha');
return Cache::Memcached->new(
servers => \@servers,
debug => 0,
compress_threshold => 10_000,
expire_time => 600,
namespace => $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha',
);
my $class = shift;
my $params = shift;
my @servers = split /,/,
$params->{'cache_servers'}
? $params->{'cache_servers'}
: $ENV{MEMCACHED_SERVERS};
my $namespace =
$ENV{MEMCACHED_NAMESPACE}
|| $params->{'namespace'}
|| 'koha';
$ENV{DEBUG}
&& warn "Caching server settings: "
. join( ', ', @servers )
. " with "
. ( $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha' );
if (
$params->{have_chi}
&& can_load(
modules =>
{ 'CHI' => undef, 'CHI::Driver::Memcached::Fast' => undef }
)
)
{
return CHI->new(
driver => 'Memcached::Fast',
servers => \@servers,
namespace => $namespace,
compress_threshold => 10_000,
l1_cache =>
{ driver => 'Memory', global => 1, max_size => 1024 * 1024 },
);
# We use a 1MB L1 memory cache for added efficiency
}
else {
return Cache::Memcached::Fast->new(
{
servers => \@servers,
compress_threshold => 10_000,
namespace => $namespace,
}
);
}
}
sub set_in_cache {
my ( $self, $key, $value, $expiry ) = @_;
croak "No key" unless $key;
$self->cache->set_debug;
$ENV{DEBUG} && warn "set_in_cache for Memcache $key";
return $self->SUPER::set_in_cache( $key, $value, $expiry )
if ( $self->{have_chi} );
# No CHI, we have to use Cache::Memcached::Fast directly
if ( defined $expiry ) {
return $self->cache->set( $key, $value, $expiry );
}
@ -55,20 +87,31 @@ sub set_in_cache {
sub get_from_cache {
my ( $self, $key ) = @_;
croak "No key" unless $key;
$ENV{DEBUG} && warn "get_from_cache for Memcache $key";
return $self->SUPER::get_from_cache($key) if ( $self->{have_chi} );
# No CHI, we have to use Cache::Memcached::Fast directly
return $self->cache->get($key);
}
sub clear_from_cache {
my ( $self, $key ) = @_;
croak "No key" unless $key;
return $self->SUPER::clear_from_cache($key) if ( $self->{have_chi} );
# No CHI, we have to use Cache::Memcached::Fast directly
return $self->cache->delete($key);
}
# We have to overload flush_all because CHI::Driver::Memcached::Fast does not
# support the clear() method
sub flush_all {
my $self = shift;
return $self->cache->flush_all;
if ( $self->{have_chi} ) {
$self->{cache}->l1_cache->clear();
return $self->{cache}->memd->flush_all();
}
else {
return $self->{cache}->flush_all;
}
}
1;

46
Koha/Cache/Memory.pm Normal file
View file

@ -0,0 +1,46 @@
package Koha::Cache::Memory;
# Copyright 2012 C & P Bibliography Services
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
use warnings;
use Carp;
use CHI;
use base qw(Koha::Cache);
sub _cache_handle {
my $class = shift;
my $params = shift;
return CHI->new(
driver => 'Memory',
namespace => $params->{'namespace'} || 'koha',
expire_in => 600,
max_size => $params->{'max_size'} || 8192 * 1024,
global => 1,
);
}
1;
__END__
=head1 NAME
Koha::Cache::Memory - in-process memory based cache for Koha
=cut

41
Koha/Cache/Null.pm Normal file
View file

@ -0,0 +1,41 @@
package Koha::Cache::Null;
# Copyright 2012 C & P Bibliography Services
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
use warnings;
use Carp;
use Module::Load;
use base qw(Koha::Cache);
sub _cache_handle {
my $class = shift;
my $params = shift;
load CHI if $params->{have_chi};
return $params->{have_chi} ? CHI->new( driver => 'Null' ) : undef;
}
1;
__END__
=head1 NAME
Koha::Cache::Null - null (no-op) cache for Koha
=cut

6
t/Cache.t
View file

@ -1,6 +1,6 @@
#!/usr/bin/perl
# Tests Koha::Cache and Koha::Cache::Memcached (through Koha::Cache)
# Tests Koha::Cache and whichever type of cache is enabled (through Koha::Cache)
use strict;
use warnings;
@ -13,9 +13,9 @@ BEGIN {
}
SKIP: {
skip "Memcached not enabled", 7 unless C4::Context->ismemcached;
my $cache = Koha::Cache->new ();
my $cache = Koha::Cache->new ( { 'cache_servers' => $ENV{'MEMCACHED_SERVERS'} } );
skip "Cache not enabled", 7 unless (Koha::Cache->is_cache_active() && defined $cache);
# test fetching an item that isnt in the cache
is( $cache->get_from_cache("not in here"), undef, "fetching item NOT in cache");