|
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 |
- |
|
|