#
# 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 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 3 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.
+# 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.
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
=head1 NAME
use strict;
use warnings;
use Carp;
+use Storable qw(dclone);
use Module::Load::Conditional qw(can_load);
use Koha::Cache::Object;
__PACKAGE__->mk_ro_accessors(
qw( cache memcached_cache fastmmap_cache memory_cache ));
+our %L1_cache;
+
=head2 get_instance
my $cache = Koha::Cache->get_instance();
$self->{'timeout'} ||= 0;
$self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
- if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
- _initialize_memcached($self);
- if ( $self->{'default_type'} eq 'memcached'
- && defined( $self->{'memcached_cache'} ) )
- {
- $self->{'cache'} = $self->{'memcached_cache'};
- }
- }
-
- if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
- _initialize_fastmmap($self);
- if ( $self->{'default_type'} eq 'fastmmap'
- && defined( $self->{'fastmmap_cache'} ) )
- {
- $self->{'cache'} = $self->{'fastmmap_cache'};
- }
+ if ( $self->{'default_type'} eq 'memcached'
+ && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
+ && _initialize_memcached($self)
+ && defined( $self->{'memcached_cache'} ) )
+ {
+ $self->{'cache'} = $self->{'memcached_cache'};
}
- if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
- _initialize_memory($self);
- if ( $self->{'default_type'} eq 'memory'
- && defined( $self->{'memory_cache'} ) )
- {
- $self->{'cache'} = $self->{'memory_cache'};
- }
+ if ( $self->{'default_type'} eq 'fastmmap'
+ && defined( $ENV{GATEWAY_INTERFACE} )
+ && can_load( modules => { 'Cache::FastMmap' => undef } )
+ && _initialize_fastmmap($self)
+ && defined( $self->{'fastmmap_cache'} ) )
+ {
+ $self->{'cache'} = $self->{'fastmmap_cache'};
}
- # Unless a default has already been picked, we go through in best-to-
- # least-best order, looking for something we can use. fastmmap_cache
- # is excluded because it doesn't support expiry in a useful way.
+ # Unless memcache or fastmmap has already been picked, use memory_cache
unless ( defined( $self->{'cache'} ) ) {
- foreach my $cachemember (qw(memcached_cache memory_cache )) {
- if ( defined( $self->{$cachemember} ) ) {
- $self->{'cache'} = $self->{$cachemember};
- last;
- }
+ if ( can_load( modules => { 'Cache::Memory' => undef, nocache => 1 } )
+ && _initialize_memory($self) )
+ {
+ $self->{'cache'} = $self->{'memory_cache'};
}
}
sub _initialize_fastmmap {
my ($self) = @_;
-
- $self->{'fastmmap_cache'} = Cache::FastMmap->new(
- 'share_file' => "/tmp/sharefile-koha-$self->{'namespace'}",
- 'expire_time' => $self->{'timeout'},
- 'unlink_on_exit' => 0,
- );
+ my ($cache, $share_file);
+
+ # Temporary workaround to catch fatal errors when: C4::Context module
+ # is not loaded beforehand, or Cache::FastMmap init fails for whatever
+ # other reason (e.g. due to permission issues - see Bug 13431)
+ eval {
+ $share_file = join( '-',
+ "/tmp/sharefile-koha", $self->{'namespace'},
+ C4::Context->config('hostname'), C4::Context->config('database') );
+
+ $cache = Cache::FastMmap->new(
+ 'share_file' => $share_file,
+ 'expire_time' => $self->{'timeout'},
+ 'unlink_on_exit' => 0,
+ );
+ };
+ if ( $@ ) {
+ warn "FastMmap cache initialization failed: $@";
+ return;
+ }
+ return unless defined $cache;
+ $self->{'fastmmap_cache'} = $cache;
return $self;
}
Expiry time of this cached entry in seconds.
-=item deepcopy
+=item unsafe
-If set, this will perform a deep copy of the item when it's retrieved. This
-means that it'll be safe if something later modifies the result of the
-function. Will be ignored in situations where the same behaviour comes from
-the caching layer anyway.
+If set, this will avoid performing a deep copy of the item. This
+means that it won't be safe if something later modifies the result of the
+function. It should be used with caution, and could save processing time
+in some situations where is safe to use it.
=item cache
The cache object to use if you want to provide your own. It should be an
instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
+=back
+
=cut
sub set_in_cache {
$new_options->{cache} = $_cache if defined $_cache;
$options = $new_options;
}
+ my $unsafe = $options->{unsafe} || 0;
# the key mustn't contain whitespace (or control characters) for memcache
# but shouldn't be any harm in applying it globally.
my $expiry = $options->{expiry};
$expiry //= $self->{timeout};
my $set_sub = $self->{ref($self->{$cache}) . "_set"};
+
+ # Deep copy if it's not a scalar and unsafe is not passed
+ $value = dclone( $value ) if ref($value) and not $unsafe;
+
+ # Set in L1 cache
+ $L1_cache{ $key } = $value;
+
# We consider an expiry of 0 to be inifinite
if ( $expiry ) {
return $set_sub
=head2 get_from_cache
- my $value = $cache->get_from_cache($key);
+ my $value = $cache->get_from_cache($key, [ $options ]);
Retrieve the value stored under the specified key in the default cache.
+The possible options are:
+
+=over
+
+=item unsafe
+
+If set, this will avoid performing a deep copy of the item. This
+means that it won't be safe if something later modifies the result of the
+function. It should be used with caution, and could save processing time
+in some situations where is safe to use it. Make sure you know what you are doing!
+
+=item cache
+
+The cache object to use if you want to provide your own. It should be an
+instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
+
+=back
+
=cut
sub get_from_cache {
- my ( $self, $key, $cache ) = @_;
+ my ( $self, $key, $options ) = @_;
+ my $cache = $options->{cache} || 'cache';
+ my $unsafe = $options->{unsafe} || 0;
$key =~ s/[\x00-\x20]/_/g;
- $cache ||= 'cache';
croak "No key" unless $key;
$ENV{DEBUG} && carp "get_from_cache for $key";
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+
+ # Return L1 cache value if exists
+ if ( exists $L1_cache{$key} ) {
+ # No need to deep copy if it's a scalar
+ # Or if we do not need to deep copy
+ return $L1_cache{$key}
+ if not ref $L1_cache{$key} or $unsafe;
+ return dclone $L1_cache{$key};
+ }
+
my $get_sub = $self->{ref($self->{$cache}) . "_get"};
- return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
+ my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
+
+ # Update the L1 cache when fetching the L2 cache
+ # Otherwise the L1 cache won't ever be populated
+ $L1_cache{$key} = $value;
+
+ $value = dclone $value if ref $L1_cache{$key} and not $unsafe;
+
+ return $value;
}
=head2 clear_from_cache
$cache ||= 'cache';
croak "No key" unless $key;
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+
+ # Clear from L1 cache
+ delete $L1_cache{$key};
+
return $self->{$cache}->delete($key)
if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
return $self->{$cache}->remove($key);
my ( $self, $cache ) = shift;
$cache ||= 'cache';
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+
+ $self->flush_L1_cache();
+
return $self->{$cache}->flush_all()
if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
return $self->{$cache}->clear();
}
+sub flush_L1_cache {
+ my( $self ) = @_;
+ %L1_cache = ();
+}
+
=head1 TIED INTERFACE
Koha::Cache also provides a tied interface which enables users to provide a
$args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
$args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
- unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
+ unless ( $args->{cache_type} and lc( $args->{cache_type} ) eq 'null' ) {
$args->{'cache'} = $self;
$args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
}