|
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 |
} |
| 84 |
} |
| 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 |
} |
| 79 |
} |
93 |
} |
| 80 |
my $cache = $subclass->_cache_handle($param); |
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; |
| 130 |
} |
| 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; |
| 84 |
} |
141 |
} |
| 85 |
|
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 |
=back |
| 337 |
|
| 338 |
=head2 create_scalar |
| 339 |
|
| 340 |
my $scalar = Koha::Cache->create_scalar(\%params); |
| 341 |
|
| 342 |
Create scalar tied to the cache. |
| 343 |
|
| 344 |
=cut |
| 345 |
|
| 346 |
sub create_scalar { |
| 347 |
my ( $self, $args ) = @_; |
| 348 |
|
| 349 |
$self->_set_tied_defaults($args); |
| 350 |
|
| 351 |
tie my $scalar, 'Koha::Cache::Object', $args; |
| 352 |
return \$scalar; |
| 353 |
} |
| 354 |
|
| 355 |
sub create_hash { |
| 356 |
my ( $self, $args ) = @_; |
| 357 |
|
| 358 |
$self->_set_tied_defaults($args); |
| 359 |
|
| 360 |
tie my %hash, 'Koha::Cache::Object', $args; |
| 361 |
return \%hash; |
| 362 |
} |
| 363 |
|
| 364 |
sub _set_tied_defaults { |
| 365 |
my ( $self, $args ) = @_; |
| 366 |
|
| 367 |
$args->{'timeout'} = '600' unless defined( $args->{'timeout'} ); |
| 368 |
$args->{'inprocess'} = '0' unless defined( $args->{'inprocess'} ); |
| 369 |
unless (lc($args->{'cache_type'}) eq 'null') { |
| 370 |
$args->{'cache'} = $self; |
| 371 |
$args->{'cache_type'} ||= $ENV{'CACHING_SYSTEM'}; |
| 372 |
} |
| 373 |
|
| 374 |
return $args; |
| 128 |
} |
375 |
} |
| 129 |
|
376 |
|
| 130 |
=head2 EXPORT |
377 |
=head1 EXPORT |
| 131 |
|
378 |
|
| 132 |
None by default. |
379 |
None by default. |
| 133 |
|
380 |
|
| 134 |
=head1 SEE ALSO |
381 |
=head1 SEE ALSO |
| 135 |
|
382 |
|
| 136 |
Koha::Cache::Memcached |
383 |
Koha::Cache::Object |
| 137 |
|
384 |
|
| 138 |
=head1 AUTHOR |
385 |
=head1 AUTHOR |
| 139 |
|
386 |
|