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 |