gitea
/
Koha-clms
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'bug_9434' into 3.12-master

This commit is contained in:
Jared Camins-Esakov 2013-03-20 15:16:10 -04:00
parent 89bbab4b84 b07f4debb7
commit 2f3f5d9a3c
10 changed files with 651 additions and 360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
C4/Installer/PerlDependencies.pm
View File

@ -254,15 +254,15 @@ our $PERL_DEPS = {
'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',

368
Koha/Cache.pm
View File

@ -1,6 +1,7 @@
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.
#
@ -23,24 +24,13 @@ Koha::Cache - Handling caching of html and Objects for 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
@ -50,90 +40,348 @@ 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 Koha::Cache::Object;
use base qw(Class::Accessor);
__PACKAGE__->mk_ro_accessors(qw( cache ));
__PACKAGE__->mk_ro_accessors(
qw( cache memcached_cache fastmmap_cache memory_cache ));
=head2 new
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'};
}
}
my $cache = $subclass->_cache_handle($param);
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 ( 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();
}
=head2 EXPORT
=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;
}
=head1 EXPORT
None by default.
=head1 SEE ALSO
Koha::Cache::Memcached
Koha::Cache::Object
=head1 AUTHOR

49
Koha/Cache/Fastmmap.pm
View File

@ -1,49 +0,0 @@
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

124
Koha/Cache/Memcached.pm
View File

@ -1,124 +0,0 @@
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

50
Koha/Cache/Memory.pm
View File

@ -1,50 +0,0 @@
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

41
Koha/Cache/Null.pm
View File

@ -1,41 +0,0 @@
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

220
Koha/Cache/Object.pm Normal file
View File

@ -0,0 +1,220 @@
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__

1
t/00-load.t
View File

@ -42,7 +42,6 @@ find(
$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'");
},
},

136
t/Cache.t
View File

@ -5,39 +5,141 @@
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' );
}
}

14
t/optional/Cache_Memcached.t
View File

@ -1,14 +0,0 @@
#!/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');
}