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

(-)a/C4/External/OverDrive.pm (-2 / +4 lines)
Lines 99-105 sub GetOverDriveToken { Link Here
99
99
100
    my $cache;
100
    my $cache;
101
101
102
    eval { $cache = Koha::Cache->new() };
102
    eval { $cache = Koha::Cache->get_instance() };
103
103
104
    my $token;
104
    my $token;
105
    $cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;
105
    $cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;
Lines 124-130 sub GetOverDriveToken { Link Here
124
    $token = $contents->{'token_type'} . ' ' . $contents->{'access_token'};
124
    $token = $contents->{'token_type'} . ' ' . $contents->{'access_token'};
125
125
126
    # Fudge factor to prevent spurious failures
126
    # Fudge factor to prevent spurious failures
127
    $cache and $cache->set_in_cache( 'overdrive_token', $token, $contents->{'expires_in'} - 5 );
127
    $cache
128
      and $cache->set_in_cache( 'overdrive_token', $token,
129
        { expiry => $contents->{'expires_in'} - 5 } );
128
130
129
    return $token;
131
    return $token;
130
}
132
}
(-)a/Koha/Cache.pm (-31 / +117 lines)
Lines 30-41 Koha::Cache - Handling caching of html and Objects for Koha Link Here
30
=head1 DESCRIPTION
30
=head1 DESCRIPTION
31
31
32
Koha caching routines. This class provides two interfaces for cache access.
32
Koha caching routines. This class provides two interfaces for cache access.
33
The first, traditional interface provides the following functions:
33
The first, traditional OO interface provides the following functions:
34
34
35
=head1 FUNCTIONS
35
=head1 FUNCTIONS
36
36
37
=cut
37
=cut
38
39
use strict;
38
use strict;
40
use warnings;
39
use warnings;
41
use Carp;
40
use Carp;
Lines 47-52 use base qw(Class::Accessor); Link Here
47
__PACKAGE__->mk_ro_accessors(
46
__PACKAGE__->mk_ro_accessors(
48
    qw( cache memcached_cache fastmmap_cache memory_cache ));
47
    qw( cache memcached_cache fastmmap_cache memory_cache ));
49
48
49
=head2 get_instance
50
51
    my $cache = Koha::Cache->get_instance();
52
53
This gets a shared instance of the cache, set up in a very default way. This is
54
the recommended way to fetch a cache object. If possible, it'll be
55
persistent across multiple instances.
56
57
=cut
58
59
our $singleton_cache;
60
sub get_instance {
61
    my ($class) = @_;
62
    $singleton_cache = $class->new() unless $singleton_cache;
63
    return $singleton_cache;
64
}
65
50
=head2 new
66
=head2 new
51
67
52
Create a new Koha::Cache object. This is required for all cache-related functionality.
68
Create a new Koha::Cache object. This is required for all cache-related functionality.
Lines 92-106 sub new { Link Here
92
        }
108
        }
93
    }
109
    }
94
110
95
# NOTE: The following five lines could be uncommented if we wanted to
111
    # Unless a default has already been picked, we go through in best-to-
96
#       fall back to any functioning cache. Commented out since this would
112
    # least-best order, looking for something we can use. fastmmap_cache
97
#       represent a change in behavior.
113
    # is excluded because it doesn't support expiry in a useful way.
98
#
114
    unless ( defined( $self->{'cache'} ) ) {
99
#unless (defined($self->{'cache'})) {
115
        foreach my $cachemember (qw(memcached_cache memory_cache )) {
100
#    foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) {
116
            if ( defined( $self->{$cachemember} ) ) {
101
#        $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember}));
117
                $self->{'cache'} = $self->{$cachemember};
102
#    }
118
                last;
103
#}
119
            }
120
        }
121
    }
122
123
    $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
104
124
105
    return
125
    return
106
      bless $self,
126
      bless $self,
Lines 119-131 sub _initialize_memcached { Link Here
119
      . join( ', ', @servers )
139
      . join( ', ', @servers )
120
      . " with "
140
      . " with "
121
      . $self->{'namespace'};
141
      . $self->{'namespace'};
122
    $self->{'memcached_cache'} = Cache::Memcached::Fast->new(
142
    # Cache::Memcached::Fast doesn't allow a default expire time to be set
143
    # so we force it on setting.
144
    my $memcached = Cache::Memcached::Fast->new(
123
        {
145
        {
124
            servers            => \@servers,
146
            servers            => \@servers,
125
            compress_threshold => 10_000,
147
            compress_threshold => 10_000,
126
            namespace          => $self->{'namespace'},
148
            namespace          => $self->{'namespace'},
149
            debug              => 0,
150
            utf8               => 1,
127
        }
151
        }
128
    );
152
    );
153
    # Ensure we can actually talk to the memcached server
154
    my $ismemcached = $memcached->set('ismemcached','1');
155
    return $self unless $ismemcached;
156
    $self->{'memcached_cache'} = $memcached;
129
    return $self;
157
    return $self;
130
}
158
}
131
159
Lines 143-190 sub _initialize_fastmmap { Link Here
143
sub _initialize_memory {
171
sub _initialize_memory {
144
    my ($self) = @_;
172
    my ($self) = @_;
145
173
146
    $self->{'memory_cache'} = Cache::Memory->new(
174
    # Default cache time for memory is _always_ short unless it's specially
175
    # defined, to allow it to work reliably in a persistent environment.
176
    my $cache = Cache::Memory->new(
147
        'namespace'       => $self->{'namespace'},
177
        'namespace'       => $self->{'namespace'},
148
        'default_expires' => $self->{'timeout'}
178
        'default_expires' => "$self->{'timeout'} sec" || "10 sec",
149
    );
179
    );
180
    $self->{'memory_cache'} = $cache;
181
    # Memory cache can't handle complex types for some reason, so we use its
182
    # freeze and thaw functions.
183
    $self->{ref($cache) . '_set'} = sub {
184
        my ($key, $val, $exp) = @_;
185
        # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
186
        $exp = "$exp sec" if defined $exp;
187
        # Because we need to use freeze, it must be a reference type.
188
        $cache->freeze($key, [$val], $exp);
189
    };
190
    $self->{ref($cache) . '_get'} = sub {
191
        my $res = $cache->thaw(shift);
192
        return unless defined $res;
193
        return $res->[0];
194
    };
150
    return $self;
195
    return $self;
151
}
196
}
152
197
153
=head2 is_cache_active
198
=head2 is_cache_active
154
199
155
Routine that checks whether or not a caching system has been selected. This is
200
Routine that checks whether or not a default caching method is active on this
156
not an instance method.
201
object.
157
202
158
=cut
203
=cut
159
204
160
sub is_cache_active {
205
sub is_cache_active {
161
    return $ENV{CACHING_SYSTEM} ? '1' : '';
206
    my $self = shift;
207
    return $self->{'cache'} ? 1 : 0;
162
}
208
}
163
209
164
=head2 set_in_cache
210
=head2 set_in_cache
165
211
166
    $cache->set_in_cache($key, $value, [$expiry]);
212
    $cache->set_in_cache($key, $value, [$options]);
213
214
Save a value to the specified key in the cache. A hashref of options may be
215
specified.
167
216
168
Save a value to the specified key in the default cache, optionally with a
217
The possible options are:
169
particular expiry.
218
219
=over
220
221
=item expiry
222
223
Expiry time of this cached entry in seconds.
224
225
=item deepcopy
226
227
If set, this will perform a deep copy of the item when it's retrieved. This
228
means that it'll be safe if something later modifies the result of the
229
function. Will be ignored in situations where the same behaviour comes from
230
the caching layer anyway.
231
232
=item cache
233
234
The cache object to use if you want to provide your own. It should be an
235
instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
170
236
171
=cut
237
=cut
172
238
173
sub set_in_cache {
239
sub set_in_cache {
174
    my ( $self, $key, $value, $expiry, $cache ) = @_;
240
    my ( $self, $key, $value, $options, $_cache) = @_;
175
    $cache ||= 'cache';
241
    # This is a bit of a hack to support the old API in case things still use it
242
    if (defined $options && (ref($options) ne 'HASH')) {
243
        my $new_options;
244
        $new_options->{expiry} = $options;
245
        $new_options->{cache} = $_cache if defined $_cache;
246
        $options = $new_options;
247
    }
248
249
    # the key mustn't contain whitespace (or control characters) for memcache
250
    # but shouldn't be any harm in applying it globally.
251
    $key =~ s/[\x00-\x20]/_/g;
252
253
    my $cache = $options->{cache} || 'cache';
176
    croak "No key" unless $key;
254
    croak "No key" unless $key;
177
    $ENV{DEBUG} && carp "set_in_cache for $key";
255
    $ENV{DEBUG} && carp "set_in_cache for $key";
178
256
179
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
257
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
180
    if ( defined $expiry ) {
258
    my $expiry = $options->{expiry};
181
        if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {
259
    $expiry //= $self->{timeout};
182
            $expiry = "$expiry sec";
260
    my $set_sub = $self->{ref($self->{$cache}) . "_set"};
183
        }
261
    # We consider an expiry of 0 to be inifinite
184
        return $self->{$cache}->set( $key, $value, $expiry );
262
    if ( $expiry ) {
263
        return $set_sub
264
          ? $set_sub->( $key, $value, $expiry )
265
          : $self->{$cache}->set( $key, $value, $expiry );
185
    }
266
    }
186
    else {
267
    else {
187
        return $self->{$cache}->set( $key, $value );
268
        return $set_sub
269
          ? $set_sub->( $key, $value )
270
          : $self->{$cache}->set( $key, $value );
188
    }
271
    }
189
}
272
}
190
273
Lines 198-208 Retrieve the value stored under the specified key in the default cache. Link Here
198
281
199
sub get_from_cache {
282
sub get_from_cache {
200
    my ( $self, $key, $cache ) = @_;
283
    my ( $self, $key, $cache ) = @_;
284
    $key =~ s/[\x00-\x20]/_/g;
201
    $cache ||= 'cache';
285
    $cache ||= 'cache';
202
    croak "No key" unless $key;
286
    croak "No key" unless $key;
203
    $ENV{DEBUG} && carp "get_from_cache for $key";
287
    $ENV{DEBUG} && carp "get_from_cache for $key";
204
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
288
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
205
    return $self->{$cache}->get($key);
289
    my $get_sub = $self->{ref($self->{$cache}) . "_get"};
290
    return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
206
}
291
}
207
292
208
=head2 clear_from_cache
293
=head2 clear_from_cache
Lines 215-225 Remove the value identified by the specified key from the default cache. Link Here
215
300
216
sub clear_from_cache {
301
sub clear_from_cache {
217
    my ( $self, $key, $cache ) = @_;
302
    my ( $self, $key, $cache ) = @_;
303
    $key =~ s/[\x00-\x20]/_/g;
218
    $cache ||= 'cache';
304
    $cache ||= 'cache';
219
    croak "No key" unless $key;
305
    croak "No key" unless $key;
220
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
306
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
221
    return $self->{$cache}->delete($key)
307
    return $self->{$cache}->delete($key)
222
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
308
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
223
    return $self->{$cache}->remove($key);
309
    return $self->{$cache}->remove($key);
224
}
310
}
225
311
Lines 236-242 sub flush_all { Link Here
236
    $cache ||= 'cache';
322
    $cache ||= 'cache';
237
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
323
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
238
    return $self->{$cache}->flush_all()
324
    return $self->{$cache}->flush_all()
239
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
325
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
240
    return $self->{$cache}->clear();
326
    return $self->{$cache}->clear();
241
}
327
}
242
328
(-)a/Koha/Cache/Object.pm (-10 / +7 lines)
Lines 71-77 sub TIESCALAR { Link Here
71
        $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
71
        $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
72
        if ( defined( $self->{'cache'} ) ) {
72
        if ( defined( $self->{'cache'} ) ) {
73
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
73
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
74
                $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
74
                { expiry => $self->{'timeout'} } );
75
        }
75
        }
76
        $self->{'lastupdate'} = time;
76
        $self->{'lastupdate'} = time;
77
    }
77
    }
Lines 90-98 sub FETCH { Link Here
90
    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
90
    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
91
        && $self->{'cache'} )
91
        && $self->{'cache'} )
92
    {
92
    {
93
        $self->{'value'} =
93
        $self->{'value'} = $self->{'cache'}->get_from_cache( $self->{'key'} );
94
          $self->{'cache'}
95
          ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
96
        $self->{'lastupdate'} = $now;
94
        $self->{'lastupdate'} = $now;
97
    }
95
    }
98
96
Lines 106-112 sub FETCH { Link Here
106
            $self->{'value'}, $index );
104
            $self->{'value'}, $index );
107
        if ( defined( $self->{'cache'} ) ) {
105
        if ( defined( $self->{'cache'} ) ) {
108
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
106
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
109
                $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
107
                { expiry => $self->{'timeout'} } );
110
        }
108
        }
111
        $self->{'lastupdate'} = $now;
109
        $self->{'lastupdate'} = $now;
112
    }
110
    }
Lines 130-138 sub STORE { Link Here
130
        && $self->{'allowupdate'}
128
        && $self->{'allowupdate'}
131
        && defined( $self->{'cache'} ) )
129
        && defined( $self->{'cache'} ) )
132
    {
130
    {
133
        $self->{'cache'}
131
        $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
134
          ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'},
132
            { expiry => $self->{'timeout'} },
135
            $self->{'cache_type'} . '_cache' );
133
        );
136
    }
134
    }
137
135
138
    return $self->{'value'};
136
    return $self->{'value'};
Lines 149-156 sub DESTROY { Link Here
149
        && $self->{'unset'}
147
        && $self->{'unset'}
150
        && defined( $self->{'cache'} ) )
148
        && defined( $self->{'cache'} ) )
151
    {
149
    {
152
        $self->{'cache'}->clear_from_cache( $self->{'key'},
150
        $self->{'cache'}->clear_from_cache( $self->{'key'} );
153
            $self->{'cache_type'} . '_cache' );
154
    }
151
    }
155
152
156
    undef $self->{'value'};
153
    undef $self->{'value'};
(-)a/Koha/Template/Plugin/Cache.pm (-2 / +3 lines)
Lines 37-43 sub new { Link Here
37
    }
37
    }
38
    else {
38
    else {
39
        require Koha::Cache;
39
        require Koha::Cache;
40
        $cache = Koha::Cache->new( { 'cache_type' => 'memcached', 'cache_servers' => C4::Context->config('memcached_servers') });
40
        $cache = Koha::Cache->get_instance();
41
    }
41
    }
42
    my $self = bless {
42
    my $self = bless {
43
        CACHE   => $cache,
43
        CACHE   => $cache,
Lines 84-90 sub _cached_action { Link Here
84
    my $result = $self->{CACHE}->get_from_cache($key);
84
    my $result = $self->{CACHE}->get_from_cache($key);
85
    if ( !$result ) {
85
    if ( !$result ) {
86
        $result = $self->{CONTEXT}->$action( $params->{template} );
86
        $result = $self->{CONTEXT}->$action( $params->{template} );
87
        $self->{CACHE}->set_in_cache( $key, $result, $params->{ttl} );
87
        $self->{CACHE}
88
          ->set_in_cache( $key, $result, { expiry => $params->{ttl} } );
88
    }
89
    }
89
    return $result;
90
    return $result;
90
}
91
}
(-)a/opac/svc/report (-4 / +5 lines)
Lines 36-46 if (!$report_rec) { die "There is no such report.\n"; } Link Here
36
36
37
die "Sorry this report is not public\n" unless $report_rec->{public};
37
die "Sorry this report is not public\n" unless $report_rec->{public};
38
38
39
my $cache_active = Koha::Cache->is_cache_active;
39
my $cache = Koha::Cache->get_instance();
40
my ($cache_key, $cache, $json_text);
40
my $cache_active = $cache->is_cache_active;
41
my ($cache_key, $json_text);
41
if ($cache_active) {
42
if ($cache_active) {
42
    $cache_key = "opac:report:".($report_name ? "name:$report_name" : "id:$report_id");
43
    $cache_key = "opac:report:".($report_name ? "name:$report_name" : "id:$report_id");
43
    $cache = Koha::Cache->new();
44
    $json_text = $cache->get_from_cache($cache_key);
44
    $json_text = $cache->get_from_cache($cache_key);
45
}
45
}
46
46
Lines 59-65 unless ($json_text) { Link Here
59
        $json_text = to_json($lines);
59
        $json_text = to_json($lines);
60
60
61
        if ($cache_active) {
61
        if ($cache_active) {
62
            $cache->set_in_cache( $cache_key, $json_text, $report_rec->{cache_expiry} );
62
            $cache->set_in_cache( $cache_key, $json_text,
63
                { expiry => $report_rec->{cache_expiry} } );
63
        }
64
        }
64
    }
65
    }
65
    else {
66
    else {
(-)a/svc/report (-3 / +3 lines)
Lines 46-56 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here
46
    }
46
    }
47
);
47
);
48
48
49
my $cache_active = Koha::Cache->is_cache_active;
49
my $cache = Koha::Cache->get_instance();
50
my ($cache_key, $cache, $json_text);
50
my $cache_active = $cache->is_cache_active;
51
my ($cache_key, $json_text);
51
if ($cache_active) {
52
if ($cache_active) {
52
    $cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id");
53
    $cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id");
53
    $cache = Koha::Cache->new();
54
    $json_text = $cache->get_from_cache($cache_key);
54
    $json_text = $cache->get_from_cache($cache_key);
55
}
55
}
56
56
(-)a/t/Cache.t (-6 / +19 lines)
Lines 5-11 Link Here
5
use strict;
5
use strict;
6
use warnings;
6
use warnings;
7
7
8
use Test::More tests => 29;
8
use Test::More tests => 32;
9
9
10
my $destructorcount = 0;
10
my $destructorcount = 0;
11
11
Lines 16-25 BEGIN { Link Here
16
}
16
}
17
17
18
SKIP: {
18
SKIP: {
19
    my $cache = Koha::Cache->new();
19
    my $cache = Koha::Cache->get_instance();
20
20
21
    skip "Cache not enabled", 25
21
    skip "Cache not enabled", 28
22
      unless ( Koha::Cache->is_cache_active() && defined $cache );
22
      unless ( $cache->is_cache_active() && defined $cache );
23
23
24
    # test fetching an item that isnt in the cache
24
    # test fetching an item that isnt in the cache
25
    is( $cache->get_from_cache("not in here"),
25
    is( $cache->get_from_cache("not in here"),
Lines 134-145 SKIP: { Link Here
134
134
135
    $hash{'key'} = 'value';
135
    $hash{'key'} = 'value';
136
    is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
136
    is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
137
138
    # UTF8 testing
139
    my $utf8_str = "A Møøse once bit my sister";
140
    $cache->set_in_cache('utf8_1', $utf8_str);
141
    is($cache->get_from_cache('utf8_1'), $utf8_str, 'Simple 8-bit UTF8 correctly retrieved');
142
    $utf8_str = "\x{20ac}"; # €
143
    $cache->set_in_cache('utf8_1', $utf8_str);
144
    my $utf8_res = $cache->get_from_cache('utf8_1');
145
    # This'll ensure that we're getting a unicode string back, rather than
146
    # a couple of bytes.
147
    is(length($utf8_res), 1, 'UTF8 string length correct');
148
    # ...and that it's really the character we intend
149
    is(ord($utf8_res), 8364, 'UTF8 string value correct');
137
}
150
}
138
151
139
END {
152
END {
140
  SKIP: {
153
  SKIP: {
154
        my $cache = Koha::Cache->get_instance();
141
        skip "Cache not enabled", 1
155
        skip "Cache not enabled", 1
142
          unless ( Koha::Cache->is_cache_active() );
156
          unless ( $cache->is_cache_active() );
143
        is( $destructorcount, 1, 'Destructor run exactly once' );
157
        is( $destructorcount, 1, 'Destructor run exactly once' );
144
    }
158
    }
145
}
159
}
146
- 

Return to bug 12041