|
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 |
|