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

(-)a/C4/Context.pm (-1 / +1 lines)
Lines 108-114 BEGIN { Link Here
108
use Encode;
108
use Encode;
109
use ZOOM;
109
use ZOOM;
110
use XML::Simple;
110
use XML::Simple;
111
use Koha::Cache;
111
use Koha::Caches;
112
use POSIX ();
112
use POSIX ();
113
use DateTime::TimeZone;
113
use DateTime::TimeZone;
114
use Module::Load::Conditional qw(can_load);
114
use Module::Load::Conditional qw(can_load);
(-)a/Koha/Cache.pm (-22 / +16 lines)
Lines 54-60 our $L1_decoder = Sereal::Decoder->new; Link Here
54
54
55
=head2 get_instance
55
=head2 get_instance
56
56
57
    my $cache = Koha::Cache->get_instance();
57
    my $cache = Koha::Caches->get_instance();
58
58
59
This gets a shared instance of the cache, set up in a very default way. This is
59
This gets a shared instance of the cache, set up in a very default way. This is
60
the recommended way to fetch a cache object. If possible, it'll be
60
the recommended way to fetch a cache object. If possible, it'll be
Lines 62-74 persistent across multiple instances. Link Here
62
62
63
=cut
63
=cut
64
64
65
our $singleton_cache;
66
sub get_instance {
67
    my ($class) = @_;
68
    $singleton_cache = $class->new() unless $singleton_cache;
69
    return $singleton_cache;
70
}
71
72
=head2 new
65
=head2 new
73
66
74
Create a new Koha::Cache object. This is required for all cache-related functionality.
67
Create a new Koha::Cache object. This is required for all cache-related functionality.
Lines 76-82 Create a new Koha::Cache object. This is required for all cache-related function Link Here
76
=cut
69
=cut
77
70
78
sub new {
71
sub new {
79
    my ( $class, $self ) = @_;
72
    my ( $class, $self, $subnamespace ) = @_;
80
    $self->{'default_type'} =
73
    $self->{'default_type'} =
81
         $self->{cache_type}
74
         $self->{cache_type}
82
      || $ENV{CACHING_SYSTEM}
75
      || $ENV{CACHING_SYSTEM}
Lines 86-91 sub new { Link Here
86
79
87
    $self->{'timeout'}   ||= 0;
80
    $self->{'timeout'}   ||= 0;
88
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
81
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
82
    $self->{namespace} .= ":$subnamespace:";
89
83
90
    if ( $self->{'default_type'} eq 'memcached'
84
    if ( $self->{'default_type'} eq 'memcached'
91
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
85
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
Lines 267-277 sub set_in_cache { Link Here
267
    if (ref($value)) {
261
    if (ref($value)) {
268
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
262
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
269
        $value = $L1_encoder->encode($value);
263
        $value = $L1_encoder->encode($value);
270
        $L1_cache{$key}->{frozen} = $value;
264
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
271
        $flag = '-CF1';
265
        $flag = '-CF1';
272
    } else {
266
    } else {
273
        # Set in L1 cache as a scalar; exit if we are caching an undef
267
        # Set in L1 cache as a scalar; exit if we are caching an undef
274
        $L1_cache{$key} = $value;
268
        $L1_cache{$self->{namespace}}{$key} = $value;
275
        return if !defined $value;
269
        return if !defined $value;
276
    }
270
    }
277
271
Lines 325-341 sub get_from_cache { Link Here
325
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
319
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
326
320
327
    # Return L1 cache value if exists
321
    # Return L1 cache value if exists
328
    if ( exists $L1_cache{$key} ) {
322
    if ( exists $L1_cache{$self->{namespace}}{$key} ) {
329
        if (ref($L1_cache{$key})) {
323
        if (ref($L1_cache{$self->{namespace}}{$key})) {
330
            if ($unsafe) {
324
            if ($unsafe) {
331
                $L1_cache{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$key}->{frozen});
325
                $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
332
                return $L1_cache{$key}->{thawed};
326
                return $L1_cache{$self->{namespace}}{$key}->{thawed};
333
            } else {
327
            } else {
334
                return $L1_decoder->decode($L1_cache{$key}->{frozen});
328
                return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
335
            }
329
            }
336
        } else {
330
        } else {
337
            # No need to thaw if it's a scalar
331
            # No need to thaw if it's a scalar
338
            return $L1_cache{$key};
332
            return $L1_cache{$self->{namespace}}{$key};
339
        }
333
        }
340
    }
334
    }
341
335
Lines 348-362 sub get_from_cache { Link Here
348
    my $flag = substr($L2_value, -4, 4, '');
342
    my $flag = substr($L2_value, -4, 4, '');
349
    if ($flag eq '-CF0') {
343
    if ($flag eq '-CF0') {
350
        # it's a scalar
344
        # it's a scalar
351
        $L1_cache{$key} = $L2_value;
345
        $L1_cache{$self->{namespace}}{$key} = $L2_value;
352
        return $L2_value;
346
        return $L2_value;
353
    } elsif ($flag eq '-CF1') {
347
    } elsif ($flag eq '-CF1') {
354
        # it's a frozen data structure
348
        # it's a frozen data structure
355
        my $thawed;
349
        my $thawed;
356
        eval { $thawed = $L1_decoder->decode($L2_value); };
350
        eval { $thawed = $L1_decoder->decode($L2_value); };
357
        return if $@;
351
        return if $@;
358
        $L1_cache{$key}->{frozen} = $L2_value;
352
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
359
        $L1_cache{$key}->{thawed} = $thawed if $unsafe;
353
        $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
360
        return $thawed;
354
        return $thawed;
361
    }
355
    }
362
356
Lines 380-386 sub clear_from_cache { Link Here
380
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
374
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
381
375
382
    # Clear from L1 cache
376
    # Clear from L1 cache
383
    delete $L1_cache{$key};
377
    delete $L1_cache{$self->{namespace}}{$key};
384
378
385
    return $self->{$cache}->delete($key)
379
    return $self->{$cache}->delete($key)
386
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
380
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
Lines 409-415 sub flush_all { Link Here
409
403
410
sub flush_L1_cache {
404
sub flush_L1_cache {
411
    my( $self ) = @_;
405
    my( $self ) = @_;
412
    %L1_cache = ();
406
    $L1_cache{$self->{namespace}} = ();
413
}
407
}
414
408
415
=head1 TIED INTERFACE
409
=head1 TIED INTERFACE
(-)a/Koha/Caches.pm (+21 lines)
Line 0 Link Here
1
package Koha::Caches;
2
3
use Modern::Perl;
4
use Koha::Cache;
5
6
our $singleton_caches;
7
sub get_instance {
8
    my ($class, $subnamespace) = @_;
9
    $subnamespace //= '';
10
    $singleton_caches->{$subnamespace} = Koha::Cache->new({}, $subnamespace) unless $singleton_caches->{$subnamespace};
11
    return $singleton_caches->{$subnamespace};
12
}
13
14
sub flush_L1_caches {
15
    return unless $singleton_caches;
16
    for my $cache ( values %$singleton_caches ) {
17
        $cache->flush_L1_cache;
18
    }
19
}
20
21
1;
(-)a/debian/templates/plack.psgi (-2 / +2 lines)
Lines 36-42 use C4::Languages; Link Here
36
use C4::Letters;
36
use C4::Letters;
37
use C4::Members;
37
use C4::Members;
38
use C4::XSLT;
38
use C4::XSLT;
39
use Koha::Cache;
39
use Koha::Caches;
40
use Koha::Cache::Memory::Lite;
40
use Koha::Cache::Memory::Lite;
41
use Koha::Database;
41
use Koha::Database;
42
use Koha::DateUtils;
42
use Koha::DateUtils;
Lines 48-54 use CGI qw(-utf8 ); # we will loose -utf8 under plack, otherwise Link Here
48
    *CGI::new = sub {
48
    *CGI::new = sub {
49
        my $q = $old_new->( @_ );
49
        my $q = $old_new->( @_ );
50
        $CGI::PARAM_UTF8 = 1;
50
        $CGI::PARAM_UTF8 = 1;
51
        Koha::Cache->flush_L1_cache();
51
        Koha::Caches->flush_L1_caches();
52
        Koha::Cache::Memory::Lite->flush();
52
        Koha::Cache::Memory::Lite->flush();
53
        return $q;
53
        return $q;
54
    };
54
    };
(-)a/misc/plack/koha.psgi (-2 / +2 lines)
Lines 12-18 use CGI qw(-utf8 ); # we will lose -utf8 under plack Link Here
12
    *CGI::new = sub {
12
    *CGI::new = sub {
13
        my $q = $old_new->( @_ );
13
        my $q = $old_new->( @_ );
14
        $CGI::PARAM_UTF8 = 1;
14
        $CGI::PARAM_UTF8 = 1;
15
        Koha::Cache->flush_L1_cache();
15
        Koha::Caches->flush_L1_caches();
16
        Koha::Cache::Memory::Lite->flush();
16
        Koha::Cache::Memory::Lite->flush();
17
        return $q;
17
        return $q;
18
    };
18
    };
Lines 46-52 use C4::XSLT; Link Here
46
use C4::Branch;
46
use C4::Branch;
47
use C4::Category;
47
use C4::Category;
48
use Koha::DateUtils;
48
use Koha::DateUtils;
49
use Koha::Cache;
49
use Koha::Caches;
50
use Koha::Cache::Memory::Lite;
50
use Koha::Cache::Memory::Lite;
51
=for preload
51
=for preload
52
use C4::Tags; # FIXME
52
use C4::Tags; # FIXME
(-)a/t/Cache.t (-6 / +6 lines)
Lines 17-29 Link Here
17
17
18
use Modern::Perl;
18
use Modern::Perl;
19
19
20
use Test::More tests => 43;
20
use Test::More tests => 44;
21
use Test::Warn;
21
use Test::Warn;
22
22
23
my $destructorcount = 0;
23
my $destructorcount = 0;
24
24
25
BEGIN {
25
BEGIN {
26
    use_ok('Koha::Cache');
26
    use_ok('Koha::Cache');
27
    use_ok('Koha::Caches');
27
    use_ok('Koha::Cache::Object');
28
    use_ok('Koha::Cache::Object');
28
    use_ok('Koha::Cache::Memory::Lite');
29
    use_ok('Koha::Cache::Memory::Lite');
29
    use_ok('C4::Context');
30
    use_ok('C4::Context');
Lines 33-39 SKIP: { Link Here
33
    # Set a special namespace for testing, to avoid breaking
34
    # Set a special namespace for testing, to avoid breaking
34
    # if test is run with a different user than Apache's.
35
    # if test is run with a different user than Apache's.
35
    $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
36
    $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
36
    my $cache = Koha::Cache->get_instance();
37
    my $cache = Koha::Caches->get_instance();
37
38
38
    skip "Cache not enabled", 36
39
    skip "Cache not enabled", 36
39
      unless ( $cache->is_cache_active() && defined $cache );
40
      unless ( $cache->is_cache_active() && defined $cache );
Lines 258-265 subtest 'Koha::Cache::Memory::Lite' => sub { Link Here
258
259
259
subtest 'Koha::Caches' => sub {
260
subtest 'Koha::Caches' => sub {
260
    plan tests => 8;
261
    plan tests => 8;
261
    my $default_cache = Koha::Cache->get_instance();
262
    my $default_cache = Koha::Caches->get_instance();
262
    my $another_cache = Koha::Cache->get_instance('another_cache');
263
    my $another_cache = Koha::Caches->get_instance('another_cache');
263
    $default_cache->set_in_cache('key_a', 'value_a');
264
    $default_cache->set_in_cache('key_a', 'value_a');
264
    $default_cache->set_in_cache('key_b', 'value_b');
265
    $default_cache->set_in_cache('key_b', 'value_b');
265
    $another_cache->set_in_cache('key_a', 'another_value_a');
266
    $another_cache->set_in_cache('key_a', 'another_value_a');
Lines 279-285 subtest 'Koha::Caches' => sub { Link Here
279
END {
280
END {
280
  SKIP: {
281
  SKIP: {
281
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
282
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
282
        my $cache = Koha::Cache->get_instance();
283
        my $cache = Koha::Caches->get_instance();
283
        skip "Cache not enabled", 1
284
        skip "Cache not enabled", 1
284
          unless ( $cache->is_cache_active() );
285
          unless ( $cache->is_cache_active() );
285
        is( $destructorcount, 1, 'Destructor run exactly once' );
286
        is( $destructorcount, 1, 'Destructor run exactly once' );
286
- 

Return to bug 17189