|
Lines 51-57
our %L1_cache;
Link Here
|
| 51 |
|
51 |
|
| 52 |
=head2 get_instance |
52 |
=head2 get_instance |
| 53 |
|
53 |
|
| 54 |
my $cache = Koha::Cache->get_instance(); |
54 |
my $cache = Koha::Caches->get_instance(); |
| 55 |
|
55 |
|
| 56 |
This gets a shared instance of the cache, set up in a very default way. This is |
56 |
This gets a shared instance of the cache, set up in a very default way. This is |
| 57 |
the recommended way to fetch a cache object. If possible, it'll be |
57 |
the recommended way to fetch a cache object. If possible, it'll be |
|
Lines 59-71
persistent across multiple instances.
Link Here
|
| 59 |
|
59 |
|
| 60 |
=cut |
60 |
=cut |
| 61 |
|
61 |
|
| 62 |
our $singleton_cache; |
|
|
| 63 |
sub get_instance { |
| 64 |
my ($class) = @_; |
| 65 |
$singleton_cache = $class->new() unless $singleton_cache; |
| 66 |
return $singleton_cache; |
| 67 |
} |
| 68 |
|
| 69 |
=head2 new |
62 |
=head2 new |
| 70 |
|
63 |
|
| 71 |
Create a new Koha::Cache object. This is required for all cache-related functionality. |
64 |
Create a new Koha::Cache object. This is required for all cache-related functionality. |
|
Lines 73-79
Create a new Koha::Cache object. This is required for all cache-related function
Link Here
|
| 73 |
=cut |
66 |
=cut |
| 74 |
|
67 |
|
| 75 |
sub new { |
68 |
sub new { |
| 76 |
my ( $class, $self ) = @_; |
69 |
my ( $class, $self, $subnamespace ) = @_; |
| 77 |
$self->{'default_type'} = |
70 |
$self->{'default_type'} = |
| 78 |
$self->{cache_type} |
71 |
$self->{cache_type} |
| 79 |
|| $ENV{CACHING_SYSTEM} |
72 |
|| $ENV{CACHING_SYSTEM} |
|
Lines 83-88
sub new {
Link Here
|
| 83 |
|
76 |
|
| 84 |
$self->{'timeout'} ||= 0; |
77 |
$self->{'timeout'} ||= 0; |
| 85 |
$self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha'; |
78 |
$self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha'; |
|
|
79 |
$self->{namespace} .= ":$subnamespace:"; |
| 86 |
|
80 |
|
| 87 |
if ( $self->{'default_type'} eq 'memcached' |
81 |
if ( $self->{'default_type'} eq 'memcached' |
| 88 |
&& can_load( modules => { 'Cache::Memcached::Fast' => undef } ) |
82 |
&& can_load( modules => { 'Cache::Memcached::Fast' => undef } ) |
|
Lines 261-271
sub set_in_cache {
Link Here
|
| 261 |
if (ref($value)) { |
255 |
if (ref($value)) { |
| 262 |
# Set in L1 cache as a data structure, initially only in frozen form (for performance reasons) |
256 |
# Set in L1 cache as a data structure, initially only in frozen form (for performance reasons) |
| 263 |
$value = freeze($value); |
257 |
$value = freeze($value); |
| 264 |
$L1_cache{$key}->{frozen} = $value; |
258 |
$L1_cache{$self->{namespace}}{$key}->{frozen} = $value; |
| 265 |
$flag = '-CF1'; |
259 |
$flag = '-CF1'; |
| 266 |
} else { |
260 |
} else { |
| 267 |
# Set in L1 cache as a scalar; exit if we are caching an undef |
261 |
# Set in L1 cache as a scalar; exit if we are caching an undef |
| 268 |
$L1_cache{$key} = $value; |
262 |
$L1_cache{$self->{namespace}}{$key} = $value; |
| 269 |
return if !defined $value; |
263 |
return if !defined $value; |
| 270 |
} |
264 |
} |
| 271 |
|
265 |
|
|
Lines 319-335
sub get_from_cache {
Link Here
|
| 319 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
313 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
| 320 |
|
314 |
|
| 321 |
# Return L1 cache value if exists |
315 |
# Return L1 cache value if exists |
| 322 |
if ( exists $L1_cache{$key} ) { |
316 |
if ( exists $L1_cache{$self->{namespace}}{$key} ) { |
| 323 |
if (ref($L1_cache{$key})) { |
317 |
if (ref($L1_cache{$self->{namespace}}{$key})) { |
| 324 |
if ($unsafe) { |
318 |
if ($unsafe) { |
| 325 |
$L1_cache{$key}->{thawed} ||= thaw($L1_cache{$key}->{frozen}); |
319 |
$L1_cache{$self->{namespace}}{$key}->{thawed} ||= thaw($L1_cache{$self->{namespace}}{$key}->{frozen}); |
| 326 |
return $L1_cache{$key}->{thawed}; |
320 |
return $L1_cache{$self->{namespace}}{$key}->{thawed}; |
| 327 |
} else { |
321 |
} else { |
| 328 |
return thaw($L1_cache{$key}->{frozen}); |
322 |
return thaw($L1_cache{$self->{namespace}}{$key}->{frozen}); |
| 329 |
} |
323 |
} |
| 330 |
} else { |
324 |
} else { |
| 331 |
# No need to thaw if it's a scalar |
325 |
# No need to thaw if it's a scalar |
| 332 |
return $L1_cache{$key}; |
326 |
return $L1_cache{$self->{namespace}}{$key}; |
| 333 |
} |
327 |
} |
| 334 |
} |
328 |
} |
| 335 |
|
329 |
|
|
Lines 342-356
sub get_from_cache {
Link Here
|
| 342 |
my $flag = substr($L2_value, -4, 4, ''); |
336 |
my $flag = substr($L2_value, -4, 4, ''); |
| 343 |
if ($flag eq '-CF0') { |
337 |
if ($flag eq '-CF0') { |
| 344 |
# it's a scalar |
338 |
# it's a scalar |
| 345 |
$L1_cache{$key} = $L2_value; |
339 |
$L1_cache{$self->{namespace}}{$key} = $L2_value; |
| 346 |
return $L2_value; |
340 |
return $L2_value; |
| 347 |
} elsif ($flag eq '-CF1') { |
341 |
} elsif ($flag eq '-CF1') { |
| 348 |
# it's a frozen data structure |
342 |
# it's a frozen data structure |
| 349 |
my $thawed; |
343 |
my $thawed; |
| 350 |
eval { $thawed = thaw($L2_value); }; |
344 |
eval { $thawed = thaw($L2_value); }; |
| 351 |
return if $@; |
345 |
return if $@; |
| 352 |
$L1_cache{$key}->{frozen} = $L2_value; |
346 |
$L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value; |
| 353 |
$L1_cache{$key}->{thawed} = $thawed if $unsafe; |
347 |
$L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe; |
| 354 |
return $thawed; |
348 |
return $thawed; |
| 355 |
} |
349 |
} |
| 356 |
|
350 |
|
|
Lines 374-380
sub clear_from_cache {
Link Here
|
| 374 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
368 |
return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); |
| 375 |
|
369 |
|
| 376 |
# Clear from L1 cache |
370 |
# Clear from L1 cache |
| 377 |
delete $L1_cache{$key}; |
371 |
delete $L1_cache{$self->{namespace}}{$key}; |
| 378 |
|
372 |
|
| 379 |
return $self->{$cache}->delete($key) |
373 |
return $self->{$cache}->delete($key) |
| 380 |
if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); |
374 |
if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); |
|
Lines 403-409
sub flush_all {
Link Here
|
| 403 |
|
397 |
|
| 404 |
sub flush_L1_cache { |
398 |
sub flush_L1_cache { |
| 405 |
my( $self ) = @_; |
399 |
my( $self ) = @_; |
| 406 |
%L1_cache = (); |
400 |
$L1_cache{$self->{namespace}} = (); |
| 407 |
} |
401 |
} |
| 408 |
|
402 |
|
| 409 |
=head1 TIED INTERFACE |
403 |
=head1 TIED INTERFACE |