View | Details | Raw Unified | Return to bug 8092
Collapse All | Expand All

(-)a/Koha/Cache.pm (-3 / +43 lines)
Lines 27-36 Koha::Cache - Handling caching of html and Objects for Koha Link Here
27
27
28
=head1 DESCRIPTION
28
=head1 DESCRIPTION
29
29
30
Base class for Koha::Cache::X. Subclasses need to provide the following methods
30
Base class for Koha::Cache::X. Subclasses must provide the following methods
31
31
32
B<_cache_handle ($params_hr)> - cache handle creator
32
B<_cache_handle ($params_hr)> - cache handle creator
33
33
34
Subclasses may override the following methods if they are not using a
35
CHI-derived cache
36
34
B<set_in_cache ($key, $value, $expiry)>
37
B<set_in_cache ($key, $value, $expiry)>
35
38
36
B<get_from_cache ($key)>
39
B<get_from_cache ($key)>
Lines 46-56 B<flush_all ()> Link Here
46
use strict;
49
use strict;
47
use warnings;
50
use warnings;
48
use Carp;
51
use Carp;
52
use Module::Load::Conditional qw(can_load);
53
use Module::Load;
54
use CHI;
49
55
50
use base qw(Class::Accessor);
56
use base qw(Class::Accessor);
51
57
52
use Koha::Cache::Memcached;
53
54
__PACKAGE__->mk_ro_accessors( qw( cache ) );
58
__PACKAGE__->mk_ro_accessors( qw( cache ) );
55
59
56
sub new {
60
sub new {
Lines 58-63 sub new { Link Here
58
    my $param = shift;
62
    my $param = shift;
59
    my $cache_type = $ENV{CACHING_SYSTEM} || $param->{cache_type} || 'memcached';
63
    my $cache_type = $ENV{CACHING_SYSTEM} || $param->{cache_type} || 'memcached';
60
    my $subclass = __PACKAGE__."::".ucfirst($cache_type);
64
    my $subclass = __PACKAGE__."::".ucfirst($cache_type);
65
    unless (can_load( modules => { $subclass => 0 }) ) {
66
        $subclass = __PACKAGE__."::".ucfirst('Null');
67
        load $subclass;
68
    }
61
    my $cache    = $subclass->_cache_handle($param)
69
    my $cache    = $subclass->_cache_handle($param)
62
      or croak "Cannot create cache handle for '$cache_type'";
70
      or croak "Cannot create cache handle for '$cache_type'";
63
    return bless $class->SUPER::new({cache => $cache}), $subclass;
71
    return bless $class->SUPER::new({cache => $cache}), $subclass;
Lines 67-72 sub is_cache_active { Link Here
67
    return $ENV{CACHING_SYSTEM} ? '1' : '' ;
75
    return $ENV{CACHING_SYSTEM} ? '1' : '' ;
68
}
76
}
69
77
78
sub set_in_cache {
79
    my ( $self, $key, $value, $expiry ) = @_;
80
    croak "No key" unless $key;
81
    $ENV{DEBUG} && warn "set_in_cache for $key";
82
83
    if ( defined $expiry ) {
84
        return $self->{cache}->set( $key, $value, $expiry );
85
    }
86
    else {
87
        return $self->{cache}->set( $key, $value );
88
    }
89
}
90
91
sub get_from_cache {
92
    my ( $self, $key ) = @_;
93
    croak "No key" unless $key;
94
    $ENV{DEBUG} && warn "get_from_cache for $key";
95
    return $self->{cache}->get($key);
96
}
97
98
sub clear_from_cache {
99
    my ( $self, $key ) = @_;
100
    croak "No key" unless $key;
101
    return $self->{cache}->remove($key);
102
}
103
104
sub flush_all {
105
    my $self = shift;
106
    return $self->{cache}->clear();
107
}
108
70
=head2 EXPORT
109
=head2 EXPORT
71
110
72
None by default.
111
None by default.
Lines 79-84 Koha::Cache::Memcached Link Here
79
118
80
Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
119
Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
81
Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
120
Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
121
Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
82
122
83
=cut
123
=cut
84
124
(-)a/Koha/Cache/Fastmmap.pm (+45 lines)
Line 0 Link Here
1
package Koha::Cache::Fastmmap;
2
3
# Copyright 2012 C & P Bibliography Services
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it under the
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License along
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
use strict;
21
use warnings;
22
use Carp;
23
use CHI;
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    return CHI->new(
31
        driver => 'FastMmap',
32
        namespace => $params->{'namespace'} || 'koha',
33
        expire_in => 600,
34
        cache_size => $params->{'cachesize'} || '1m',
35
    );
36
}
37
38
1;
39
__END__
40
41
=head1 NAME
42
43
Koha::Cache::Fastmmap - persistent interprocess mmap-based cache for Koha
44
45
=cut
(-)a/Koha/Cache/Memcached.pm (-35 / +12 lines)
Lines 20-27 package Koha::Cache::Memcached; Link Here
20
use strict;
20
use strict;
21
use warnings;
21
use warnings;
22
use Carp;
22
use Carp;
23
23
use CHI;
24
use Cache::Memcached;
24
use Cache::Memcached::Fast;
25
25
26
use base qw(Koha::Cache);
26
use base qw(Koha::Cache);
27
27
Lines 30-74 sub _cache_handle { Link Here
30
    my $params = shift;
30
    my $params = shift;
31
    my @servers = split /,/, $params->{'cache_servers'}?$params->{'cache_servers'}:$ENV{MEMCACHED_SERVERS};
31
    my @servers = split /,/, $params->{'cache_servers'}?$params->{'cache_servers'}:$ENV{MEMCACHED_SERVERS};
32
    $ENV{DEBUG} && warn "Caching server settings: ".join(', ',@servers)." with ".($ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha');
32
    $ENV{DEBUG} && warn "Caching server settings: ".join(', ',@servers)." with ".($ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha');
33
    return Cache::Memcached->new(
33
    return CHI->new(
34
        servers   => \@servers,
34
        driver => 'Memcached::Fast',
35
        debug   => 0,
35
        servers => \@servers,
36
        compress_threshold => 10_000,
37
        expire_time => 600,
38
        namespace => $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha',
36
        namespace => $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha',
37
        compress_threshold => 10_000,
38
        l1_cache => { driver => 'Memory', global => 1, max_size => 1024*1024 },
39
    );
39
    );
40
    # We use a 1MB L1 memory cache for added efficiency
40
}
41
}
41
42
42
sub set_in_cache {
43
# We have to overload flush_all because CHI::Driver::Memcached::Fast does not
43
    my ( $self, $key, $value, $expiry ) = @_;
44
# support the clear() method
44
    croak "No key" unless $key;
45
    $self->cache->set_debug;
46
    $ENV{DEBUG} && warn "set_in_cache for Memcache $key";
47
48
    if ( defined $expiry ) {
49
        return $self->cache->set( $key, $value, $expiry );
50
    }
51
    else {
52
        return $self->cache->set( $key, $value );
53
    }
54
}
55
56
sub get_from_cache {
57
    my ( $self, $key ) = @_;
58
    croak "No key" unless $key;
59
    $ENV{DEBUG} && warn "get_from_cache for Memcache $key";
60
    return $self->cache->get($key);
61
}
62
63
sub clear_from_cache {
64
    my ( $self, $key ) = @_;
65
    croak "No key" unless $key;
66
    return $self->cache->delete($key);
67
}
68
69
sub flush_all {
45
sub flush_all {
70
    my $self = shift;
46
    my $self = shift;
71
    return $self->cache->flush_all;
47
    $self->{cache}->l1_cache->clear();
48
    return $self->{cache}->memd->flush_all();
72
}
49
}
73
50
74
1;
51
1;
(-)a/Koha/Cache/Memory.pm (+46 lines)
Line 0 Link Here
1
package Koha::Cache::Memory;
2
3
# Copyright 2012 C & P Bibliography Services
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it under the
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License along
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
use strict;
21
use warnings;
22
use Carp;
23
use CHI;
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    return CHI->new(
31
        driver => 'Memory',
32
        namespace => $params->{'namespace'} || 'koha',
33
        expire_in => 600,
34
        max_size => $params->{'max_size'} || 8192*1024,
35
        global => 1,
36
    );
37
}
38
39
1;
40
__END__
41
42
=head1 NAME
43
44
Koha::Cache::Memory - in-process memory based cache for Koha
45
46
=cut
(-)a/Koha/Cache/Null.pm (+42 lines)
Line 0 Link Here
1
package Koha::Cache::Null;
2
3
# Copyright 2012 C & P Bibliography Services
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it under the
8
# terms of the GNU General Public License as published by the Free Software
9
# Foundation; either version 2 of the License, or (at your option) any later
10
# version.
11
#
12
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15
#
16
# You should have received a copy of the GNU General Public License along
17
# with Koha; if not, write to the Free Software Foundation, Inc.,
18
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
use strict;
21
use warnings;
22
use Carp;
23
use CHI;
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    return CHI->new(
31
        driver => 'Null',
32
    );
33
}
34
35
1;
36
__END__
37
38
=head1 NAME
39
40
Koha::Cache::Null - null (no-op) cache for Koha
41
42
=cut
(-)a/t/Cache.t (-4 / +3 lines)
Lines 1-6 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
2
3
# Tests Koha::Cache and Koha::Cache::Memcached (through Koha::Cache)
3
# Tests Koha::Cache and whichever type of cache is enabled (through Koha::Cache)
4
4
5
use strict;
5
use strict;
6
use warnings;
6
use warnings;
Lines 13-21 BEGIN { Link Here
13
}
13
}
14
14
15
SKIP: {
15
SKIP: {
16
    skip "Memcached not enabled", 7 unless C4::Context->ismemcached;
16
    my $cache = Koha::Cache->new ();
17
17
18
    my $cache = Koha::Cache->new ( { 'cache_servers' => $ENV{'MEMCACHED_SERVERS'} } );
18
    skip "Cache not enabled", 7 unless (Koha::Cache->is_cache_active() && defined $cache);
19
19
20
    # test fetching an item that isnt in the cache
20
    # test fetching an item that isnt in the cache
21
    is( $cache->get_from_cache("not in here"), undef, "fetching item NOT in cache");
21
    is( $cache->get_from_cache("not in here"), undef, "fetching item NOT in cache");
22
- 

Return to bug 8092