View | Details | Raw Unified | Return to bug 16579
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 264-274 sub set_in_cache { Link Here
264
    if (ref($value)) {
258
    if (ref($value)) {
265
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
259
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
266
        $value = $L1_encoder->encode($value);
260
        $value = $L1_encoder->encode($value);
267
        $L1_cache{$key}->{frozen} = $value;
261
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
268
        $flag = '-CF1';
262
        $flag = '-CF1';
269
    } else {
263
    } else {
270
        # Set in L1 cache as a scalar; exit if we are caching an undef
264
        # Set in L1 cache as a scalar; exit if we are caching an undef
271
        $L1_cache{$key} = $value;
265
        $L1_cache{$self->{namespace}}{$key} = $value;
272
        return if !defined $value;
266
        return if !defined $value;
273
    }
267
    }
274
268
Lines 322-338 sub get_from_cache { Link Here
322
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
316
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
323
317
324
    # Return L1 cache value if exists
318
    # Return L1 cache value if exists
325
    if ( exists $L1_cache{$key} ) {
319
    if ( exists $L1_cache{$self->{namespace}}{$key} ) {
326
        if (ref($L1_cache{$key})) {
320
        if (ref($L1_cache{$self->{namespace}}{$key})) {
327
            if ($unsafe) {
321
            if ($unsafe) {
328
                $L1_cache{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$key}->{frozen});
322
                $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
329
                return $L1_cache{$key}->{thawed};
323
                return $L1_cache{$self->{namespace}}{$key}->{thawed};
330
            } else {
324
            } else {
331
                return $L1_decoder->decode($L1_cache{$key}->{frozen});
325
                return $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
332
            }
326
            }
333
        } else {
327
        } else {
334
            # No need to thaw if it's a scalar
328
            # No need to thaw if it's a scalar
335
            return $L1_cache{$key};
329
            return $L1_cache{$self->{namespace}}{$key};
336
        }
330
        }
337
    }
331
    }
338
332
Lines 345-359 sub get_from_cache { Link Here
345
    my $flag = substr($L2_value, -4, 4, '');
339
    my $flag = substr($L2_value, -4, 4, '');
346
    if ($flag eq '-CF0') {
340
    if ($flag eq '-CF0') {
347
        # it's a scalar
341
        # it's a scalar
348
        $L1_cache{$key} = $L2_value;
342
        $L1_cache{$self->{namespace}}{$key} = $L2_value;
349
        return $L2_value;
343
        return $L2_value;
350
    } elsif ($flag eq '-CF1') {
344
    } elsif ($flag eq '-CF1') {
351
        # it's a frozen data structure
345
        # it's a frozen data structure
352
        my $thawed;
346
        my $thawed;
353
        eval { $thawed = $L1_decoder->decode($L2_value); };
347
        eval { $thawed = $L1_decoder->decode($L2_value); };
354
        return if $@;
348
        return if $@;
355
        $L1_cache{$key}->{frozen} = $L2_value;
349
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
356
        $L1_cache{$key}->{thawed} = $thawed if $unsafe;
350
        $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
357
        return $thawed;
351
        return $thawed;
358
    }
352
    }
359
353
Lines 377-383 sub clear_from_cache { Link Here
377
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
371
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
378
372
379
    # Clear from L1 cache
373
    # Clear from L1 cache
380
    delete $L1_cache{$key};
374
    delete $L1_cache{$self->{namespace}}{$key};
381
375
382
    return $self->{$cache}->delete($key)
376
    return $self->{$cache}->delete($key)
383
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
377
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
Lines 406-412 sub flush_all { Link Here
406
400
407
sub flush_L1_cache {
401
sub flush_L1_cache {
408
    my( $self ) = @_;
402
    my( $self ) = @_;
409
    %L1_cache = ();
403
    $L1_cache{$self->{namespace}} = ();
410
}
404
}
411
405
412
=head1 TIED INTERFACE
406
=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 34-40 use C4::Languages; Link Here
34
use C4::Letters;
34
use C4::Letters;
35
use C4::Members;
35
use C4::Members;
36
use C4::XSLT;
36
use C4::XSLT;
37
use Koha::Cache;
37
use Koha::Caches;
38
use Koha::Cache::Memory::Lite;
38
use Koha::Cache::Memory::Lite;
39
use Koha::Database;
39
use Koha::Database;
40
use Koha::DateUtils;
40
use Koha::DateUtils;
Lines 46-52 use CGI qw(-utf8 ); # we will loose -utf8 under plack, otherwise Link Here
46
    *CGI::new = sub {
46
    *CGI::new = sub {
47
        my $q = $old_new->( @_ );
47
        my $q = $old_new->( @_ );
48
        $CGI::PARAM_UTF8 = 1;
48
        $CGI::PARAM_UTF8 = 1;
49
        Koha::Cache->flush_L1_cache();
49
        Koha::Caches->flush_L1_caches();
50
        Koha::Cache::Memory::Lite->flush();
50
        Koha::Cache::Memory::Lite->flush();
51
        return $q;
51
        return $q;
52
    };
52
    };
(-)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 16579