=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)>
use strict;
use warnings;
use Carp;
+use Module::Load::Conditional qw(can_load);
+use Module::Load;
-use base qw(Class::Accessor);
+my $have_chi = 0;
+
+BEGIN: {
+ if ( can_load( modules => { CHI => undef } ) ) {
+ $have_chi = 1;
+ }
+}
-use Koha::Cache::Memcached;
+use base qw(Class::Accessor);
-__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
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
--- /dev/null
+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
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.
#
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 );
}
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;
--- /dev/null
+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
--- /dev/null
+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
#!/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;
}
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");
projects / koha-ffzg.git / commitdiff