Lines 38-44
The first, traditional OO interface provides the following functions:
Link Here
|
38 |
use strict; |
38 |
use strict; |
39 |
use warnings; |
39 |
use warnings; |
40 |
use Carp; |
40 |
use Carp; |
41 |
use Storable qw(dclone); |
41 |
use Storable qw(freeze thaw); |
42 |
use Module::Load::Conditional qw(can_load); |
42 |
use Module::Load::Conditional qw(can_load); |
43 |
use Koha::Cache::Object; |
43 |
use Koha::Cache::Object; |
44 |
|
44 |
|
Lines 242-254
The possible options are:
Link Here
|
242 |
|
242 |
|
243 |
Expiry time of this cached entry in seconds. |
243 |
Expiry time of this cached entry in seconds. |
244 |
|
244 |
|
245 |
=item unsafe |
|
|
246 |
|
247 |
If set, this will avoid performing a deep copy of the item. This |
248 |
means that it won't be safe if something later modifies the result of the |
249 |
function. It should be used with caution, and could save processing time |
250 |
in some situations where is safe to use it. |
251 |
|
252 |
=item cache |
245 |
=item cache |
253 |
|
246 |
|
254 |
The cache object to use if you want to provide your own. It should be an |
247 |
The cache object to use if you want to provide your own. It should be an |
Lines 267-273
sub set_in_cache {
Link Here
|
267 |
$new_options->{cache} = $_cache if defined $_cache; |
260 |
$new_options->{cache} = $_cache if defined $_cache; |
268 |
$options = $new_options; |
261 |
$options = $new_options; |
269 |
} |
262 |
} |
270 |
my $unsafe = $options->{unsafe} || 0; |
|
|
271 |
|
263 |
|
272 |
# the key mustn't contain whitespace (or control characters) for memcache |
264 |
# the key mustn't contain whitespace (or control characters) for memcache |
273 |
# but shouldn't be any harm in applying it globally. |
265 |
# but shouldn't be any harm in applying it globally. |
Lines 282-293
sub set_in_cache {
Link Here
|
282 |
$expiry //= $self->{timeout}; |
274 |
$expiry //= $self->{timeout}; |
283 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
275 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
284 |
|
276 |
|
285 |
# Deep copy if it's not a scalar and unsafe is not passed |
277 |
my $flag = '-CF0'; # 0: scalar, 1: frozen data structure |
286 |
$value = dclone( $value ) if ref($value) and not $unsafe; |
|
|
287 |
|
288 |
# Set in L1 cache |
278 |
# Set in L1 cache |
289 |
$L1_cache{ $key } = $value; |
279 |
if (ref($value)) { |
|
|
280 |
$value = freeze($value); |
281 |
$L1_cache{$key}->{frozen} = $value; |
282 |
$flag = '-CF1'; |
283 |
} else { |
284 |
$L1_cache{$key} = $value; |
285 |
} |
290 |
|
286 |
|
|
|
287 |
$value .= $flag; |
291 |
# We consider an expiry of 0 to be inifinite |
288 |
# We consider an expiry of 0 to be inifinite |
292 |
if ( $expiry ) { |
289 |
if ( $expiry ) { |
293 |
return $set_sub |
290 |
return $set_sub |
Lines 305-311
sub set_in_cache {
Link Here
|
305 |
|
302 |
|
306 |
my $value = $cache->get_from_cache($key, [ $options ]); |
303 |
my $value = $cache->get_from_cache($key, [ $options ]); |
307 |
|
304 |
|
308 |
Retrieve the value stored under the specified key in the default cache. |
305 |
Retrieve the value stored under the specified key in the cache. |
309 |
|
306 |
|
310 |
The possible options are: |
307 |
The possible options are: |
311 |
|
308 |
|
Lines 338-360
sub get_from_cache {
Link Here
|
338 |
|
335 |
|
339 |
# Return L1 cache value if exists |
336 |
# Return L1 cache value if exists |
340 |
if ( exists $L1_cache{$key} ) { |
337 |
if ( exists $L1_cache{$key} ) { |
341 |
# No need to deep copy if it's a scalar |
338 |
if (ref($L1_cache{$key})) { |
342 |
# Or if we do not need to deep copy |
339 |
if ($unsafe) { |
343 |
return $L1_cache{$key} |
340 |
$L1_cache{$key}->{thawed} ||= thaw($L1_cache{$key}->{frozen}); |
344 |
if not ref $L1_cache{$key} or $unsafe; |
341 |
return $L1_cache{$key}->{thawed}; |
345 |
return dclone $L1_cache{$key}; |
342 |
} else { |
|
|
343 |
return thaw($L1_cache{$key}->{frozen}); |
344 |
} |
345 |
} else { |
346 |
# No need to thaw if it's a scalar |
347 |
return $L1_cache{$key}; |
348 |
} |
346 |
} |
349 |
} |
347 |
|
350 |
|
348 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
351 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
349 |
my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
352 |
my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
350 |
|
353 |
|
351 |
# Update the L1 cache when fetching the L2 cache |
354 |
return if ref($L2_value); |
352 |
# Otherwise the L1 cache won't ever be populated |
355 |
return unless (defined($L2_value) && length($L2_value) >= 4); |
353 |
$L1_cache{$key} = $value; |
356 |
|
354 |
|
357 |
my $flag = substr($L2_value, -4, 4, ''); |
355 |
$value = dclone $value if ref $L1_cache{$key} and not $unsafe; |
358 |
if ($flag eq '-CF0') { |
|
|
359 |
# it's a scalar |
360 |
$L1_cache{$key} = $L2_value; |
361 |
return $L2_value; |
362 |
} elsif ($flag eq '-CF1') { |
363 |
# it's a frozen data structure |
364 |
my $thawed; |
365 |
eval { $thawed = thaw($L2_value); }; |
366 |
return if $@; |
367 |
$L1_cache{$key}->{frozen} = $L2_value; |
368 |
$L1_cache{$key}->{thawed} = $thawed if $unsafe; |
369 |
return $thawed; |
370 |
} |
356 |
|
371 |
|
357 |
return $value; |
372 |
# Unknown value / data type returned from L2 cache |
|
|
373 |
return; |
358 |
} |
374 |
} |
359 |
|
375 |
|
360 |
=head2 clear_from_cache |
376 |
=head2 clear_from_cache |
361 |
- |
|
|