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 228-240
The possible options are:
Link Here
|
228 |
|
228 |
|
229 |
Expiry time of this cached entry in seconds. |
229 |
Expiry time of this cached entry in seconds. |
230 |
|
230 |
|
231 |
=item unsafe |
|
|
232 |
|
233 |
If set, this will avoid performing a deep copy of the item. This |
234 |
means that it won't be safe if something later modifies the result of the |
235 |
function. It should be used with caution, and could save processing time |
236 |
in some situations where is safe to use it. |
237 |
|
238 |
=item cache |
231 |
=item cache |
239 |
|
232 |
|
240 |
The cache object to use if you want to provide your own. It should be an |
233 |
The cache object to use if you want to provide your own. It should be an |
Lines 253-259
sub set_in_cache {
Link Here
|
253 |
$new_options->{cache} = $_cache if defined $_cache; |
246 |
$new_options->{cache} = $_cache if defined $_cache; |
254 |
$options = $new_options; |
247 |
$options = $new_options; |
255 |
} |
248 |
} |
256 |
my $unsafe = $options->{unsafe} || 0; |
|
|
257 |
|
249 |
|
258 |
# the key mustn't contain whitespace (or control characters) for memcache |
250 |
# the key mustn't contain whitespace (or control characters) for memcache |
259 |
# but shouldn't be any harm in applying it globally. |
251 |
# but shouldn't be any harm in applying it globally. |
Lines 268-281
sub set_in_cache {
Link Here
|
268 |
$expiry //= $self->{timeout}; |
260 |
$expiry //= $self->{timeout}; |
269 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
261 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
270 |
|
262 |
|
271 |
# Deep copy if it's not a scalar and unsafe is not passed |
263 |
my $flag = '-CF0'; # 0: scalar, 1: frozen data structure |
272 |
$value = dclone( $value ) if ref($value) and not $unsafe; |
264 |
if (ref($value)) { |
273 |
|
265 |
# Set in L1 cache as a data structure, initially only in frozen form (for performance reasons) |
274 |
# Set in L1 cache; exit if we are caching an undef |
266 |
$value = freeze($value); |
275 |
$L1_cache{ $key } = $value; |
267 |
$L1_cache{$key}->{frozen} = $value; |
276 |
return if !defined $value; |
268 |
$flag = '-CF1'; |
|
|
269 |
} else { |
270 |
# Set in L1 cache as a scalar; exit if we are caching an undef |
271 |
$L1_cache{$key} = $value; |
272 |
return if !defined $value; |
273 |
} |
277 |
|
274 |
|
278 |
# We consider an expiry of 0 to be infinite |
275 |
$value .= $flag; |
|
|
276 |
# We consider an expiry of 0 to be inifinite |
279 |
if ( $expiry ) { |
277 |
if ( $expiry ) { |
280 |
return $set_sub |
278 |
return $set_sub |
281 |
? $set_sub->( $key, $value, $expiry ) |
279 |
? $set_sub->( $key, $value, $expiry ) |
Lines 292-298
sub set_in_cache {
Link Here
|
292 |
|
290 |
|
293 |
my $value = $cache->get_from_cache($key, [ $options ]); |
291 |
my $value = $cache->get_from_cache($key, [ $options ]); |
294 |
|
292 |
|
295 |
Retrieve the value stored under the specified key in the default cache. |
293 |
Retrieve the value stored under the specified key in the cache. |
296 |
|
294 |
|
297 |
The possible options are: |
295 |
The possible options are: |
298 |
|
296 |
|
Lines 325-347
sub get_from_cache {
Link Here
|
325 |
|
323 |
|
326 |
# Return L1 cache value if exists |
324 |
# Return L1 cache value if exists |
327 |
if ( exists $L1_cache{$key} ) { |
325 |
if ( exists $L1_cache{$key} ) { |
328 |
# No need to deep copy if it's a scalar |
326 |
if (ref($L1_cache{$key})) { |
329 |
# Or if we do not need to deep copy |
327 |
if ($unsafe) { |
330 |
return $L1_cache{$key} |
328 |
$L1_cache{$key}->{thawed} ||= thaw($L1_cache{$key}->{frozen}); |
331 |
if not ref $L1_cache{$key} or $unsafe; |
329 |
return $L1_cache{$key}->{thawed}; |
332 |
return dclone $L1_cache{$key}; |
330 |
} else { |
|
|
331 |
return thaw($L1_cache{$key}->{frozen}); |
332 |
} |
333 |
} else { |
334 |
# No need to thaw if it's a scalar |
335 |
return $L1_cache{$key}; |
336 |
} |
333 |
} |
337 |
} |
334 |
|
338 |
|
335 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
339 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
336 |
my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
340 |
my $L2_value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
337 |
|
341 |
|
338 |
# Update the L1 cache when fetching the L2 cache |
342 |
return if ref($L2_value); |
339 |
# Otherwise the L1 cache won't ever be populated |
343 |
return unless (defined($L2_value) && length($L2_value) >= 4); |
340 |
$L1_cache{$key} = $value; |
344 |
|
341 |
|
345 |
my $flag = substr($L2_value, -4, 4, ''); |
342 |
$value = dclone $value if ref $L1_cache{$key} and not $unsafe; |
346 |
if ($flag eq '-CF0') { |
|
|
347 |
# it's a scalar |
348 |
$L1_cache{$key} = $L2_value; |
349 |
return $L2_value; |
350 |
} elsif ($flag eq '-CF1') { |
351 |
# it's a frozen data structure |
352 |
my $thawed; |
353 |
eval { $thawed = thaw($L2_value); }; |
354 |
return if $@; |
355 |
$L1_cache{$key}->{frozen} = $L2_value; |
356 |
$L1_cache{$key}->{thawed} = $thawed if $unsafe; |
357 |
return $thawed; |
358 |
} |
343 |
|
359 |
|
344 |
return $value; |
360 |
# Unknown value / data type returned from L2 cache |
|
|
361 |
return; |
345 |
} |
362 |
} |
346 |
|
363 |
|
347 |
=head2 clear_from_cache |
364 |
=head2 clear_from_cache |
348 |
- |
|
|