Attachment #54816 for bug #17189

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

Lines 108-114 BEGIN { Link Here

(-)a/C4/Context.pm (-1 / +1 lines)
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);





=head2 get_instance

    my $cache = Koha::Caches->get_instance();

This gets a shared instance of the cache, set up in a very default way. This is
the recommended way to fetch a cache object. If possible, it'll be


=cut

our $singleton_cache;
sub get_instance {
    my ($class) = @_;
    $singleton_cache = $class->new() unless $singleton_cache;
    return $singleton_cache;
}

=head2 new

Create a new Koha::Cache object. This is required for all cache-related functionality.

=cut

sub new {
    my ( $class, $self, $subnamespace ) = @_;
    $self->{'default_type'} =
         $self->{cache_type}
      || $ENV{CACHING_SYSTEM}


    $self->{'timeout'}   ||= 0;
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE} || 'koha';
    $self->{namespace} .= ":$subnamespace:";

    if ( $self->{'default_type'} eq 'memcached'
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } )

    if (ref($value)) {
        # Set in L1 cache as a data structure, initially only in frozen form (for performance reasons)
        $value = $L1_encoder->encode($value);
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $value;
        $flag = '-CF1';
    } else {
        # Set in L1 cache as a scalar; exit if we are caching an undef
        $L1_cache{$self->{namespace}}{$key} = $value;
        return if !defined $value;
    }


    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );

    # Return L1 cache value if exists
    if ( exists $L1_cache{$self->{namespace}}{$key} ) {
        if (ref($L1_cache{$self->{namespace}}{$key})) {
            if ($unsafe) {
                $L1_cache{$self->{namespace}}{$key}->{thawed} ||= $L1_decoder->decode($L1_cache{$self->{namespace}}{key}->{frozen});
                return $L1_cache{$self->{namespace}}{$key}->{thawed};
            } else {
                return $L1_decoder->decode($L1_cache{$self->{namespace}}{$key}->{frozen});
            }
        } else {
            # No need to thaw if it's a scalar
            return $L1_cache{$self->{namespace}}{$key};
        }
    }


    my $flag = substr($L2_value, -4, 4, '');
    if ($flag eq '-CF0') {
        # it's a scalar
        $L1_cache{$self->{namespace}}{$key} = $L2_value;
        return $L2_value;
    } elsif ($flag eq '-CF1') {
        # it's a frozen data structure
        my $thawed;
        eval { $thawed = $L1_decoder->decode($L2_value); };
        return if $@;
        $L1_cache{$self->{namespace}}{$key}->{frozen} = $L2_value;
        $L1_cache{$self->{namespace}}{$key}->{thawed} = $thawed if $unsafe;
        return $thawed;
    }


    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );

    # Clear from L1 cache
    delete $L1_cache{$self->{namespace}}{$key};

    return $self->{$cache}->delete($key)
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );


sub flush_L1_cache {
    my( $self ) = @_;
    $L1_cache{$self->{namespace}} = ();
}

=head1 TIED INTERFACE




package Koha::Caches;

use Modern::Perl;
use Koha::Cache;

our $singleton_caches;
sub get_instance {
    my ($class, $subnamespace) = @_;
    $subnamespace //= '';
    $singleton_caches->{$subnamespace} = Koha::Cache->new({}, $subnamespace) unless $singleton_caches->{$subnamespace};
    return $singleton_caches->{$subnamespace};
}

sub flush_L1_caches {
    return unless $singleton_caches;
    for my $cache ( values %$singleton_caches ) {
        $cache->flush_L1_cache;
    }
}

1;

Lines 36-42 use C4::Languages; Link Here

(-)a/debian/templates/plack.psgi (-2 / +2 lines)
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	};

Lines 12-18 use CGI qw(-utf8 ); # we will lose -utf8 under plack Link Here

(-)a/misc/plack/koha.psgi (-2 / +2 lines)
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





use Modern::Perl;

use Test::More tests => 44;
use Test::Warn;

my $destructorcount = 0;

BEGIN {
    use_ok('Koha::Cache');
    use_ok('Koha::Caches');
    use_ok('Koha::Cache::Object');
    use_ok('Koha::Cache::Memory::Lite');
    use_ok('C4::Context');

    # Set a special namespace for testing, to avoid breaking
    # if test is run with a different user than Apache's.
    $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
    my $cache = Koha::Caches->get_instance();

    skip "Cache not enabled", 36
      unless ( $cache->is_cache_active() && defined $cache );


subtest 'Koha::Caches' => sub {
    plan tests => 8;
    my $default_cache = Koha::Caches->get_instance();
    my $another_cache = Koha::Caches->get_instance('another_cache');
    $default_cache->set_in_cache('key_a', 'value_a');
    $default_cache->set_in_cache('key_b', 'value_b');
    $another_cache->set_in_cache('key_a', 'another_value_a');

END {
  SKIP: {
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
        my $cache = Koha::Caches->get_instance();
        skip "Cache not enabled", 1
          unless ( $cache->is_cache_active() );
        is( $destructorcount, 1, 'Destructor run exactly once' );
- 

Return to bug 17189

Lines 54-60 our $L1_decoder = Sereal::Decoder->new; Link Here

(-)a/Koha/Cache.pm (-22 / +16 lines)
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

Lines 17-29 Link Here

(-)a/t/Cache.t (-6 / +6 lines)
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	-

Line 0 Link Here

(-)a/Koha/Caches.pm (+21 lines)
	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;