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

(-)a/C4/Installer/PerlDependencies.pm (-4 / +4 lines)
Lines 254-268 our $PERL_DEPS = { Link Here
254
        'required' => '0',
254
        'required' => '0',
255
        'min_ver'  => '0.17'
255
        'min_ver'  => '0.17'
256
    },
256
    },
257
    'CHI' => {
257
    'Cache::FastMmap' => {
258
        'usage'    => 'Caching',
258
        'usage'    => 'Caching',
259
        'required' => '0',
259
        'required' => '0',
260
        'min_ver'  => '0.36'
260
        'min_ver'  => '1.34'
261
    },
261
    },
262
    'CHI::Driver::Memcached' => {
262
    'Cache::Memory' => {
263
        'usage'    => 'Caching',
263
        'usage'    => 'Caching',
264
        'required' => '0',
264
        'required' => '0',
265
        'min_ver'  => '0.12'
265
        'min_ver'  => '2.04'
266
    },
266
    },
267
    'Net::LDAP::Filter' => {
267
    'Net::LDAP::Filter' => {
268
        'usage'    => 'LDAP Interface Feature',
268
        'usage'    => 'LDAP Interface Feature',
(-)a/Koha/Cache.pm (-59 / +307 lines)
Lines 1-6 Link Here
1
package Koha::Cache;
1
package Koha::Cache;
2
2
3
# Copyright 2009 Chris Cormack and The Koha Dev Team
3
# Copyright 2009 Chris Cormack and The Koha Dev Team
4
# Parts copyright 2012-2013 C & P Bibliography Services
4
#
5
#
5
# This file is part of Koha.
6
# This file is part of Koha.
6
#
7
#
Lines 23-46 Koha::Cache - Handling caching of html and Objects for Koha Link Here
23
24
24
=head1 SYNOPSIS
25
=head1 SYNOPSIS
25
26
26
  use Koha::Cache (cache_type => $cache_type, %params );
27
  use Koha::Cache;
28
  my $cache = Koha::Cache->new({cache_type => $cache_type, %params});
27
29
28
=head1 DESCRIPTION
30
=head1 DESCRIPTION
29
31
30
Base class for Koha::Cache::X. Subclasses must provide the following methods
32
Koha caching routines. This class provides two interfaces for cache access.
31
33
The first, traditional interface provides the following functions:
32
B<_cache_handle ($params_hr)> - cache handle creator
33
34
Subclasses may override the following methods if they are not using a
35
CHI-derived cache
36
37
B<set_in_cache ($key, $value, $expiry)>
38
39
B<get_from_cache ($key)>
40
41
B<clear_from_cache ($key)>
42
43
B<flush_all ()>
44
34
45
=head1 FUNCTIONS
35
=head1 FUNCTIONS
46
36
Lines 50-139 use strict; Link Here
50
use warnings;
40
use warnings;
51
use Carp;
41
use Carp;
52
use Module::Load::Conditional qw(can_load);
42
use Module::Load::Conditional qw(can_load);
53
use Module::Load;
43
use Koha::Cache::Object;
54
44
55
my $have_chi = 0;
45
use base qw(Class::Accessor);
56
46
57
BEGIN: {
47
__PACKAGE__->mk_ro_accessors(
58
    if ( can_load( modules => { CHI => undef } ) ) {
48
    qw( cache memcached_cache fastmmap_cache memory_cache ));
59
        $have_chi = 1;
60
    }
61
}
62
49
63
use base qw(Class::Accessor);
50
=head2 new
64
51
65
__PACKAGE__->mk_ro_accessors(qw( cache ));
52
Create a new Koha::Cache object. This is required for all cache-related functionality.
53
54
=cut
66
55
67
sub new {
56
sub new {
68
    my $class = shift;
57
    my ( $class, $self ) = @_;
69
    my $param = shift;
58
    $self->{'default_type'} =
70
    my $cache_type =
59
         $self->{cache_type}
71
         $ENV{CACHING_SYSTEM}
60
      || $ENV{CACHING_SYSTEM}
72
      || $param->{cache_type}
73
      || 'memcached';
61
      || 'memcached';
74
    my $subclass = __PACKAGE__ . "::" . ucfirst($cache_type);
62
75
    $param->{have_chi} = $have_chi;
63
    $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
76
    unless ( can_load( modules => { $subclass => undef } ) ) {
64
77
        $subclass = __PACKAGE__ . "::" . ucfirst('Null');
65
    $self->{'timeout'}   ||= 0;
78
        load $subclass;
66
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
67
68
    if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
69
        _initialize_memcached($self);
70
        if ( $self->{'default_type'} eq 'memcached'
71
            && defined( $self->{'memcached_cache'} ) )
72
        {
73
            $self->{'cache'} = $self->{'memcached_cache'};
74
        }
75
    }
76
77
    if ( can_load( modules => { 'Cache::FastMmap' => undef } ) ) {
78
        _initialize_fastmmap($self);
79
        if ( $self->{'default_type'} eq 'fastmmap'
80
            && defined( $self->{'fastmmap_cache'} ) )
81
        {
82
            $self->{'cache'} = $self->{'fastmmap_cache'};
83
        }
79
    }
84
    }
80
    my $cache = $subclass->_cache_handle($param);
85
86
    if ( can_load( modules => { 'Cache::Memory' => undef } ) ) {
87
        _initialize_memory($self);
88
        if ( $self->{'default_type'} eq 'memory'
89
            && defined( $self->{'memory_cache'} ) )
90
        {
91
            $self->{'cache'} = $self->{'memory_cache'};
92
        }
93
    }
94
95
# NOTE: The following five lines could be uncommented if we wanted to
96
#       fall back to any functioning cache. Commented out since this would
97
#       represent a change in behavior.
98
#
99
#unless (defined($self->{'cache'})) {
100
#    foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) {
101
#        $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember}));
102
#    }
103
#}
104
81
    return
105
    return
82
      bless $class->SUPER::new( { cache => $cache, have_chi => $have_chi } ),
106
      bless $self,
83
      $subclass;
107
      $class;
108
}
109
110
sub _initialize_memcached {
111
    my ($self) = @_;
112
    my @servers =
113
      split /,/, $self->{'cache_servers'}
114
      ? $self->{'cache_servers'}
115
      : $ENV{MEMCACHED_SERVERS};
116
117
    $ENV{DEBUG}
118
      && carp "Memcached server settings: "
119
      . join( ', ', @servers )
120
      . " with "
121
      . $self->{'namespace'};
122
    $self->{'memcached_cache'} = Cache::Memcached::Fast->new(
123
        {
124
            servers            => \@servers,
125
            compress_threshold => 10_000,
126
            namespace          => $self->{'namespace'},
127
        }
128
    );
129
    return $self;
84
}
130
}
85
131
132
sub _initialize_fastmmap {
133
    my ($self) = @_;
134
135
    $self->{'fastmmap_cache'} = Cache::FastMmap->new(
136
        'share_file'  => "/tmp/sharefile-koha-$self->{'namespace'}",
137
        'expire_time' => $self->{'timeout'},
138
        'unlink_on_exit' => 0,
139
    );
140
    return $self;
141
}
142
143
sub _initialize_memory {
144
    my ($self) = @_;
145
146
    $self->{'memory_cache'} = Cache::Memory->new(
147
        'namespace'       => $self->{'namespace'},
148
        'default_expires' => $self->{'timeout'}
149
    );
150
    return $self;
151
}
152
153
=head2 is_cache_active
154
155
Routine that checks whether or not a caching system has been selected. This is
156
not an instance method.
157
158
=cut
159
86
sub is_cache_active {
160
sub is_cache_active {
87
    return $ENV{CACHING_SYSTEM} ? '1' : '';
161
    return $ENV{CACHING_SYSTEM} ? '1' : '';
88
}
162
}
89
163
164
=head2 set_in_cache
165
166
    $cache->set_in_cache($key, $value, [$expiry]);
167
168
Save a value to the specified key in the default cache, optionally with a
169
particular expiry.
170
171
=cut
172
90
sub set_in_cache {
173
sub set_in_cache {
91
    my ( $self, $key, $value, $expiry ) = @_;
174
    my ( $self, $key, $value, $expiry, $cache ) = @_;
175
    $cache ||= 'cache';
92
    croak "No key" unless $key;
176
    croak "No key" unless $key;
93
    $ENV{DEBUG} && warn "set_in_cache for $key";
177
    $ENV{DEBUG} && carp "set_in_cache for $key";
94
95
    return unless $self->{cache};
96
    return unless $self->{have_chi};
97
178
179
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
98
    if ( defined $expiry ) {
180
    if ( defined $expiry ) {
99
        return $self->{cache}->set( $key, $value, $expiry );
181
        if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {
182
            $expiry = "$expiry sec";
183
        }
184
        return $self->{$cache}->set( $key, $value, $expiry );
100
    }
185
    }
101
    else {
186
    else {
102
        return $self->{cache}->set( $key, $value );
187
        return $self->{$cache}->set( $key, $value );
103
    }
188
    }
104
}
189
}
105
190
191
=head2 get_from_cache
192
193
    my $value = $cache->get_from_cache($key);
194
195
Retrieve the value stored under the specified key in the default cache.
196
197
=cut
198
106
sub get_from_cache {
199
sub get_from_cache {
107
    my ( $self, $key ) = @_;
200
    my ( $self, $key, $cache ) = @_;
201
    $cache ||= 'cache';
108
    croak "No key" unless $key;
202
    croak "No key" unless $key;
109
    $ENV{DEBUG} && warn "get_from_cache for $key";
203
    $ENV{DEBUG} && carp "get_from_cache for $key";
110
    return unless $self->{cache};
204
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
111
    return unless $self->{have_chi};
205
    return $self->{$cache}->get($key);
112
    return $self->{cache}->get($key);
113
}
206
}
114
207
208
=head2 clear_from_cache
209
210
    $cache->clear_from_cache($key);
211
212
Remove the value identified by the specified key from the default cache.
213
214
=cut
215
115
sub clear_from_cache {
216
sub clear_from_cache {
116
    my ( $self, $key ) = @_;
217
    my ( $self, $key, $cache ) = @_;
218
    $cache ||= 'cache';
117
    croak "No key" unless $key;
219
    croak "No key" unless $key;
118
    return unless $self->{cache};
220
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
119
    return unless $self->{have_chi};
221
    return $self->{$cache}->delete($key)
120
    return $self->{cache}->remove($key);
222
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
223
    return $self->{$cache}->remove($key);
121
}
224
}
122
225
226
=head2 flush_all
227
228
    $cache->flush_all();
229
230
Clear the entire default cache.
231
232
=cut
233
123
sub flush_all {
234
sub flush_all {
124
    my $self = shift;
235
    my ( $self, $cache ) = shift;
125
    return unless $self->{cache};
236
    $cache ||= 'cache';
126
    return unless $self->{have_chi};
237
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
127
    return $self->{cache}->clear();
238
    return $self->{$cache}->flush_all()
239
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
240
    return $self->{$cache}->clear();
241
}
242
243
=head1 TIED INTERFACE
244
245
Koha::Cache also provides a tied interface which enables users to provide a
246
constructor closure and (after creation) treat cached data like normal reference
247
variables and rely on the cache Just Working and getting updated when it
248
expires, etc.
249
250
    my $cache = Koha::Cache->new();
251
    my $data = 'whatever';
252
    my $scalar = Koha::Cache->create_scalar(
253
        {
254
            'key'         => 'whatever',
255
            'timeout'     => 2,
256
            'constructor' => sub { return $data; },
257
        }
258
    );
259
    print "$$scalar\n"; # Prints "whatever"
260
    $data = 'somethingelse';
261
    print "$$scalar\n"; # Prints "whatever" because it is cached
262
    sleep 2; # Wait until the cache entry has expired
263
    print "$$scalar\n"; # Prints "somethingelse"
264
265
    my $hash = Koha::Cache->create_hash(
266
        {
267
            'key'         => 'whatever',
268
            'timeout'     => 2,
269
            'constructor' => sub { return $data; },
270
        }
271
    );
272
    print "$$variable\n"; # Prints "whatever"
273
274
The gotcha with this interface, of course, is that the variable returned by
275
create_scalar and create_hash is a I<reference> to a tied variable and not a
276
tied variable itself.
277
278
The tied variable is configured by means of a hashref passed in to the
279
create_scalar and create_hash methods. The following parameters are supported:
280
281
=over
282
283
=item I<key>
284
285
Required. The key to use for identifying the variable in the cache.
286
287
=item I<constructor>
288
289
Required. A closure (or reference to a function) that will return the value that
290
needs to be stored in the cache.
291
292
=item I<preload>
293
294
Optional. A closure (or reference to a function) that gets run to initialize
295
the cache when creating the tied variable.
296
297
=item I<arguments>
298
299
Optional. Array reference with the arguments that should be passed to the
300
constructor function.
301
302
=item I<timeout>
303
304
Optional. The cache timeout in seconds for the variable. Defaults to 600
305
(ten minutes).
306
307
=item I<cache_type>
308
309
Optional. Which type of cache to use for the variable. Defaults to whatever is
310
set in the environment variable CACHING_SYSTEM. If set to 'null', disables
311
caching for the tied variable.
312
313
=item I<allowupdate>
314
315
Optional. Boolean flag to allow the variable to be updated directly. When this
316
is set and the variable is used as an l-value, the cache will be updated
317
immediately with the new value. Using this is probably a bad idea on a
318
multi-threaded system. When I<allowupdate> is not set to true, using the
319
tied variable as an l-value will have no effect.
320
321
=item I<destructor>
322
323
Optional. A closure (or reference to a function) that should be called when the
324
tied variable is destroyed.
325
326
=item I<unset>
327
328
Optional. Boolean flag to tell the object to remove the variable from the cache
329
when it is destroyed or goes out of scope.
330
331
=item I<inprocess>
332
333
Optional. Boolean flag to tell the object not to refresh the variable from the
334
cache every time the value is desired, but rather only when the I<local> copy
335
of the variable is older than the timeout.
336
337
=back
338
339
=head2 create_scalar
340
341
    my $scalar = Koha::Cache->create_scalar(\%params);
342
343
Create scalar tied to the cache.
344
345
=cut
346
347
sub create_scalar {
348
    my ( $self, $args ) = @_;
349
350
    $self->_set_tied_defaults($args);
351
352
    tie my $scalar, 'Koha::Cache::Object', $args;
353
    return \$scalar;
354
}
355
356
sub create_hash {
357
    my ( $self, $args ) = @_;
358
359
    $self->_set_tied_defaults($args);
360
361
    tie my %hash, 'Koha::Cache::Object', $args;
362
    return \%hash;
363
}
364
365
sub _set_tied_defaults {
366
    my ( $self, $args ) = @_;
367
368
    $args->{'timeout'}   = '600' unless defined( $args->{'timeout'} );
369
    $args->{'inprocess'} = '0'   unless defined( $args->{'inprocess'} );
370
    unless ( lc( $args->{'cache_type'} ) eq 'null' ) {
371
        $args->{'cache'} = $self;
372
        $args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'};
373
    }
374
375
    return $args;
128
}
376
}
129
377
130
=head2 EXPORT
378
=head1 EXPORT
131
379
132
None by default.
380
None by default.
133
381
134
=head1 SEE ALSO
382
=head1 SEE ALSO
135
383
136
Koha::Cache::Memcached
384
Koha::Cache::Object
137
385
138
=head1 AUTHOR
386
=head1 AUTHOR
139
387
(-)a/Koha/Cache/Fastmmap.pm (-49 lines)
Lines 1-49 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 Module::Load::Conditional qw(can_load);
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    if ( can_load( modules => { CHI => undef } ) ) {
31
        return CHI->new(
32
            driver     => 'FastMmap',
33
            namespace  => $params->{'namespace'} || 'koha',
34
            expire_in  => 600,
35
            cache_size => $params->{'cachesize'} || '1m',
36
        );
37
    } else {
38
        return;
39
    }
40
}
41
42
1;
43
__END__
44
45
=head1 NAME
46
47
Koha::Cache::Fastmmap - persistent interprocess mmap-based cache for Koha
48
49
=cut
(-)a/Koha/Cache/Memcached.pm (-124 lines)
Lines 1-124 Link Here
1
package Koha::Cache::Memcached;
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 Cache::Memcached::Fast;
24
use Module::Load::Conditional qw(can_load);
25
26
use base qw(Koha::Cache);
27
28
sub _cache_handle {
29
    my $class   = shift;
30
    my $params  = shift;
31
    my @servers = split /,/,
32
      $params->{'cache_servers'}
33
      ? $params->{'cache_servers'}
34
      : $ENV{MEMCACHED_SERVERS};
35
    my $namespace =
36
         $ENV{MEMCACHED_NAMESPACE}
37
      || $params->{'namespace'}
38
      || 'koha';
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
    }
72
}
73
74
sub set_in_cache {
75
    my ( $self, $key, $value, $expiry ) = @_;
76
    return $self->SUPER::set_in_cache( $key, $value, $expiry )
77
      if ( $self->{have_chi} );
78
79
    # No CHI, we have to use Cache::Memcached::Fast directly
80
    if ( defined $expiry ) {
81
        return $self->cache->set( $key, $value, $expiry );
82
    }
83
    else {
84
        return $self->cache->set( $key, $value );
85
    }
86
}
87
88
sub get_from_cache {
89
    my ( $self, $key ) = @_;
90
    return $self->SUPER::get_from_cache($key) if ( $self->{have_chi} );
91
92
    # No CHI, we have to use Cache::Memcached::Fast directly
93
    return $self->cache->get($key);
94
}
95
96
sub clear_from_cache {
97
    my ( $self, $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
101
    return $self->cache->delete($key);
102
}
103
104
# We have to overload flush_all because CHI::Driver::Memcached::Fast does not
105
# support the clear() method
106
sub flush_all {
107
    my $self = shift;
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
    }
115
}
116
117
1;
118
__END__
119
120
=head1 NAME
121
122
Koha::Cache::Memcached - memcached subclass of Koha::Cache
123
124
=cut
(-)a/Koha/Cache/Memory.pm (-50 lines)
Lines 1-50 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 Module::Load::Conditional qw(can_load);
24
25
use base qw(Koha::Cache);
26
27
sub _cache_handle {
28
    my $class  = shift;
29
    my $params = shift;
30
    if ( can_load( modules => { CHI => undef } ) ) {
31
        return CHI->new(
32
            driver    => 'Memory',
33
            namespace => $params->{'namespace'} || 'koha',
34
            expire_in => 600,
35
            max_size  => $params->{'max_size'} || 8192 * 1024,
36
            global    => 1,
37
        );
38
    } else {
39
        return;
40
    }
41
}
42
43
1;
44
__END__
45
46
=head1 NAME
47
48
Koha::Cache::Memory - in-process memory based cache for Koha
49
50
=cut
(-)a/Koha/Cache/Null.pm (-41 lines)
Lines 1-41 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/Koha/Cache/Object.pm (+220 lines)
Line 0 Link Here
1
package Koha::Cache::Object;
2
3
# Copyright 2013 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 3 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
=head1 NAME
21
22
Koha::Cache::Object - Tie-able class for caching objects
23
24
=head1 SYNOPSIS
25
26
    my $cache = Koha::Cache->new();
27
    my $scalar = Koha::Cache->create_scalar(
28
        {
29
            'key'         => 'whatever',
30
            'timeout'     => 2,
31
            'constructor' => sub { return 'stuff'; },
32
        }
33
    );
34
    my %hash = Koha::Cache->create_hash(
35
        {
36
            'key'         => 'whateverelse',
37
            'timeout'     => 2,
38
            'constructor' => sub { return { 'stuff' => 'nonsense' }; },
39
        }
40
    );
41
42
=head1 DESCRIPTION
43
44
Do not use this class directly. It is tied to variables by Koha::Cache
45
for transparent cache access. If you choose to ignore this warning, you
46
should be aware that it is disturbingly polymorphic and supports both
47
scalars and hashes, with arrays a potential future addition.
48
49
=head1 TIE METHODS
50
51
=cut
52
53
use strict;
54
use warnings;
55
use Carp;
56
57
use base qw(Class::Accessor);
58
59
__PACKAGE__->mk_ro_accessors(
60
    qw( allowupdate arguments cache cache_type constructor destructor inprocess key lastupdate timeout unset value )
61
);
62
63
# General/SCALAR routines
64
65
sub TIESCALAR {
66
    my ( $class, $self ) = @_;
67
68
    $self->{'datatype'}  ||= 'SCALAR';
69
    $self->{'arguments'} ||= [];
70
    if ( defined $self->{'preload'} ) {
71
        $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
72
        if ( defined( $self->{'cache'} ) ) {
73
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
74
                $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
75
        }
76
        $self->{'lastupdate'} = time;
77
    }
78
    return bless $self, $class;
79
}
80
81
sub FETCH {
82
    my ( $self, $index ) = @_;
83
84
    $ENV{DEBUG}
85
      && $index
86
      && carp "Retrieving cached hash member $index of $self->{'key'}";
87
88
    my $now = time;
89
90
    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
91
        && $self->{'cache'} )
92
    {
93
        $self->{'value'} =
94
          $self->{'cache'}
95
          ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
96
        $self->{'lastupdate'} = $now;
97
    }
98
99
    if (   !defined $self->{'value'}
100
        || ( defined $index && !exists $self->{'value'}->{$index} )
101
        || !defined $self->{'lastupdate'}
102
        || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) )
103
    {
104
        $self->{'value'} =
105
          &{ $self->{'constructor'} }( @{ $self->{'arguments'} },
106
            $self->{'value'}, $index );
107
        if ( defined( $self->{'cache'} ) ) {
108
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
109
                $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
110
        }
111
        $self->{'lastupdate'} = $now;
112
    }
113
    if ( $self->{'datatype'} eq 'HASH' && defined $index ) {
114
        return $self->{'value'}->{$index};
115
    }
116
    return $self->{'value'};
117
}
118
119
sub STORE {
120
    my $value = pop @_;
121
    my ( $self, $index ) = @_;
122
123
    if ( $self->{'datatype'} eq 'HASH' && defined($index) ) {
124
        $self->{'value'}->{$index} = $value;
125
    }
126
    else {
127
        $self->{'value'} = $value;
128
    }
129
    if (   defined( $self->{'allowupdate'} )
130
        && $self->{'allowupdate'}
131
        && defined( $self->{'cache'} ) )
132
    {
133
        $self->{'cache'}
134
          ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'},
135
            $self->{'cache_type'} . '_cache' );
136
    }
137
138
    return $self->{'value'};
139
}
140
141
sub DESTROY {
142
    my ($self) = @_;
143
144
    if ( defined( $self->{'destructor'} ) ) {
145
        &{ $self->{'destructor'} }( @{ $self->{'arguments'} } );
146
    }
147
148
    if (   defined( $self->{'unset'} )
149
        && $self->{'unset'}
150
        && defined( $self->{'cache'} ) )
151
    {
152
        $self->{'cache'}->clear_from_cache( $self->{'key'},
153
            $self->{'cache_type'} . '_cache' );
154
    }
155
156
    undef $self->{'value'};
157
158
    return $self;
159
}
160
161
# HASH-specific routines
162
163
sub TIEHASH {
164
    my ( $class, $self, @args ) = @_;
165
    $self->{'datatype'} = 'HASH';
166
    return TIESCALAR( $class, $self, @args );
167
}
168
169
sub DELETE {
170
    my ( $self, $index ) = @_;
171
    delete $self->{'value'}->{$index};
172
    return $self->STORE( $self->{'value'} );
173
}
174
175
sub EXISTS {
176
    my ( $self, $index ) = @_;
177
    $self->FETCH($index);
178
    return exists $self->{'value'}->{$index};
179
}
180
181
sub FIRSTKEY {
182
    my ($self) = @_;
183
    $self->FETCH;
184
    $self->{'iterator'} = [ keys %{ $self->{'value'} } ];
185
    return $self->NEXTKEY;
186
}
187
188
sub NEXTKEY {
189
    my ($self) = @_;
190
    return shift @{ $self->{'iterator'} };
191
}
192
193
sub SCALAR {
194
    my ($self) = @_;
195
    $self->FETCH;
196
    return scalar %{ $self->{'value'} }
197
      if ( ref( $self->{'value'} ) eq 'HASH' );
198
    return;
199
}
200
201
sub CLEAR {
202
    my ($self) = @_;
203
    return $self->DESTROY;
204
}
205
206
# ARRAY-specific routines
207
208
=head1 SEE ALSO
209
210
Koha::Cache, tie, perltie
211
212
=head1 AUTHOR
213
214
Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
215
216
=cut
217
218
1;
219
220
__END__
(-)a/t/00-load.t (-1 lines)
Lines 42-48 find( Link Here
42
            $m =~ s{^.*/Koha/}{Koha/};
42
            $m =~ s{^.*/Koha/}{Koha/};
43
            $m =~ s{/}{::}g;
43
            $m =~ s{/}{::}g;
44
            return if $m =~ /Koha::SearchEngine/; # Koha::SearchEngine::* are experimental
44
            return if $m =~ /Koha::SearchEngine/; # Koha::SearchEngine::* are experimental
45
            return if $m =~ /Koha::Cache::Memcached/; # optional dependency
46
            use_ok($m) || BAIL_OUT("***** PROBLEMS LOADING FILE '$m'");
45
            use_ok($m) || BAIL_OUT("***** PROBLEMS LOADING FILE '$m'");
47
        },
46
        },
48
    },
47
    },
(-)a/t/Cache.t (-17 / +119 lines)
Lines 5-43 Link Here
5
use strict;
5
use strict;
6
use warnings;
6
use warnings;
7
7
8
use Test::More tests => 9;
8
use Test::More tests => 29;
9
10
my $destructorcount = 0;
9
11
10
BEGIN {
12
BEGIN {
11
        use_ok('Koha::Cache');
13
    use_ok('Koha::Cache');
12
        use_ok('C4::Context');
14
    use_ok('Koha::Cache::Object');
15
    use_ok('C4::Context');
13
}
16
}
14
17
15
SKIP: {
18
SKIP: {
16
    my $cache = Koha::Cache->new ();
19
    my $cache = Koha::Cache->new();
17
20
18
    skip "Cache not enabled", 7 unless (Koha::Cache->is_cache_active() && defined $cache);
21
    skip "Cache not enabled", 13
22
      unless ( Koha::Cache->is_cache_active() && defined $cache );
19
23
20
    # test fetching an item that isnt in the cache
24
    # test fetching an item that isnt in the cache
21
    is( $cache->get_from_cache("not in here"), undef, "fetching item NOT in cache");
25
    is( $cache->get_from_cache("not in here"),
26
        undef, "fetching item NOT in cache" );
22
27
23
    # test expiry time in cache
28
    # test expiry time in cache
24
    $cache->set_in_cache("timeout", "I AM DATA", 1); # expiry time of 1 second
29
    $cache->set_in_cache( "timeout", "I AM DATA", 1 ); # expiry time of 1 second
25
    sleep 1;
30
    sleep 2;
26
    is( $cache->get_from_cache("timeout"), undef, "fetching expired item from cache");
31
    is( $cache->get_from_cache("timeout"),
32
        undef, "fetching expired item from cache" );
27
33
28
    # test fetching a valid, non expired, item from cache
34
    # test fetching a valid, non expired, item from cache
29
    $cache->set_in_cache("clear_me", "I AM MORE DATA", 1000); # overly large expiry time, clear below
35
    $cache->set_in_cache( "clear_me", "I AM MORE DATA", 1000 )
30
    $cache->set_in_cache("dont_clear_me", "I AM MORE DATA22", 1000); # overly large expiry time, clear below
36
      ;    # overly large expiry time, clear below
31
    is( $cache->get_from_cache("clear_me"), "I AM MORE DATA", "fetching valid item from cache");
37
    $cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22", 1000 )
38
      ;    # overly large expiry time, clear below
39
    is(
40
        $cache->get_from_cache("clear_me"),
41
        "I AM MORE DATA",
42
        "fetching valid item from cache"
43
    );
32
44
33
    # test clearing from cache
45
    # test clearing from cache
34
    $cache->clear_from_cache("clear_me");
46
    $cache->clear_from_cache("clear_me");
35
    is( $cache->get_from_cache("clear_me"), undef, "fetching cleared item from cache");
47
    is( $cache->get_from_cache("clear_me"),
36
    is( $cache->get_from_cache("dont_clear_me"), "I AM MORE DATA22", "fetching valid item from cache (after clearing another item)");
48
        undef, "fetching cleared item from cache" );
49
    is(
50
        $cache->get_from_cache("dont_clear_me"),
51
        "I AM MORE DATA22",
52
        "fetching valid item from cache (after clearing another item)"
53
    );
37
54
38
    #test flushing from cache
55
    #test flushing from cache
39
    $cache->set_in_cache("flush_me", "testing 1 data");
56
    $cache->set_in_cache( "flush_me", "testing 1 data" );
40
    $cache->flush_all;
57
    $cache->flush_all;
41
    is( $cache->get_from_cache("flush_me"), undef, "fetching flushed item from cache");
58
    is( $cache->get_from_cache("flush_me"),
42
    is( $cache->get_from_cache("dont_clear_me"), undef, "fetching flushed item from cache");
59
        undef, "fetching flushed item from cache" );
60
    is( $cache->get_from_cache("dont_clear_me"),
61
        undef, "fetching flushed item from cache" );
62
63
    my $constructorcount = 0;
64
    my $myscalar         = $cache->create_scalar(
65
        {
66
            'key'         => 'myscalar',
67
            'timeout'     => 1,
68
            'allowupdate' => 1,
69
            'unset'       => 1,
70
            'constructor' => sub { return ++$constructorcount; },
71
            'destructor'  => sub { return ++$destructorcount; },
72
        }
73
    );
74
    ok( defined($myscalar), 'Created tied scalar' );
75
    is( $$myscalar, 1, 'Constructor called to first initialize' );
76
    is( $$myscalar, 1, 'Data retrieved from cache' );
77
    sleep 2;
78
    is( $$myscalar, 2, 'Constructor called again when timeout reached' );
79
    $$myscalar = 5;
80
    is( $$myscalar,        5, 'Stored new value to cache' );
81
    is( $constructorcount, 2, 'Constructor not called after storing value' );
82
    undef $myscalar;
83
84
    is( $cache->get_from_cache("myscalar"),
85
        undef, 'Item removed from cache on destruction' );
86
87
    my %hash = ( 'key' => 'value' );
88
89
    my $myhash         = $cache->create_hash(
90
        {
91
            'key'         => 'myhash',
92
            'timeout'     => 1,
93
            'allowupdate' => 1,
94
            'unset'       => 1,
95
            'constructor' => sub { return { %hash }; },
96
        }
97
    );
98
99
    ok(defined $myhash, 'Created tied hash');
100
101
    is($myhash->{'key'}, 'value', 'Found expected value in hash');
102
    ok(exists $myhash->{'key'}, 'Exists works');
103
    $myhash->{'key2'} = 'surprise';
104
    is($myhash->{'key2'}, 'surprise', 'Setting hash member worked');
105
    $hash{'key2'} = 'nosurprise';
106
    sleep 2;
107
    is($myhash->{'key2'}, 'nosurprise', 'Cache change caught');
108
109
110
    my $foundkeys = 0;
111
    foreach my $key (keys %{$myhash}) {
112
        $foundkeys++;
113
    }
114
115
    is($foundkeys, 2, 'Found expected 2 keys when iterating through hash');
116
117
    isnt(scalar %{$myhash}, undef, 'scalar knows the hash is not empty');
118
119
    $hash{'anotherkey'} = 'anothervalue';
120
121
    sleep 2;
122
123
    ok(exists $myhash->{'anotherkey'}, 'Cache reset properly');
124
125
    delete $hash{'anotherkey'};
126
    delete $myhash->{'anotherkey'};
127
128
    ok(!exists $myhash->{'anotherkey'}, 'Key successfully deleted');
129
130
    undef %hash;
131
    %{$myhash} = ();
132
133
    is(scalar %{$myhash}, 0, 'hash cleared');
134
135
    $hash{'key'} = 'value';
136
    is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
137
}
138
139
END {
140
  SKIP: {
141
        skip "Cache not enabled", 1
142
          unless ( Koha::Cache->is_cache_active() );
143
        is( $destructorcount, 1, 'Destructor run exactly once' );
144
    }
43
}
145
}
(-)a/t/optional/Cache_Memcached.t (-15 lines)
Lines 1-14 Link Here
1
#!/usr/bin/perl
2
#
3
# This Koha test module is a stub!  
4
# Add more tests here!!!
5
6
use strict;
7
use warnings;
8
9
use Test::More tests => 1;
10
11
BEGIN {
12
        use_ok('Koha::Cache::Memcached');
13
}
14
15
- 

Return to bug 9434