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

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

Return to bug 16166