'required' => '0',
'min_ver' => '0.17'
},
- 'CHI' => {
+ 'Cache::FastMmap' => {
'usage' => 'Caching',
'required' => '0',
- 'min_ver' => '0.36'
+ 'min_ver' => '1.34'
},
- 'CHI::Driver::Memcached' => {
+ 'Cache::Memory' => {
'usage' => 'Caching',
'required' => '0',
- 'min_ver' => '0.12'
+ 'min_ver' => '2.04'
},
'Net::LDAP::Filter' => {
'usage' => 'LDAP Interface Feature',
package Koha::Cache;
# Copyright 2009 Chris Cormack and The Koha Dev Team
+# Parts copyright 2012-2013 C & P Bibliography Services
#
# This file is part of Koha.
#
=head1 SYNOPSIS
- use Koha::Cache (cache_type => $cache_type, %params );
+ use Koha::Cache;
+ my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
=head1 DESCRIPTION
-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)>
-
-B<clear_from_cache ($key)>
-
-B<flush_all ()>
+Koha caching routines. This class provides two interfaces for cache access.
+The first, traditional interface provides the following functions:
=head1 FUNCTIONS
use warnings;
use Carp;
use Module::Load::Conditional qw(can_load);
-use Module::Load;
+use Koha::Cache::Object;
-my $have_chi = 0;
+use base qw(Class::Accessor);
-BEGIN: {
- if ( can_load( modules => { CHI => undef } ) ) {
- $have_chi = 1;
- }
-}
+__PACKAGE__->mk_ro_accessors(
+ qw( cache memcached_cache fastmmap_cache memory_cache ));
-use base qw(Class::Accessor);
+=head2 new
-__PACKAGE__->mk_ro_accessors(qw( cache ));
+Create a new Koha::Cache object. This is required for all cache-related functionality.
+
+=cut
sub new {
- my $class = shift;
- my $param = shift;
- my $cache_type =
- $ENV{CACHING_SYSTEM}
- || $param->{cache_type}
+ my ( $class, $self ) = @_;
+ $self->{'default_type'} =
+ $self->{cache_type}
+ || $ENV{CACHING_SYSTEM}
|| 'memcached';
- my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type);
- $param->{have_chi} = $have_chi;
- unless ( can_load( modules => { $subclass => undef } ) ) {
- $subclass = __PACKAGE__ . "::" . ucfirst('Null');
- load $subclass;
+
+ $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
+
+ $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'};
+ }
}
- my $cache = $subclass->_cache_handle($param);
+
+ 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'};
+ }
+ }
+
+# NOTE: The following five lines could be uncommented if we wanted to
+# fall back to any functioning cache. Commented out since this would
+# represent a change in behavior.
+#
+#unless (defined($self->{'cache'})) {
+# foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) {
+# $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember}));
+# }
+#}
+
return
- bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ),
- $subclass;
+ bless $self,
+ $class;
+}
+
+sub _initialize_memcached {
+ my ($self) = @_;
+ my @servers =
+ split /,/, $self->{'cache_servers'}
+ ? $self->{'cache_servers'}
+ : $ENV{MEMCACHED_SERVERS};
+
+ $ENV{DEBUG}
+ && carp "Memcached server settings: "
+ . join( ', ', @servers )
+ . " with "
+ . $self->{'namespace'};
+ $self->{'memcached_cache'} = Cache::Memcached::Fast->new(
+ {
+ servers => \@servers,
+ compress_threshold => 10_000,
+ namespace => $self->{'namespace'},
+ }
+ );
+ return $self;
}
+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,
+ );
+ return $self;
+}
+
+sub _initialize_memory {
+ my ($self) = @_;
+
+ $self->{'memory_cache'} = Cache::Memory->new(
+ 'namespace' => $self->{'namespace'},
+ 'default_expires' => $self->{'timeout'}
+ );
+ return $self;
+}
+
+=head2 is_cache_active
+
+Routine that checks whether or not a caching system has been selected. This is
+not an instance method.
+
+=cut
+
sub is_cache_active {
return $ENV{CACHING_SYSTEM} ? '1' : '';
}
+=head2 set_in_cache
+
+ $cache->set_in_cache($key, $value, [$expiry]);
+
+Save a value to the specified key in the default cache, optionally with a
+particular expiry.
+
+=cut
+
sub set_in_cache {
- my ( $self, $key, $value, $expiry ) = @_;
+ my ( $self, $key, $value, $expiry, $cache ) = @_;
+ $cache ||= 'cache';
croak "No key" unless $key;
- $ENV{DEBUG} && warn "set_in_cache for $key";
-
- return unless $self->{cache};
- return unless $self->{have_chi};
+ $ENV{DEBUG} && carp "set_in_cache for $key";
+ return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
if ( defined $expiry ) {
- return $self->{cache}->set( $key, $value, $expiry );
+ if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {
+ $expiry = "$expiry sec";
+ }
+ return $self->{$cache}->set( $key, $value, $expiry );
}
else {
- return $self->{cache}->set( $key, $value );
+ return $self->{$cache}->set( $key, $value );
}
}
+=head2 get_from_cache
+
+ my $value = $cache->get_from_cache($key);
+
+Retrieve the value stored under the specified key in the default cache.
+
+=cut
+
sub get_from_cache {
- my ( $self, $key ) = @_;
+ my ( $self, $key, $cache ) = @_;
+ $cache ||= 'cache';
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);
+ $ENV{DEBUG} && carp "get_from_cache for $key";
+ return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+ return $self->{$cache}->get($key);
}
+=head2 clear_from_cache
+
+ $cache->clear_from_cache($key);
+
+Remove the value identified by the specified key from the default cache.
+
+=cut
+
sub clear_from_cache {
- my ( $self, $key ) = @_;
+ my ( $self, $key, $cache ) = @_;
+ $cache ||= 'cache';
croak "No key" unless $key;
- return unless $self->{cache};
- return unless $self->{have_chi};
- return $self->{cache}->remove($key);
+ return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+ return $self->{$cache}->delete($key)
+ if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
+ return $self->{$cache}->remove($key);
}
+=head2 flush_all
+
+ $cache->flush_all();
+
+Clear the entire default cache.
+
+=cut
+
sub flush_all {
- my $self = shift;
- return unless $self->{cache};
- return unless $self->{have_chi};
- return $self->{cache}->clear();
+ my ( $self, $cache ) = shift;
+ $cache ||= 'cache';
+ return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
+ return $self->{$cache}->flush_all()
+ if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
+ return $self->{$cache}->clear();
+}
+
+=head1 TIED INTERFACE
+
+Koha::Cache also provides a tied interface which enables users to provide a
+constructor closure and (after creation) treat cached data like normal reference
+variables and rely on the cache Just Working and getting updated when it
+expires, etc.
+
+ my $cache = Koha::Cache->new();
+ my $data = 'whatever';
+ my $scalar = Koha::Cache->create_scalar(
+ {
+ 'key' => 'whatever',
+ 'timeout' => 2,
+ 'constructor' => sub { return $data; },
+ }
+ );
+ print "$$scalar\n"; # Prints "whatever"
+ $data = 'somethingelse';
+ print "$$scalar\n"; # Prints "whatever" because it is cached
+ sleep 2; # Wait until the cache entry has expired
+ print "$$scalar\n"; # Prints "somethingelse"
+
+ my $hash = Koha::Cache->create_hash(
+ {
+ 'key' => 'whatever',
+ 'timeout' => 2,
+ 'constructor' => sub { return $data; },
+ }
+ );
+ print "$$variable\n"; # Prints "whatever"
+
+The gotcha with this interface, of course, is that the variable returned by
+create_scalar and create_hash is a I<reference> to a tied variable and not a
+tied variable itself.
+
+The tied variable is configured by means of a hashref passed in to the
+create_scalar and create_hash methods. The following parameters are supported:
+
+=over
+
+=item I<key>
+
+Required. The key to use for identifying the variable in the cache.
+
+=item I<constructor>
+
+Required. A closure (or reference to a function) that will return the value that
+needs to be stored in the cache.
+
+=item I<preload>
+
+Optional. A closure (or reference to a function) that gets run to initialize
+the cache when creating the tied variable.
+
+=item I<arguments>
+
+Optional. Array reference with the arguments that should be passed to the
+constructor function.
+
+=item I<timeout>
+
+Optional. The cache timeout in seconds for the variable. Defaults to 600
+(ten minutes).
+
+=item I<cache_type>
+
+Optional. Which type of cache to use for the variable. Defaults to whatever is
+set in the environment variable CACHING_SYSTEM. If set to 'null', disables
+caching for the tied variable.
+
+=item I<allowupdate>
+
+Optional. Boolean flag to allow the variable to be updated directly. When this
+is set and the variable is used as an l-value, the cache will be updated
+immediately with the new value. Using this is probably a bad idea on a
+multi-threaded system. When I<allowupdate> is not set to true, using the
+tied variable as an l-value will have no effect.
+
+=item I<destructor>
+
+Optional. A closure (or reference to a function) that should be called when the
+tied variable is destroyed.
+
+=item I<unset>
+
+Optional. Boolean flag to tell the object to remove the variable from the cache
+when it is destroyed or goes out of scope.
+
+=item I<inprocess>
+
+Optional. Boolean flag to tell the object not to refresh the variable from the
+cache every time the value is desired, but rather only when the I<local> copy
+of the variable is older than the timeout.
+
+=back
+
+=head2 create_scalar
+
+ my $scalar = Koha::Cache->create_scalar(\%params);
+
+Create scalar tied to the cache.
+
+=cut
+
+sub create_scalar {
+ my ( $self, $args ) = @_;
+
+ $self->_set_tied_defaults($args);
+
+ tie my $scalar, 'Koha::Cache::Object', $args;
+ return \$scalar;
+}
+
+sub create_hash {
+ my ( $self, $args ) = @_;
+
+ $self->_set_tied_defaults($args);
+
+ tie my %hash, 'Koha::Cache::Object', $args;
+ return \%hash;
+}
+
+sub _set_tied_defaults {
+ my ( $self, $args ) = @_;
+
+ $args->{'timeout'} = '600' unless defined( $args->{'timeout'} );
+ $args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} );
+ unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
+ $args->{'cache'} = $self;
+ $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
+ }
+
+ return $args;
}
-=head2 EXPORT
+=head1 EXPORT
None by default.
=head1 SEE ALSO
-Koha::Cache::Memcached
+Koha::Cache::Object
=head1 AUTHOR
+++ /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 Module::Load::Conditional qw(can_load);
-
-use base qw(Koha::Cache);
-
-sub _cache_handle {
- my $class = shift;
- my $params = shift;
- if ( can_load( modules => { CHI => undef } ) ) {
- return CHI->new(
- driver => 'FastMmap',
- namespace => $params->{'namespace'} || 'koha',
- expire_in => 600,
- cache_size => $params->{'cachesize'} || '1m',
- );
- } else {
- return;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Koha::Cache::Fastmmap - persistent interprocess mmap-based cache for Koha
-
-=cut
+++ /dev/null
-package Koha::Cache::Memcached;
-
-# 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 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};
- 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 ) = @_;
- 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 );
- }
- else {
- return $self->cache->set( $key, $value );
- }
-}
-
-sub get_from_cache {
- my ( $self, $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 ) = @_;
- 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;
- if ( $self->{have_chi} ) {
- $self->{cache}->l1_cache->clear();
- return $self->{cache}->memd->flush_all();
- }
- else {
- return $self->{cache}->flush_all;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Koha::Cache::Memcached - memcached subclass of Koha::Cache
-
-=cut
+++ /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 Module::Load::Conditional qw(can_load);
-
-use base qw(Koha::Cache);
-
-sub _cache_handle {
- my $class = shift;
- my $params = shift;
- if ( can_load( modules => { CHI => undef } ) ) {
- return CHI->new(
- driver => 'Memory',
- namespace => $params->{'namespace'} || 'koha',
- expire_in => 600,
- max_size => $params->{'max_size'} || 8192 * 1024,
- global => 1,
- );
- } else {
- return;
- }
-}
-
-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
--- /dev/null
+package Koha::Cache::Object;
+
+# Copyright 2013 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 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.
+#
+# 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.
+
+=head1 NAME
+
+Koha::Cache::Object - Tie-able class for caching objects
+
+=head1 SYNOPSIS
+
+ my $cache = Koha::Cache->new();
+ my $scalar = Koha::Cache->create_scalar(
+ {
+ 'key' => 'whatever',
+ 'timeout' => 2,
+ 'constructor' => sub { return 'stuff'; },
+ }
+ );
+ my %hash = Koha::Cache->create_hash(
+ {
+ 'key' => 'whateverelse',
+ 'timeout' => 2,
+ 'constructor' => sub { return { 'stuff' => 'nonsense' }; },
+ }
+ );
+
+=head1 DESCRIPTION
+
+Do not use this class directly. It is tied to variables by Koha::Cache
+for transparent cache access. If you choose to ignore this warning, you
+should be aware that it is disturbingly polymorphic and supports both
+scalars and hashes, with arrays a potential future addition.
+
+=head1 TIE METHODS
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+
+use base qw(Class::Accessor);
+
+__PACKAGE__->mk_ro_accessors(
+ qw( allowupdate arguments cache cache_type constructor destructor inprocess key lastupdate timeout unset value )
+);
+
+# General/SCALAR routines
+
+sub TIESCALAR {
+ my ( $class, $self ) = @_;
+
+ $self->{'datatype'} ||= 'SCALAR';
+ $self->{'arguments'} ||= [];
+ if ( defined $self->{'preload'} ) {
+ $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
+ if ( defined( $self->{'cache'} ) ) {
+ $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
+ $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
+ }
+ $self->{'lastupdate'} = time;
+ }
+ return bless $self, $class;
+}
+
+sub FETCH {
+ my ( $self, $index ) = @_;
+
+ $ENV{DEBUG}
+ && $index
+ && carp "Retrieving cached hash member $index of $self->{'key'}";
+
+ my $now = time;
+
+ if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
+ && $self->{'cache'} )
+ {
+ $self->{'value'} =
+ $self->{'cache'}
+ ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
+ $self->{'lastupdate'} = $now;
+ }
+
+ if ( !defined $self->{'value'}
+ || ( defined $index && !exists $self->{'value'}->{$index} )
+ || !defined $self->{'lastupdate'}
+ || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) )
+ {
+ $self->{'value'} =
+ &{ $self->{'constructor'} }( @{ $self->{'arguments'} },
+ $self->{'value'}, $index );
+ if ( defined( $self->{'cache'} ) ) {
+ $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
+ $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
+ }
+ $self->{'lastupdate'} = $now;
+ }
+ if ( $self->{'datatype'} eq 'HASH' && defined $index ) {
+ return $self->{'value'}->{$index};
+ }
+ return $self->{'value'};
+}
+
+sub STORE {
+ my $value = pop @_;
+ my ( $self, $index ) = @_;
+
+ if ( $self->{'datatype'} eq 'HASH' && defined($index) ) {
+ $self->{'value'}->{$index} = $value;
+ }
+ else {
+ $self->{'value'} = $value;
+ }
+ if ( defined( $self->{'allowupdate'} )
+ && $self->{'allowupdate'}
+ && defined( $self->{'cache'} ) )
+ {
+ $self->{'cache'}
+ ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'},
+ $self->{'cache_type'} . '_cache' );
+ }
+
+ return $self->{'value'};
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ if ( defined( $self->{'destructor'} ) ) {
+ &{ $self->{'destructor'} }( @{ $self->{'arguments'} } );
+ }
+
+ if ( defined( $self->{'unset'} )
+ && $self->{'unset'}
+ && defined( $self->{'cache'} ) )
+ {
+ $self->{'cache'}->clear_from_cache( $self->{'key'},
+ $self->{'cache_type'} . '_cache' );
+ }
+
+ undef $self->{'value'};
+
+ return $self;
+}
+
+# HASH-specific routines
+
+sub TIEHASH {
+ my ( $class, $self, @args ) = @_;
+ $self->{'datatype'} = 'HASH';
+ return TIESCALAR( $class, $self, @args );
+}
+
+sub DELETE {
+ my ( $self, $index ) = @_;
+ delete $self->{'value'}->{$index};
+ return $self->STORE( $self->{'value'} );
+}
+
+sub EXISTS {
+ my ( $self, $index ) = @_;
+ $self->FETCH($index);
+ return exists $self->{'value'}->{$index};
+}
+
+sub FIRSTKEY {
+ my ($self) = @_;
+ $self->FETCH;
+ $self->{'iterator'} = [ keys %{ $self->{'value'} } ];
+ return $self->NEXTKEY;
+}
+
+sub NEXTKEY {
+ my ($self) = @_;
+ return shift @{ $self->{'iterator'} };
+}
+
+sub SCALAR {
+ my ($self) = @_;
+ $self->FETCH;
+ return scalar %{ $self->{'value'} }
+ if ( ref( $self->{'value'} ) eq 'HASH' );
+ return;
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ return $self->DESTROY;
+}
+
+# ARRAY-specific routines
+
+=head1 SEE ALSO
+
+Koha::Cache, tie, perltie
+
+=head1 AUTHOR
+
+Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
+
+=cut
+
+1;
+
+__END__
$m =~ s{^.*/Koha/}{Koha/};
$m =~ s{/}{::}g;
return if $m =~ /Koha::SearchEngine/; # Koha::SearchEngine::* are experimental
- return if $m =~ /Koha::Cache::Memcached/; # optional dependency
use_ok($m) || BAIL_OUT("***** PROBLEMS LOADING FILE '$m'");
},
},
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 29;
+
+my $destructorcount = 0;
BEGIN {
- use_ok('Koha::Cache');
- use_ok('C4::Context');
+ use_ok('Koha::Cache');
+ use_ok('Koha::Cache::Object');
+ use_ok('C4::Context');
}
SKIP: {
- my $cache = Koha::Cache->new ();
+ my $cache = Koha::Cache->new();
- skip "Cache not enabled", 7 unless (Koha::Cache->is_cache_active() && defined $cache);
+ skip "Cache not enabled", 13
+ 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");
+ is( $cache->get_from_cache("not in here"),
+ undef, "fetching item NOT in cache" );
# test expiry time in cache
- $cache->set_in_cache("timeout", "I AM DATA", 1); # expiry time of 1 second
- sleep 1;
- is( $cache->get_from_cache("timeout"), undef, "fetching expired item from cache");
+ $cache->set_in_cache( "timeout", "I AM DATA", 1 ); # expiry time of 1 second
+ sleep 2;
+ is( $cache->get_from_cache("timeout"),
+ undef, "fetching expired item from cache" );
# test fetching a valid, non expired, item from cache
- $cache->set_in_cache("clear_me", "I AM MORE DATA", 1000); # overly large expiry time, clear below
- $cache->set_in_cache("dont_clear_me", "I AM MORE DATA22", 1000); # overly large expiry time, clear below
- is( $cache->get_from_cache("clear_me"), "I AM MORE DATA", "fetching valid item from cache");
+ $cache->set_in_cache( "clear_me", "I AM MORE DATA", 1000 )
+ ; # overly large expiry time, clear below
+ $cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22", 1000 )
+ ; # overly large expiry time, clear below
+ is(
+ $cache->get_from_cache("clear_me"),
+ "I AM MORE DATA",
+ "fetching valid item from cache"
+ );
# test clearing from cache
$cache->clear_from_cache("clear_me");
- is( $cache->get_from_cache("clear_me"), undef, "fetching cleared item from cache");
- is( $cache->get_from_cache("dont_clear_me"), "I AM MORE DATA22", "fetching valid item from cache (after clearing another item)");
+ is( $cache->get_from_cache("clear_me"),
+ undef, "fetching cleared item from cache" );
+ is(
+ $cache->get_from_cache("dont_clear_me"),
+ "I AM MORE DATA22",
+ "fetching valid item from cache (after clearing another item)"
+ );
#test flushing from cache
- $cache->set_in_cache("flush_me", "testing 1 data");
+ $cache->set_in_cache( "flush_me", "testing 1 data" );
$cache->flush_all;
- is( $cache->get_from_cache("flush_me"), undef, "fetching flushed item from cache");
- is( $cache->get_from_cache("dont_clear_me"), undef, "fetching flushed item from cache");
+ is( $cache->get_from_cache("flush_me"),
+ undef, "fetching flushed item from cache" );
+ is( $cache->get_from_cache("dont_clear_me"),
+ undef, "fetching flushed item from cache" );
+
+ my $constructorcount = 0;
+ my $myscalar = $cache->create_scalar(
+ {
+ 'key' => 'myscalar',
+ 'timeout' => 1,
+ 'allowupdate' => 1,
+ 'unset' => 1,
+ 'constructor' => sub { return ++$constructorcount; },
+ 'destructor' => sub { return ++$destructorcount; },
+ }
+ );
+ ok( defined($myscalar), 'Created tied scalar' );
+ is( $$myscalar, 1, 'Constructor called to first initialize' );
+ is( $$myscalar, 1, 'Data retrieved from cache' );
+ sleep 2;
+ is( $$myscalar, 2, 'Constructor called again when timeout reached' );
+ $$myscalar = 5;
+ is( $$myscalar, 5, 'Stored new value to cache' );
+ is( $constructorcount, 2, 'Constructor not called after storing value' );
+ undef $myscalar;
+
+ is( $cache->get_from_cache("myscalar"),
+ undef, 'Item removed from cache on destruction' );
+
+ my %hash = ( 'key' => 'value' );
+
+ my $myhash = $cache->create_hash(
+ {
+ 'key' => 'myhash',
+ 'timeout' => 1,
+ 'allowupdate' => 1,
+ 'unset' => 1,
+ 'constructor' => sub { return { %hash }; },
+ }
+ );
+
+ ok(defined $myhash, 'Created tied hash');
+
+ is($myhash->{'key'}, 'value', 'Found expected value in hash');
+ ok(exists $myhash->{'key'}, 'Exists works');
+ $myhash->{'key2'} = 'surprise';
+ is($myhash->{'key2'}, 'surprise', 'Setting hash member worked');
+ $hash{'key2'} = 'nosurprise';
+ sleep 2;
+ is($myhash->{'key2'}, 'nosurprise', 'Cache change caught');
+
+
+ my $foundkeys = 0;
+ foreach my $key (keys %{$myhash}) {
+ $foundkeys++;
+ }
+
+ is($foundkeys, 2, 'Found expected 2 keys when iterating through hash');
+
+ isnt(scalar %{$myhash}, undef, 'scalar knows the hash is not empty');
+
+ $hash{'anotherkey'} = 'anothervalue';
+
+ sleep 2;
+
+ ok(exists $myhash->{'anotherkey'}, 'Cache reset properly');
+
+ delete $hash{'anotherkey'};
+ delete $myhash->{'anotherkey'};
+
+ ok(!exists $myhash->{'anotherkey'}, 'Key successfully deleted');
+
+ undef %hash;
+ %{$myhash} = ();
+
+ is(scalar %{$myhash}, 0, 'hash cleared');
+
+ $hash{'key'} = 'value';
+ is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
+}
+
+END {
+ SKIP: {
+ skip "Cache not enabled", 1
+ unless ( Koha::Cache->is_cache_active() );
+ is( $destructorcount, 1, 'Destructor run exactly once' );
+ }
}
+++ /dev/null
-#!/usr/bin/perl
-#
-# This Koha test module is a stub!
-# Add more tests here!!!
-
-use strict;
-use warnings;
-
-use Test::More tests => 1;
-
-BEGIN {
- use_ok('Koha::Cache::Memcached');
-}
-