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 51-57 our %L1_cache; Link Here
51
51
52
=head2 get_instance
52
=head2 get_instance
53
53
54
    my $cache = Koha::Cache->get_instance();
54
    my $cache = Koha::Caches->get_instance();
55
55
56
This gets a shared instance of the cache, set up in a very default way. This is
56
This gets a shared instance of the cache, set up in a very default way. This is
57
the recommended way to fetch a cache object. If possible, it'll be
57
the recommended way to fetch a cache object. If possible, it'll be
Lines 59-71 persistent across multiple instances. Link Here
59
59
60
=cut
60
=cut
61
61
62
our $singleton_cache;
63
sub get_instance {
64
    my ($class) = @_;
65
    $singleton_cache = $class->new() unless $singleton_cache;
66
    return $singleton_cache;
67
}
68
69
=head2 new
62
=head2 new
70
63
71
Create a new Koha::Cache object. This is required for all cache-related functionality.
64
Create a new Koha::Cache object. This is required for all cache-related functionality.
Lines 73-79 Create a new Koha::Cache object. This is required for all cache-related function Link Here
73
=cut
66
=cut
74
67
75
sub new {
68
sub new {
76
    my ( $class, $self ) = @_;
69
    my ( $class, $self, $subnamespace ) = @_;
77
    $self->{'default_type'} =
70
    $self->{'default_type'} =
78
         $self->{cache_type}
71
         $self->{cache_type}
79
      || $ENV{CACHING_SYSTEM}
72
      || $ENV{CACHING_SYSTEM}
Lines 83-88 sub new { Link Here
83
76
84
    $self->{'timeout'}   ||= 0;
77
    $self->{'timeout'}   ||= 0;
85
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
78
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
79
    $self->{namespace} .= ":$subnamespace:";
86
80
87
    if ( $self->{'default_type'} eq 'memcached'
81
    if ( $self->{'default_type'} eq 'memcached'
88
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
82
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } )
Lines 261-271 sub set_in_cache { Link Here
261
    if (ref($value)) {
255
    if (ref($value)) {
262
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
256
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
263
        $value = freeze($value);
257
        $value = freeze($value);
264
        $L1_cache{$key}->{frozen} = $value;
258
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
265
        $flag = '-CF1';
259
        $flag = '-CF1';
266
    } else {
260
    } else {
267
        # Set in L1 cache as a scalar; exit if we are caching an undef
261
        # Set in L1 cache as a scalar; exit if we are caching an undef
268
        $L1_cache{$key} = $value;
262
        $L1_cache{$self->{namespace}}{$key} = $value;
269
        return if !defined $value;
263
        return if !defined $value;
270
    }
264
    }
271
265
Lines 319-335 sub get_from_cache { Link Here
319
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
313
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
320
314
321
    # Return L1 cache value if exists
315
    # Return L1 cache value if exists
322
    if ( exists $L1_cache{$key} ) {
316
    if ( exists $L1_cache{$self->{namespace}}{$key} ) {
323
        if (ref($L1_cache{$key})) {
317
        if (ref($L1_cache{$self->{namespace}}{$key})) {
324
            if ($unsafe) {
318
            if ($unsafe) {
325
                $L1_cache{$key}->{thawed} ||= thaw($L1_cache{$key}->{frozen});
319
                $L1_cache{$self->{namespace}}{$key}->{thawed} ||= thaw($L1_cache{$self->{namespace}}{$key}->{frozen});
326
                return $L1_cache{$key}->{thawed};
320
                return $L1_cache{$self->{namespace}}{$key}->{thawed};
327
            } else {
321
            } else {
328
                return thaw($L1_cache{$key}->{frozen});
322
                return thaw($L1_cache{$self->{namespace}}{$key}->{frozen});
329
            }
323
            }
330
        } else {
324
        } else {
331
            # No need to thaw if it's a scalar
325
            # No need to thaw if it's a scalar
332
            return $L1_cache{$key};
326
            return $L1_cache{$self->{namespace}}{$key};
333
        }
327
        }
334
    }
328
    }
335
329
Lines 342-356 sub get_from_cache { Link Here
342
    my $flag = substr($L2_value, -4, 4, '');
336
    my $flag = substr($L2_value, -4, 4, '');
343
    if ($flag eq '-CF0') {
337
    if ($flag eq '-CF0') {
344
        # it's a scalar
338
        # it's a scalar
345
        $L1_cache{$key} = $L2_value;
339
        $L1_cache{$self->{namespace}}{$key} = $L2_value;
346
        return $L2_value;
340
        return $L2_value;
347
    } elsif ($flag eq '-CF1') {
341
    } elsif ($flag eq '-CF1') {
348
        # it's a frozen data structure
342
        # it's a frozen data structure
349
        my $thawed;
343
        my $thawed;
350
        eval { $thawed = thaw($L2_value); };
344
        eval { $thawed = thaw($L2_value); };
351
        return if $@;
345
        return if $@;
352
        $L1_cache{$key}->{frozen} = $L2_value;
346
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
353
        $L1_cache{$key}->{thawed} = $thawed if $unsafe;
347
        $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
354
        return $thawed;
348
        return $thawed;
355
    }
349
    }
356
350
Lines 374-380 sub clear_from_cache { Link Here
374
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
368
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
375
369
376
    # Clear from L1 cache
370
    # Clear from L1 cache
377
    delete $L1_cache{$key};
371
    delete $L1_cache{$self->{namespace}}{$key};
378
372
379
    return $self->{$cache}->delete($key)
373
    return $self->{$cache}->delete($key)
380
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
374
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
Lines 403-409 sub flush_all { Link Here
403
397
404
sub flush_L1_cache {
398
sub flush_L1_cache {
405
    my( $self ) = @_;
399
    my( $self ) = @_;
406
    %L1_cache = ();
400
    $L1_cache{$self->{namespace}} = ();
407
}
401
}
408
402
409
=head1 TIED INTERFACE
403
=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