|
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 Clone qw( clone ); |
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 281-289
sub set_in_cache {
Link Here
|
| 281 |
$expiry //= $self->{timeout}; |
281 |
$expiry //= $self->{timeout}; |
| 282 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
282 |
my $set_sub = $self->{ref($self->{$cache}) . "_set"}; |
| 283 |
|
283 |
|
|
|
284 |
my $flag = '-CF0'; # 0: scalar, 1: freezed data structure |
| 284 |
# Set in L1 cache |
285 |
# Set in L1 cache |
| 285 |
$L1_cache{ $key } = $value; |
286 |
if (ref($value)) { |
|
|
287 |
$value = freeze($value); |
| 288 |
$L1_cache{ $key } = [ (undef, $value) ]; |
| 289 |
$flag = '-CF1'; |
| 290 |
} else { |
| 291 |
$L1_cache{ $key } = $value; |
| 292 |
} |
| 286 |
|
293 |
|
|
|
294 |
$value .= $flag; |
| 287 |
# We consider an expiry of 0 to be inifinite |
295 |
# We consider an expiry of 0 to be inifinite |
| 288 |
if ( $expiry ) { |
296 |
if ( $expiry ) { |
| 289 |
return $set_sub |
297 |
return $set_sub |
|
Lines 321-341
sub get_from_cache {
Link Here
|
| 321 |
|
329 |
|
| 322 |
# Return L1 cache value if exists |
330 |
# Return L1 cache value if exists |
| 323 |
if ( exists $L1_cache{$key} ) { |
331 |
if ( exists $L1_cache{$key} ) { |
| 324 |
# No need to deep copy if it's a scalar |
332 |
if (ref($L1_cache{$key})) { |
| 325 |
# Or if we do not need to deep copy |
333 |
if ($unsafe) { |
| 326 |
return $L1_cache{$key} |
334 |
$L1_cache{$key}->[0] ||= thaw($L1_cache{$key}->[1]); |
| 327 |
if not ref $L1_cache{$key} or $unsafe; |
335 |
return $L1_cache{$key}->[0]; |
| 328 |
return clone $L1_cache{$key}; |
336 |
} else { |
|
|
337 |
return thaw($L1_cache{$key}->[1]); |
| 338 |
} |
| 339 |
} else { |
| 340 |
# No need to deep copy if it's a scalar |
| 341 |
return $L1_cache{$key}; |
| 342 |
} |
| 329 |
} |
343 |
} |
| 330 |
|
344 |
|
| 331 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
345 |
my $get_sub = $self->{ref($self->{$cache}) . "_get"}; |
| 332 |
my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
346 |
my $value = $get_sub ? $get_sub->($key) : $self->{$cache}->get($key); |
| 333 |
|
347 |
|
| 334 |
# Update the L1 cache when fetching the L2 cache |
348 |
return if ref($value); |
| 335 |
# Otherwise the L1 cache won't ever be populated |
349 |
return unless (defined($value) && length($value) >= 4); |
| 336 |
$L1_cache{$key} = $value; |
350 |
|
|
|
351 |
my $flag = substr($value, -4, 4, ''); |
| 352 |
if ($flag eq '-CF0') { |
| 353 |
# it's a scalar |
| 354 |
$L1_cache{$key} = $value; |
| 355 |
return $value; |
| 356 |
} elsif ($flag eq '-CF1') { |
| 357 |
# it's a freezed data structure |
| 358 |
my $thawed; |
| 359 |
eval { $thawed = thaw($value); }; |
| 360 |
return if $@; |
| 361 |
$L1_cache{$key} = [ (undef, $value) ]; |
| 362 |
$L1_cache{$key}->[0] = $thawed if $unsafe; |
| 363 |
return $thawed; |
| 364 |
} |
| 337 |
|
365 |
|
| 338 |
return $value; |
366 |
# Unknown value / data type returned from L2 cache |
|
|
367 |
return; |
| 339 |
} |
368 |
} |
| 340 |
|
369 |
|
| 341 |
=head2 clear_from_cache |
370 |
=head2 clear_from_cache |
| 342 |
- |
|
|