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