View | Details | Raw Unified | Return to bug 16166
Collapse All | Expand All

(-)a/Koha/Cache.pm (-12 / +40 lines)
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
- 

Return to bug 16166