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 / +114 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 65-71 sub new { Link Here
65
    $self->{'timeout'}   ||= 0;
81
    $self->{'timeout'}   ||= 0;
66
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
82
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
67
83
68
    if ( can_load( modules => { 'Cache::Memcached::Fast' => undef } ) ) {
84
    if ( can_load( modules => { 'Cache::Memcached' => undef } ) ) {
69
        _initialize_memcached($self);
85
        _initialize_memcached($self);
70
        if ( $self->{'default_type'} eq 'memcached'
86
        if ( $self->{'default_type'} eq 'memcached'
71
            && defined( $self->{'memcached_cache'} ) )
87
            && defined( $self->{'memcached_cache'} ) )
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
    my $memcached = Cache::Memcached->new(
123
        {
144
        {
124
            servers            => \@servers,
145
            servers            => \@servers,
125
            compress_threshold => 10_000,
146
            compress_threshold => 10_000,
126
            namespace          => $self->{'namespace'},
147
            namespace          => $self->{'namespace'},
148
            expire_time        => 600,
149
            debug              => 0,
127
        }
150
        }
128
    );
151
    );
152
    # Ensure we can actually talk to the memcached server
153
    my $ismemcached = $memcached->set('ismemcached','1');
154
    return $self unless $ismemcached;
155
    $self->{'memcached_cache'} = $memcached;
129
    return $self;
156
    return $self;
130
}
157
}
131
158
Lines 143-190 sub _initialize_fastmmap { Link Here
143
sub _initialize_memory {
170
sub _initialize_memory {
144
    my ($self) = @_;
171
    my ($self) = @_;
145
172
146
    $self->{'memory_cache'} = Cache::Memory->new(
173
    # Default cache time for memory is _always_ short unless it's specially
174
    # defined, to allow it to work reliably in a persistent environment.
175
    my $cache = Cache::Memory->new(
147
        'namespace'       => $self->{'namespace'},
176
        'namespace'       => $self->{'namespace'},
148
        'default_expires' => $self->{'timeout'}
177
        'default_expires' => "$self->{'timeout'} sec" || "10 sec",
149
    );
178
    );
179
    $self->{'memory_cache'} = $cache;
180
    # Memory cache can't handle complex types for some reason, so we use its
181
    # freeze and thaw functions.
182
    $self->{ref($cache) . '_set'} = sub {
183
        my ($key, $val, $exp) = @_;
184
        # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
185
        $exp = "$exp sec" if defined $exp;
186
        # Because we need to use freeze, it must be a reference type.
187
        $cache->freeze($key, [$val], $exp);
188
    };
189
    $self->{ref($cache) . '_get'} = sub {
190
        my $res = $cache->thaw(shift);
191
        return unless defined $res;
192
        return $res->[0];
193
    };
150
    return $self;
194
    return $self;
151
}
195
}
152
196
153
=head2 is_cache_active
197
=head2 is_cache_active
154
198
155
Routine that checks whether or not a caching system has been selected. This is
199
Routine that checks whether or not a default caching method is active on this
156
not an instance method.
200
object.
157
201
158
=cut
202
=cut
159
203
160
sub is_cache_active {
204
sub is_cache_active {
161
    return $ENV{CACHING_SYSTEM} ? '1' : '';
205
    my $self = shift;
206
    return $self->{'cache'} ? 1 : 0;
162
}
207
}
163
208
164
=head2 set_in_cache
209
=head2 set_in_cache
165
210
166
    $cache->set_in_cache($key, $value, [$expiry]);
211
    $cache->set_in_cache($key, $value, [$options]);
212
213
Save a value to the specified key in the cache. A hashref of options may be
214
specified.
167
215
168
Save a value to the specified key in the default cache, optionally with a
216
The possible options are:
169
particular expiry.
217
218
=over
219
220
=item expiry
221
222
Expiry time of this cached entry in seconds.
223
224
=item deepcopy
225
226
If set, this will perform a deep copy of the item when it's retrieved. This
227
means that it'll be safe if something later modifies the result of the
228
function. Will be ignored in situations where the same behaviour comes from
229
the caching layer anyway.
230
231
=item cache
232
233
The cache object to use if you want to provide your own. It should be an
234
instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
170
235
171
=cut
236
=cut
172
237
173
sub set_in_cache {
238
sub set_in_cache {
174
    my ( $self, $key, $value, $expiry, $cache ) = @_;
239
    my ( $self, $key, $value, $options, $_cache) = @_;
175
    $cache ||= 'cache';
240
    # This is a bit of a hack to support the old API in case things still use it
241
    if (defined $options && (ref($options) ne 'HASH')) {
242
        my $new_options;
243
        $new_options->{expiry} = $options;
244
        $new_options->{cache} = $_cache if defined $_cache;
245
        $options = $new_options;
246
    }
247
248
    # the key mustn't contain whitespace (or control characters) for memcache
249
    # but shouldn't be any harm in applying it globally.
250
    $key =~ s/[\x00-\x20]/_/g;
251
252
    my $cache = $options->{cache} || 'cache';
176
    croak "No key" unless $key;
253
    croak "No key" unless $key;
177
    $ENV{DEBUG} && carp "set_in_cache for $key";
254
    $ENV{DEBUG} && carp "set_in_cache for $key";
178
255
179
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
256
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
257
    my $expiry = $options->{expiry};
258
    my $set_sub = $self->{ref($self->{$cache}) . "_set"};
180
    if ( defined $expiry ) {
259
    if ( defined $expiry ) {
181
        if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {
260
        return $set_sub
182
            $expiry = "$expiry sec";
261
          ? $set_sub->( $key, $value, $expiry )
183
        }
262
          : $self->{$cache}->set( $key, $value, $expiry );
184
        return $self->{$cache}->set( $key, $value, $expiry );
185
    }
263
    }
186
    else {
264
    else {
187
        return $self->{$cache}->set( $key, $value );
265
        return $set_sub
266
          ? $set_sub->( $key, $value )
267
          : $self->{$cache}->set( $key, $value );
188
    }
268
    }
189
}
269
}
190
270
Lines 198-208 Retrieve the value stored under the specified key in the default cache. Link Here
198
278
199
sub get_from_cache {
279
sub get_from_cache {
200
    my ( $self, $key, $cache ) = @_;
280
    my ( $self, $key, $cache ) = @_;
281
    $key =~ s/[\x00-\x20]/_/g;
201
    $cache ||= 'cache';
282
    $cache ||= 'cache';
202
    croak "No key" unless $key;
283
    croak "No key" unless $key;
203
    $ENV{DEBUG} && carp "get_from_cache for $key";
284
    $ENV{DEBUG} && carp "get_from_cache for $key";
204
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
285
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
205
    return $self->{$cache}->get($key);
286
    my $get_sub = $self->{ref($self->{$cache}) . "_get"};
287
    return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
206
}
288
}
207
289
208
=head2 clear_from_cache
290
=head2 clear_from_cache
Lines 215-225 Remove the value identified by the specified key from the default cache. Link Here
215
297
216
sub clear_from_cache {
298
sub clear_from_cache {
217
    my ( $self, $key, $cache ) = @_;
299
    my ( $self, $key, $cache ) = @_;
300
    $key =~ s/[\x00-\x20]/_/g;
218
    $cache ||= 'cache';
301
    $cache ||= 'cache';
219
    croak "No key" unless $key;
302
    croak "No key" unless $key;
220
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
303
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
221
    return $self->{$cache}->delete($key)
304
    return $self->{$cache}->delete($key)
222
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
305
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
223
    return $self->{$cache}->remove($key);
306
    return $self->{$cache}->remove($key);
224
}
307
}
225
308
Lines 236-242 sub flush_all { Link Here
236
    $cache ||= 'cache';
319
    $cache ||= 'cache';
237
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
320
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
238
    return $self->{$cache}->flush_all()
321
    return $self->{$cache}->flush_all()
239
      if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );
322
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
240
    return $self->{$cache}->clear();
323
    return $self->{$cache}->clear();
241
}
324
}
242
325
(-)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 (-4 / +4 lines)
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", 25
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 138-145 SKIP: { Link Here
138
138
139
END {
139
END {
140
  SKIP: {
140
  SKIP: {
141
        my $cache = Koha::Cache->get_instance();
141
        skip "Cache not enabled", 1
142
        skip "Cache not enabled", 1
142
          unless ( Koha::Cache->is_cache_active() );
143
          unless ( $cache->is_cache_active() );
143
        is( $destructorcount, 1, 'Destructor run exactly once' );
144
        is( $destructorcount, 1, 'Destructor run exactly once' );
144
    }
145
    }
145
}
146
}
146
- 

Return to bug 12041