Merge remote-tracking branch 'origin/new/bug_8440'

[srvgit] / Koha / Cache.pm

diff --git a/Koha/Cache.pm b/Koha/Cache.pm
index 25aad93..740a133 100644 (file)
--- a/Koha/Cache.pm
+++ b/Koha/Cache.pm
@@ -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,21 +49,82 @@ B<flush_all ()>
 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;
 
-use Koha::Cache::Memcached;
+BEGIN: {
+    if ( can_load( modules => { CHI => undef } ) ) {
+        $have_chi = 1;
+    }
+}
+
+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 = $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' : '';
+}
+
+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->{cache};
+    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->{cache};
+    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->{cache};
+    return unless $self->{have_chi};
+    return $self->{cache}->remove($key);
+}
+
+sub flush_all {
+    my $self = shift;
+    return unless $self->{cache};
+    return unless $self->{have_chi};
+    return $self->{cache}->clear();
 }
 
 =head2 EXPORT
@@ -74,6 +138,8 @@ Koha::Cache::Memcached
 =head1 AUTHOR
 
 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