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

(-)a/Koha/Cache.pm (-10 / +67 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-70 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;
49
54
50
use base qw(Class::Accessor);
55
my $have_chi = 0;
56
57
BEGIN: {
58
    if ( can_load( modules => { CHI => undef } ) ) {
59
        $have_chi = 1;
60
    }
61
}
51
62
52
use Koha::Cache::Memcached;
63
use base qw(Class::Accessor);
53
64
54
__PACKAGE__->mk_ro_accessors( qw( cache ) );
65
__PACKAGE__->mk_ro_accessors(qw( cache ));
55
66
56
sub new {
67
sub new {
57
    my $class = shift;
68
    my $class = shift;
58
    my $param = shift;
69
    my $param = shift;
59
    my $cache_type = $ENV{CACHING_SYSTEM} || $param->{cache_type} || 'memcached';
70
    my $cache_type =
60
    my $subclass = __PACKAGE__."::".ucfirst($cache_type);
71
         $ENV{CACHING_SYSTEM}
61
    my $cache    = $subclass->_cache_handle($param)
72
      || $param->{cache_type}
62
      or croak "Cannot create cache handle for '$cache_type'";
73
      || 'memcached';
63
    return bless $class->SUPER::new({cache => $cache}), $subclass;
74
    my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type);
75
    $param->{have_chi} = $have_chi;
76
    unless ( can_load( modules => { $subclass => undef } ) ) {
77
        $subclass = __PACKAGE__ . "::" . ucfirst('Null');
78
        load $subclass;
79
    }
80
    my $cache = $subclass->_cache_handle($param);
81
    return
82
      bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ),
83
      $subclass;
64
}
84
}
65
85
66
sub is_cache_active {
86
sub is_cache_active {
67
    return $ENV{CACHING_SYSTEM} ? '1' : '' ;
87
    return $ENV{CACHING_SYSTEM} ? '1' : '';
88
}
89
90
sub set_in_cache {
91
    my ( $self, $key, $value, $expiry ) = @_;
92
    croak "No key" unless $key;
93
    $ENV{DEBUG} && warn "set_in_cache for $key";
94
95
    return unless $self->{have_chi};
96
97
    if ( defined $expiry ) {
98
        return $self->{cache}->set( $key, $value, $expiry );
99
    }
100
    else {
101
        return $self->{cache}->set( $key, $value );
102
    }
103
}
104
105
sub get_from_cache {
106
    my ( $self, $key ) = @_;
107
    croak "No key" unless $key;
108
    $ENV{DEBUG} && warn "get_from_cache for $key";
109
    return unless $self->{have_chi};
110
    return $self->{cache}->get($key);
111
}
112
113
sub clear_from_cache {
114
    my ( $self, $key ) = @_;
115
    croak "No key" unless $key;
116
    return unless $self->{have_chi};
117
    return $self->{cache}->remove($key);
118
}
119
120
sub flush_all {
121
    my $self = shift;
122
    return unless $self->{have_chi};
123
    return $self->{cache}->clear();
68
}
124
}
69
125
70
=head2 EXPORT
126
=head2 EXPORT
Lines 79-84 Koha::Cache::Memcached Link Here
79
135
80
Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
136
Chris Cormack, E<lt>chris@bigballofwax.co.nzE<gt>
81
Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
137
Paul Poulain, E<lt>paul.poulain@biblibre.comE<gt>
138
Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
82
139
83
=cut
140
=cut
84
141
(-)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 (-21 / +64 lines)
Lines 1-6 Link Here
1
package Koha::Cache::Memcached;
1
package Koha::Cache::Memcached;
2
2
3
# Copyright 2009 Chris Cormack and The Koha Dev Team
3
# Copyright 2012 C & P Bibliography Services
4
#
4
#
5
# This file is part of Koha.
5
# This file is part of Koha.
6
#
6
#
Lines 20-50 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 Cache::Memcached::Fast;
24
use Cache::Memcached;
24
use Module::Load::Conditional qw(can_load);
25
25
26
use base qw(Koha::Cache);
26
use base qw(Koha::Cache);
27
27
28
sub _cache_handle {
28
sub _cache_handle {
29
    my $class  = shift;
29
    my $class   = shift;
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 /,/,
32
    $ENV{DEBUG} && warn "Caching server settings: ".join(', ',@servers)." with ".($ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha');
32
      $params->{'cache_servers'}
33
    return Cache::Memcached->new(
33
      ? $params->{'cache_servers'}
34
        servers   => \@servers,
34
      : $ENV{MEMCACHED_SERVERS};
35
        debug   => 0,
35
    my $namespace =
36
        compress_threshold => 10_000,
36
         $ENV{MEMCACHED_NAMESPACE}
37
        expire_time => 600,
37
      || $params->{'namespace'}
38
        namespace => $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha',
38
      || 'koha';
39
    );
39
    $ENV{DEBUG}
40
      && warn "Caching server settings: "
41
      . join( ', ', @servers )
42
      . " with "
43
      . ( $ENV{MEMCACHED_NAMESPACE} || $params->{'namespace'} || 'koha' );
44
    if (
45
        $params->{have_chi}
46
        && can_load(
47
            modules =>
48
              { 'CHI' => undef, 'CHI::Driver::Memcached::Fast' => undef }
49
        )
50
      )
51
    {
52
        return CHI->new(
53
            driver             => 'Memcached::Fast',
54
            servers            => \@servers,
55
            namespace          => $namespace,
56
            compress_threshold => 10_000,
57
            l1_cache =>
58
              { driver => 'Memory', global => 1, max_size => 1024 * 1024 },
59
        );
60
61
        # We use a 1MB L1 memory cache for added efficiency
62
    }
63
    else {
64
        return Cache::Memcached::Fast->new(
65
            {
66
                servers            => \@servers,
67
                compress_threshold => 10_000,
68
                namespace          => $namespace,
69
            }
70
        );
71
    }
40
}
72
}
41
73
42
sub set_in_cache {
74
sub set_in_cache {
43
    my ( $self, $key, $value, $expiry ) = @_;
75
    my ( $self, $key, $value, $expiry ) = @_;
44
    croak "No key" unless $key;
76
    return $self->SUPER::set_in_cache( $key, $value, $expiry )
45
    $self->cache->set_debug;
77
      if ( $self->{have_chi} );
46
    $ENV{DEBUG} && warn "set_in_cache for Memcache $key";
47
78
79
    # No CHI, we have to use Cache::Memcached::Fast directly
48
    if ( defined $expiry ) {
80
    if ( defined $expiry ) {
49
        return $self->cache->set( $key, $value, $expiry );
81
        return $self->cache->set( $key, $value, $expiry );
50
    }
82
    }
Lines 55-74 sub set_in_cache { Link Here
55
87
56
sub get_from_cache {
88
sub get_from_cache {
57
    my ( $self, $key ) = @_;
89
    my ( $self, $key ) = @_;
58
    croak "No key" unless $key;
90
    return $self->SUPER::get_from_cache($key) if ( $self->{have_chi} );
59
    $ENV{DEBUG} && warn "get_from_cache for Memcache $key";
91
92
    # No CHI, we have to use Cache::Memcached::Fast directly
60
    return $self->cache->get($key);
93
    return $self->cache->get($key);
61
}
94
}
62
95
63
sub clear_from_cache {
96
sub clear_from_cache {
64
    my ( $self, $key ) = @_;
97
    my ( $self, $key ) = @_;
65
    croak "No key" unless $key;
98
    return $self->SUPER::clear_from_cache($key) if ( $self->{have_chi} );
99
100
    # No CHI, we have to use Cache::Memcached::Fast directly
66
    return $self->cache->delete($key);
101
    return $self->cache->delete($key);
67
}
102
}
68
103
104
# We have to overload flush_all because CHI::Driver::Memcached::Fast does not
105
# support the clear() method
69
sub flush_all {
106
sub flush_all {
70
    my $self = shift;
107
    my $self = shift;
71
    return $self->cache->flush_all;
108
    if ( $self->{have_chi} ) {
109
        $self->{cache}->l1_cache->clear();
110
        return $self->{cache}->memd->flush_all();
111
    }
112
    else {
113
        return $self->{cache}->flush_all;
114
    }
72
}
115
}
73
116
74
1;
117
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 (+41 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 Module::Load;
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    load CHI if $params->{have_chi};
31
    return $params->{have_chi} ? CHI->new( driver => 'Null' ) : undef;
32
}
33
34
1;
35
__END__
36
37
=head1 NAME
38
39
Koha::Cache::Null - null (no-op) cache for Koha
40
41
=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