Attachment #28611 for bug #12041

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

Lines 99-105 sub GetOverDriveToken { Link Here

(-)a/C4/External/OverDrive.pm (-2 / +4 lines)
99		99
100	my $cache;	100	my $cache;
101		101
102	eval { $cache = Koha::Cache->new() };	102	eval { $cache = Koha::Cache->get_instance() };
103		103
104	my $token;	104	my $token;
105	$cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;	105	$cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;
Lines 124-130 sub GetOverDriveToken { Link Here
124	$token = $contents->{'token_type'} . ' ' . $contents->{'access_token'};	124	$token = $contents->{'token_type'} . ' ' . $contents->{'access_token'};
125		125
126	# Fudge factor to prevent spurious failures	126	# Fudge factor to prevent spurious failures
127	$cache and $cache->set_in_cache( 'overdrive_token', $token, $contents->{'expires_in'} - 5 );	127	$cache
		128	and $cache->set_in_cache( 'overdrive_token', $token,
		129	{ expiry => $contents->{'expires_in'} - 5 } );
128		130
129	return $token;	131	return $token;
130	}	132	}




=head1 DESCRIPTION

Koha caching routines. This class provides two interfaces for cache access.
The first, traditional OO interface provides the following functions:

=head1 FUNCTIONS

=cut

use strict;
use warnings;
use Carp;

__PACKAGE__->mk_ro_accessors(
    qw( cache memcached_cache fastmmap_cache memory_cache ));

=head2 get_instance

    my $cache = Koha::Cache->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
persistent across multiple instances.

=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.

        }
    }

    # Unless a default has already been picked, we go through in best-to-
    # least-best order, looking for something we can use. fastmmap_cache
    # is excluded because it doesn't support expiry in a useful way.
    unless ( defined( $self->{'cache'} ) ) {
        foreach my $cachemember (qw(memcached_cache memory_cache )) {
            if ( defined( $self->{$cachemember} ) ) {
                $self->{'cache'} = $self->{$cachemember};
                last;
            }
        }
    }

    $ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');

    return
      bless $self,

    my @servers =
      split /,/, $self->{'cache_servers'}
      ? $self->{'cache_servers'}
      : ($ENV{MEMCACHED_SERVERS} || '');
    return if !@servers;

    $ENV{DEBUG}
      && carp "Memcached server settings: "
      . join( ', ', @servers )
      . " with "
      . $self->{'namespace'};
    # Cache::Memcached::Fast doesn't allow a default expire time to be set
    # so we force it on setting.
    my $memcached = Cache::Memcached::Fast->new(
        {
            servers            => \@servers,
            compress_threshold => 10_000,
            namespace          => $self->{'namespace'},
            utf8               => 1,
        }
    );
    # Ensure we can actually talk to the memcached server
    my $ismemcached = $memcached->set('ismemcached','1');
    return $self unless $ismemcached;
    $self->{'memcached_cache'} = $memcached;
    return $self;
}


sub _initialize_memory {
    my ($self) = @_;

    # Default cache time for memory is _always_ short unless it's specially
    # defined, to allow it to work reliably in a persistent environment.
    my $cache = Cache::Memory->new(
        'namespace'       => $self->{'namespace'},
        'default_expires' => "$self->{'timeout'} sec" || "10 sec",
    );
    $self->{'memory_cache'} = $cache;
    # Memory cache can't handle complex types for some reason, so we use its
    # freeze and thaw functions.
    $self->{ref($cache) . '_set'} = sub {
        my ($key, $val, $exp) = @_;
        # Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
        $exp = "$exp sec" if defined $exp;
        # Because we need to use freeze, it must be a reference type.
        $cache->freeze($key, [$val], $exp);
    };
    $self->{ref($cache) . '_get'} = sub {
        my $res = $cache->thaw(shift);
        return unless defined $res;
        return $res->[0];
    };
    return $self;
}

=head2 is_cache_active

Routine that checks whether or not a default caching method is active on this
object.

=cut

sub is_cache_active {
    my $self = shift;
    return $self->{'cache'} ? 1 : 0;
}

=head2 set_in_cache

    $cache->set_in_cache($key, $value, [$options]);

Save a value to the specified key in the cache. A hashref of options may be
specified.

The possible options are:

=over

=item expiry

Expiry time of this cached entry in seconds.

=item deepcopy

If set, this will perform a deep copy of the item when it's retrieved. This
means that it'll be safe if something later modifies the result of the
function. Will be ignored in situations where the same behaviour comes from
the caching layer anyway.

=item cache

The cache object to use if you want to provide your own. It should be an
instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.

=cut

sub set_in_cache {
    my ( $self, $key, $value, $options, $_cache) = @_;
    # This is a bit of a hack to support the old API in case things still use it
    if (defined $options && (ref($options) ne 'HASH')) {
        my $new_options;
        $new_options->{expiry} = $options;
        $new_options->{cache} = $_cache if defined $_cache;
        $options = $new_options;
    }

    # the key mustn't contain whitespace (or control characters) for memcache
    # but shouldn't be any harm in applying it globally.
    $key =~ s/[\x00-\x20]/_/g;

    my $cache = $options->{cache} || 'cache';
    croak "No key" unless $key;
    $ENV{DEBUG} && carp "set_in_cache for $key";

    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
    my $expiry = $options->{expiry};
    $expiry //= $self->{timeout};
    my $set_sub = $self->{ref($self->{$cache}) . "_set"};
    # We consider an expiry of 0 to be inifinite
    if ( $expiry ) {
        return $set_sub
          ? $set_sub->( $key, $value, $expiry )
          : $self->{$cache}->set( $key, $value, $expiry );
    }
    else {
        return $set_sub
          ? $set_sub->( $key, $value )
          : $self->{$cache}->set( $key, $value );
    }
}



sub get_from_cache {
    my ( $self, $key, $cache ) = @_;
    $key =~ s/[\x00-\x20]/_/g;
    $cache ||= 'cache';
    croak "No key" unless $key;
    $ENV{DEBUG} && carp "get_from_cache for $key";
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
    my $get_sub = $self->{ref($self->{$cache}) . "_get"};
    return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
}

=head2 clear_from_cache


sub clear_from_cache {
    my ( $self, $key, $cache ) = @_;
    $key =~ s/[\x00-\x20]/_/g;
    $cache ||= 'cache';
    croak "No key" unless $key;
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
    return $self->{$cache}->delete($key)
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
    return $self->{$cache}->remove($key);
}


    $cache ||= 'cache';
    return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
    return $self->{$cache}->flush_all()
      if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
    return $self->{$cache}->clear();
}





        $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
        if ( defined( $self->{'cache'} ) ) {
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
                { expiry => $self->{'timeout'} } );
        }
        $self->{'lastupdate'} = time;
    }

    if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
        && $self->{'cache'} )
    {
        $self->{'value'} = $self->{'cache'}->get_from_cache( $self->{'key'} );
          $self->{'cache'}
          ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
        $self->{'lastupdate'} = $now;
    }


            $self->{'value'}, $index );
        if ( defined( $self->{'cache'} ) ) {
            $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
                { expiry => $self->{'timeout'} } );
        }
        $self->{'lastupdate'} = $now;
    }

        && $self->{'allowupdate'}
        && defined( $self->{'cache'} ) )
    {
        $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
            { expiry => $self->{'timeout'} },
        );
    }

    return $self->{'value'};

        && $self->{'unset'}
        && defined( $self->{'cache'} ) )
    {
        $self->{'cache'}->clear_from_cache( $self->{'key'} );
            $self->{'cache_type'} . '_cache' );
    }

    undef $self->{'value'};

Lines 37-43 sub new { Link Here

(-)a/Koha/Template/Plugin/Cache.pm (-2 / +3 lines)
37	}	37	}
38	else {	38	else {
39	require Koha::Cache;	39	require Koha::Cache;
40	$cache = Koha::Cache->new( { 'cache_type' => 'memcached', 'cache_servers' => C4::Context->config('memcached_servers') });	40	$cache = Koha::Cache->get_instance();
41	}	41	}
42	my $self = bless {	42	my $self = bless {
43	CACHE => $cache,	43	CACHE => $cache,
Lines 84-90 sub _cached_action { Link Here
84	my $result = $self->{CACHE}->get_from_cache($key);	84	my $result = $self->{CACHE}->get_from_cache($key);
85	if ( !$result ) {	85	if ( !$result ) {
86	$result = $self->{CONTEXT}->$action( $params->{template} );	86	$result = $self->{CONTEXT}->$action( $params->{template} );
87	$self->{CACHE}->set_in_cache( $key, $result, $params->{ttl} );	87	$self->{CACHE}
		88	->set_in_cache( $key, $result, { expiry => $params->{ttl} } );
88	}	89	}
89	return $result;	90	return $result;
90	}	91	}





my @sql_params  = $query->param('sql_params');

my $cache = Koha::Cache->get_instance();
my $cache_active = $cache->is_cache_active;
my ($cache_key, $json_text);
if ($cache_active) {
    $cache_key =
        "opac:report:"
      . ( $report_name ? "name:$report_name" : "id:$report_id" )
      . join( '-', @sql_params );
    $cache     = Koha::Cache->new();
    $json_text = $cache->get_from_cache($cache_key);
}



        if ($cache_active) {
            $cache->set_in_cache( $cache_key, $json_text,
                { expiry => $report_rec->{cache_expiry} } );
        }
    }
    else {




    }
);

my $cache = Koha::Cache->get_instance();
my $cache_active = $cache->is_cache_active;
my ($cache_key, $json_text);
if ($cache_active) {
    $cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id");
    $cache = Koha::Cache->new();
    $json_text = $cache->get_from_cache($cache_key);
}





use strict;
use warnings;

use Test::More tests => 32;

my $destructorcount = 0;


}

SKIP: {
    my $cache = Koha::Cache->get_instance();

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

    # test fetching an item that isnt in the cache
    is( $cache->get_from_cache("not in here"),


    $hash{'key'} = 'value';
    is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');

    # UTF8 testing
    my $utf8_str = "A Møøse once bit my sister";
    $cache->set_in_cache('utf8_1', $utf8_str);
    is($cache->get_from_cache('utf8_1'), $utf8_str, 'Simple 8-bit UTF8 correctly retrieved');
    $utf8_str = "\x{20ac}"; # €
    $cache->set_in_cache('utf8_1', $utf8_str);
    my $utf8_res = $cache->get_from_cache('utf8_1');
    # This'll ensure that we're getting a unicode string back, rather than
    # a couple of bytes.
    is(length($utf8_res), 1, 'UTF8 string length correct');
    # ...and that it's really the character we intend
    is(ord($utf8_res), 8364, 'UTF8 string value correct');
}

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

Return to bug 12041

Lines 71-77 sub TIESCALAR { Link Here

(-)a/Koha/Cache/Object.pm (-10 / +7 lines)
71	$self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );	71	$self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
72	if ( defined( $self->{'cache'} ) ) {	72	if ( defined( $self->{'cache'} ) ) {
73	$self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},	73	$self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
74	$self->{'timeout'}, $self->{'cache_type'} . '_cache' );	74	{ expiry => $self->{'timeout'} } );
75	}	75	}
76	$self->{'lastupdate'} = time;	76	$self->{'lastupdate'} = time;
77	}	77	}
Lines 90-98 sub FETCH { Link Here
90	if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )	90	if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
91	&& $self->{'cache'} )	91	&& $self->{'cache'} )
92	{	92	{
93	$self->{'value'} =	93	$self->{'value'} = $self->{'cache'}->get_from_cache( $self->{'key'} );
94	$self->{'cache'}
95	->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
96	$self->{'lastupdate'} = $now;	94	$self->{'lastupdate'} = $now;
97	}	95	}
98		96
Lines 106-112 sub FETCH { Link Here
106	$self->{'value'}, $index );	104	$self->{'value'}, $index );
107	if ( defined( $self->{'cache'} ) ) {	105	if ( defined( $self->{'cache'} ) ) {
108	$self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},	106	$self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
109	$self->{'timeout'}, $self->{'cache_type'} . '_cache' );	107	{ expiry => $self->{'timeout'} } );
110	}	108	}
111	$self->{'lastupdate'} = $now;	109	$self->{'lastupdate'} = $now;
112	}	110	}
Lines 130-138 sub STORE { Link Here
130	&& $self->{'allowupdate'}	128	&& $self->{'allowupdate'}
131	&& defined( $self->{'cache'} ) )	129	&& defined( $self->{'cache'} ) )
132	{	130	{
133	$self->{'cache'}	131	$self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
134	->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'},	132	{ expiry => $self->{'timeout'} },
135	$self->{'cache_type'} . '_cache' );	133	);
136	}	134	}
137		135
138	return $self->{'value'};	136	return $self->{'value'};
Lines 149-156 sub DESTROY { Link Here
149	&& $self->{'unset'}	147	&& $self->{'unset'}
150	&& defined( $self->{'cache'} ) )	148	&& defined( $self->{'cache'} ) )
151	{	149	{
152	$self->{'cache'}->clear_from_cache( $self->{'key'},	150	$self->{'cache'}->clear_from_cache( $self->{'key'} );
153	$self->{'cache_type'} . '_cache' );
154	}	151	}
155		152
156	undef $self->{'value'};	153	undef $self->{'value'};

Lines 41-54 die "Sorry this report is not public\n" unless $report_rec->{public}; Link Here

(-)a/opac/svc/report (-5 / +5 lines)
41		41
42	my @sql_params = $query->param('sql_params');	42	my @sql_params = $query->param('sql_params');
43		43
44	my $cache_active = Koha::Cache->is_cache_active;	44	my $cache = Koha::Cache->get_instance();
45	my ( $cache_key, $cache, $json_text );	45	my $cache_active = $cache->is_cache_active;
		46	my ($cache_key, $json_text);
46	if ($cache_active) {	47	if ($cache_active) {
47	$cache_key =	48	$cache_key =
48	"opac:report:"	49	"opac:report:"
49	. ( $report_name ? "name:$report_name" : "id:$report_id" )	50	. ( $report_name ? "name:$report_name" : "id:$report_id" )
50	. @sql_params;	51	. join( '-', @sql_params );
51	$cache = Koha::Cache->new();
52	$json_text = $cache->get_from_cache($cache_key);	52	$json_text = $cache->get_from_cache($cache_key);
53	}	53	}
54		54
Lines 74-80 unless ($json_text) { Link Here
74		74
75	if ($cache_active) {	75	if ($cache_active) {
76	$cache->set_in_cache( $cache_key, $json_text,	76	$cache->set_in_cache( $cache_key, $json_text,
77	$report_rec->{cache_expiry} );	77	{ expiry => $report_rec->{cache_expiry} } );
78	}	78	}
79	}	79	}
80	else {	80	else {

Lines 46-56 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here

(-)a/svc/report (-3 / +3 lines)
46	}	46	}
47	);	47	);
48		48
49	my $cache_active = Koha::Cache->is_cache_active;	49	my $cache = Koha::Cache->get_instance();
50	my ($cache_key, $cache, $json_text);	50	my $cache_active = $cache->is_cache_active;
		51	my ($cache_key, $json_text);
51	if ($cache_active) {	52	if ($cache_active) {
52	$cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id");	53	$cache_key = "intranet:report:".($report_name ? "name:$report_name" : "id:$report_id");
53	$cache = Koha::Cache->new();
54	$json_text = $cache->get_from_cache($cache_key);	54	$json_text = $cache->get_from_cache($cache_key);
55	}	55	}
56		56

Lines 5-11 Link Here

(-)a/t/Cache.t (-6 / +19 lines)
5	use strict;	5	use strict;
6	use warnings;	6	use warnings;
7		7
8	use Test::More tests => 29;	8	use Test::More tests => 32;
9		9
10	my $destructorcount = 0;	10	my $destructorcount = 0;
11		11
Lines 16-25 BEGIN { Link Here
16	}	16	}
17		17
18	SKIP: {	18	SKIP: {
19	my $cache = Koha::Cache->new();	19	my $cache = Koha::Cache->get_instance();
20		20
21	skip "Cache not enabled", 25	21	skip "Cache not enabled", 28
22	unless ( Koha::Cache->is_cache_active() && defined $cache );	22	unless ( $cache->is_cache_active() && defined $cache );
23		23
24	# test fetching an item that isnt in the cache	24	# test fetching an item that isnt in the cache
25	is( $cache->get_from_cache("not in here"),	25	is( $cache->get_from_cache("not in here"),
Lines 134-145 SKIP: { Link Here
134		134
135	$hash{'key'} = 'value';	135	$hash{'key'} = 'value';
136	is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');	136	is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
		137
		138	# UTF8 testing
		139	my $utf8_str = "A Møøse once bit my sister";
		140	$cache->set_in_cache('utf8_1', $utf8_str);
		141	is($cache->get_from_cache('utf8_1'), $utf8_str, 'Simple 8-bit UTF8 correctly retrieved');
		142	$utf8_str = "\x{20ac}"; # €
		143	$cache->set_in_cache('utf8_1', $utf8_str);
		144	my $utf8_res = $cache->get_from_cache('utf8_1');
		145	# This'll ensure that we're getting a unicode string back, rather than
		146	# a couple of bytes.
		147	is(length($utf8_res), 1, 'UTF8 string length correct');
		148	# ...and that it's really the character we intend
		149	is(ord($utf8_res), 8364, 'UTF8 string value correct');
137	}	150	}
138		151
139	END {	152	END {
140	SKIP: {	153	SKIP: {
		154	my $cache = Koha::Cache->get_instance();
141	skip "Cache not enabled", 1	155	skip "Cache not enabled", 1
142	unless ( Koha::Cache->is_cache_active() );	156	unless ( $cache->is_cache_active() );
143	is( $destructorcount, 1, 'Destructor run exactly once' );	157	is( $destructorcount, 1, 'Destructor run exactly once' );
144	}	158	}
145	}	159	}
146	-

Lines 30-41 Koha::Cache - Handling caching of html and Objects for Koha Link Here

(-)a/Koha/Cache.pm (-32 / +118 lines)
30	=head1 DESCRIPTION	30	=head1 DESCRIPTION
31		31
32	Koha caching routines. This class provides two interfaces for cache access.	32	Koha caching routines. This class provides two interfaces for cache access.
33	The first, traditional interface provides the following functions:	33	The first, traditional OO interface provides the following functions:
34		34
35	=head1 FUNCTIONS	35	=head1 FUNCTIONS
36		36
37	=cut	37	=cut
38
39	use strict;	38	use strict;
40	use warnings;	39	use warnings;
41	use Carp;	40	use Carp;
Lines 47-52 use base qw(Class::Accessor); Link Here
47	__PACKAGE__->mk_ro_accessors(	46	__PACKAGE__->mk_ro_accessors(
48	qw( cache memcached_cache fastmmap_cache memory_cache ));	47	qw( cache memcached_cache fastmmap_cache memory_cache ));
49		48
		49	=head2 get_instance
		50
		51	my $cache = Koha::Cache->get_instance();
		52
		53	This gets a shared instance of the cache, set up in a very default way. This is
		54	the recommended way to fetch a cache object. If possible, it'll be
		55	persistent across multiple instances.
		56
		57	=cut
		58
		59	our $singleton_cache;
		60	sub get_instance {
		61	my ($class) = @_;
		62	$singleton_cache = $class->new() unless $singleton_cache;
		63	return $singleton_cache;
		64	}
		65
50	=head2 new	66	=head2 new
51		67
52	Create a new Koha::Cache object. This is required for all cache-related functionality.	68	Create a new Koha::Cache object. This is required for all cache-related functionality.
Lines 92-106 sub new { Link Here
92	}	108	}
93	}	109	}
94		110
95	# NOTE: The following five lines could be uncommented if we wanted to	111	# Unless a default has already been picked, we go through in best-to-
96	# fall back to any functioning cache. Commented out since this would	112	# least-best order, looking for something we can use. fastmmap_cache
97	# represent a change in behavior.	113	# is excluded because it doesn't support expiry in a useful way.
98	#	114	unless ( defined( $self->{'cache'} ) ) {
99	#unless (defined($self->{'cache'})) {	115	foreach my $cachemember (qw(memcached_cache memory_cache )) {
100	# foreach my $cachemember (qw(memory_cache fastmmap_cache memcached_cache)) {	116	if ( defined( $self->{$cachemember} ) ) {
101	# $self->{'cache'} = $self->{$cachemember} if (defined($self->{$cachemember}));	117	$self->{'cache'} = $self->{$cachemember};
102	# }	118	last;
103	#}	119	}
		120	}
		121	}
		122
		123	$ENV{DEBUG} && carp "Selected caching system: " . ($self->{'cache'} // 'none');
104		124
105	return	125	return
106	bless $self,	126	bless $self,
Lines 112-131 sub _initialize_memcached { Link Here
112	my @servers =	132	my @servers =
113	split /,/, $self->{'cache_servers'}	133	split /,/, $self->{'cache_servers'}
114	? $self->{'cache_servers'}	134	? $self->{'cache_servers'}
115	: $ENV{MEMCACHED_SERVERS};	135	: ($ENV{MEMCACHED_SERVERS} \|\| '');
		136	return if !@servers;
116		137
117	$ENV{DEBUG}	138	$ENV{DEBUG}
118	&& carp "Memcached server settings: "	139	&& carp "Memcached server settings: "
119	. join( ', ', @servers )	140	. join( ', ', @servers )
120	. " with "	141	. " with "
121	. $self->{'namespace'};	142	. $self->{'namespace'};
122	$self->{'memcached_cache'} = Cache::Memcached::Fast->new(	143	# Cache::Memcached::Fast doesn't allow a default expire time to be set
		144	# so we force it on setting.
		145	my $memcached = Cache::Memcached::Fast->new(
123	{	146	{
124	servers => \@servers,	147	servers => \@servers,
125	compress_threshold => 10_000,	148	compress_threshold => 10_000,
126	namespace => $self->{'namespace'},	149	namespace => $self->{'namespace'},
		150	utf8 => 1,
127	}	151	}
128	);	152	);
		153	# Ensure we can actually talk to the memcached server
		154	my $ismemcached = $memcached->set('ismemcached','1');
		155	return $self unless $ismemcached;
		156	$self->{'memcached_cache'} = $memcached;
129	return $self;	157	return $self;
130	}	158	}
131		159
Lines 143-190 sub _initialize_fastmmap { Link Here
143	sub _initialize_memory {	171	sub _initialize_memory {
144	my ($self) = @_;	172	my ($self) = @_;
145		173
146	$self->{'memory_cache'} = Cache::Memory->new(	174	# Default cache time for memory is _always_ short unless it's specially
		175	# defined, to allow it to work reliably in a persistent environment.
		176	my $cache = Cache::Memory->new(
147	'namespace' => $self->{'namespace'},	177	'namespace' => $self->{'namespace'},
148	'default_expires' => $self->{'timeout'}	178	'default_expires' => "$self->{'timeout'} sec" \|\| "10 sec",
149	);	179	);
		180	$self->{'memory_cache'} = $cache;
		181	# Memory cache can't handle complex types for some reason, so we use its
		182	# freeze and thaw functions.
		183	$self->{ref($cache) . '_set'} = sub {
		184	my ($key, $val, $exp) = @_;
		185	# Refer to set_expiry in Cache::Entry for why we do this 'sec' thing.
		186	$exp = "$exp sec" if defined $exp;
		187	# Because we need to use freeze, it must be a reference type.
		188	$cache->freeze($key, [$val], $exp);
		189	};
		190	$self->{ref($cache) . '_get'} = sub {
		191	my $res = $cache->thaw(shift);
		192	return unless defined $res;
		193	return $res->[0];
		194	};
150	return $self;	195	return $self;
151	}	196	}
152		197
153	=head2 is_cache_active	198	=head2 is_cache_active
154		199
155	Routine that checks whether or not a caching system has been selected. This is	200	Routine that checks whether or not a default caching method is active on this
156	not an instance method.	201	object.
157		202
158	=cut	203	=cut
159		204
160	sub is_cache_active {	205	sub is_cache_active {
161	return $ENV{CACHING_SYSTEM} ? '1' : '';	206	my $self = shift;
		207	return $self->{'cache'} ? 1 : 0;
162	}	208	}
163		209
164	=head2 set_in_cache	210	=head2 set_in_cache
165		211
166	$cache->set_in_cache($key, $value, [$expiry]);	212	$cache->set_in_cache($key, $value, [$options]);
		213
		214	Save a value to the specified key in the cache. A hashref of options may be
		215	specified.
167		216
168	Save a value to the specified key in the default cache, optionally with a	217	The possible options are:
169	particular expiry.	218
		219	=over
		220
		221	=item expiry
		222
		223	Expiry time of this cached entry in seconds.
		224
		225	=item deepcopy
		226
		227	If set, this will perform a deep copy of the item when it's retrieved. This
		228	means that it'll be safe if something later modifies the result of the
		229	function. Will be ignored in situations where the same behaviour comes from
		230	the caching layer anyway.
		231
		232	=item cache
		233
		234	The cache object to use if you want to provide your own. It should be an
		235	instance of C<Cache::*> and follow the same interface as L<Cache::Memcache>.
170		236
171	=cut	237	=cut
172		238
173	sub set_in_cache {	239	sub set_in_cache {
174	my ( $self, $key, $value, $expiry, $cache ) = @_;	240	my ( $self, $key, $value, $options, $_cache) = @_;
175	$cache \|\|= 'cache';	241	# This is a bit of a hack to support the old API in case things still use it
		242	if (defined $options && (ref($options) ne 'HASH')) {
		243	my $new_options;
		244	$new_options->{expiry} = $options;
		245	$new_options->{cache} = $_cache if defined $_cache;
		246	$options = $new_options;
		247	}
		248
		249	# the key mustn't contain whitespace (or control characters) for memcache
		250	# but shouldn't be any harm in applying it globally.
		251	$key =~ s/[\x00-\x20]/_/g;
		252
		253	my $cache = $options->{cache} \|\| 'cache';
176	croak "No key" unless $key;	254	croak "No key" unless $key;
177	$ENV{DEBUG} && carp "set_in_cache for $key";	255	$ENV{DEBUG} && carp "set_in_cache for $key";
178		256
179	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	257	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
180	if ( defined $expiry ) {	258	my $expiry = $options->{expiry};
181	if ( ref( $self->{$cache} ) eq 'Cache::Memory' ) {	259	$expiry //= $self->{timeout};
182	$expiry = "$expiry sec";	260	my $set_sub = $self->{ref($self->{$cache}) . "_set"};
183	}	261	# We consider an expiry of 0 to be inifinite
184	return $self->{$cache}->set( $key, $value, $expiry );	262	if ( $expiry ) {
		263	return $set_sub
		264	? $set_sub->( $key, $value, $expiry )
		265	: $self->{$cache}->set( $key, $value, $expiry );
185	}	266	}
186	else {	267	else {
187	return $self->{$cache}->set( $key, $value );	268	return $set_sub
		269	? $set_sub->( $key, $value )
		270	: $self->{$cache}->set( $key, $value );
188	}	271	}
189	}	272	}
190		273
Lines 198-208 Retrieve the value stored under the specified key in the default cache. Link Here
198		281
199	sub get_from_cache {	282	sub get_from_cache {
200	my ( $self, $key, $cache ) = @_;	283	my ( $self, $key, $cache ) = @_;
		284	$key =~ s/[\x00-\x20]/_/g;
201	$cache \|\|= 'cache';	285	$cache \|\|= 'cache';
202	croak "No key" unless $key;	286	croak "No key" unless $key;
203	$ENV{DEBUG} && carp "get_from_cache for $key";	287	$ENV{DEBUG} && carp "get_from_cache for $key";
204	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	288	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
205	return $self->{$cache}->get($key);	289	my $get_sub = $self->{ref($self->{$cache}) . "_get"};
		290	return $get_sub ? $get_sub->($key) : $self->{$cache}->get($key);
206	}	291	}
207		292
208	=head2 clear_from_cache	293	=head2 clear_from_cache
Lines 215-225 Remove the value identified by the specified key from the default cache. Link Here
215		300
216	sub clear_from_cache {	301	sub clear_from_cache {
217	my ( $self, $key, $cache ) = @_;	302	my ( $self, $key, $cache ) = @_;
		303	$key =~ s/[\x00-\x20]/_/g;
218	$cache \|\|= 'cache';	304	$cache \|\|= 'cache';
219	croak "No key" unless $key;	305	croak "No key" unless $key;
220	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	306	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
221	return $self->{$cache}->delete($key)	307	return $self->{$cache}->delete($key)
222	if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );	308	if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
223	return $self->{$cache}->remove($key);	309	return $self->{$cache}->remove($key);
224	}	310	}
225		311
Lines 236-242 sub flush_all { Link Here
236	$cache \|\|= 'cache';	322	$cache \|\|= 'cache';
237	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );	323	return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ );
238	return $self->{$cache}->flush_all()	324	return $self->{$cache}->flush_all()
239	if ( ref( $self->{$cache} ) eq 'Cache::Memcached::Fast' );	325	if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' );
240	return $self->{$cache}->clear();	326	return $self->{$cache}->clear();
241	}	327	}
242		328