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

(-)a/Koha/Cache.pm (-28 / +43 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 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
- 

Return to bug 16166