package Cache::Redis;
use 5.008_001;
use strict;
use warnings;
our $VERSION = '0.11';
use Module::Load;
my $_mp;
sub _mp {
$_mp ||= Data::MessagePack->new->utf8;
}
sub _mp_serialize {
_mp->pack(@_);
}
sub _mp_deserialize {
_mp->unpack(@_);
}
sub _mk_serialize {
my $code = shift;
return sub {
my $data = shift;
my $flags; # for future extention
my $store_date = [$data, $flags];
$code->($store_date);
};
}
sub _mk_deserialize {
my $code = shift;
return sub {
my $data = shift;
my ($org, $flags) = @{$code->($data)};
$org;
};
}
sub new {
my $class = shift;
my $args = @_ == 1 ? $_[0] : {@_};
my $default_expires_in = delete $args->{default_expires_in} || 60*60*24 * 30;
my $namespace = delete $args->{namespace} || '';
my $nowait = delete $args->{nowait} || 0;
my $redis_class = delete $args->{redis_class} || 'Redis';
my $redis = delete $args->{redis};
my $serializer = delete $args->{serializer};
my $serialize_methods = delete $args->{serialize_methods};
die '`serializer` and `serialize_methods` is exclusive option' if $serializer && $serialize_methods;
$serializer ||= 'Storable' unless $serialize_methods;
my ($serialize, $deserialize);
if ($serializer) {
if ($serializer eq 'Storable') {
require Storable;
$serialize_methods = [\&Storable::nfreeze, \&Storable::thaw];
}
elsif ($serializer eq 'JSON') {
require JSON::XS;
$serialize_methods = [\&JSON::XS::encode_json, \&JSON::XS::decode_json];
}
}
if ($serialize_methods) {
$serialize = _mk_serialize $serialize_methods->[0];
$deserialize = _mk_deserialize $serialize_methods->[1];
}
elsif ($serializer eq 'MessagePack') {
require Data::MessagePack;
$serialize = \&_mp_serialize;
$deserialize = \&_mp_deserialize;
}
die 'Serializer is not found' if !$serialize || !$deserialize;
unless ( $redis ) {
load $redis_class;
$redis = $redis_class->new(
encoding => undef,
%$args
);
}
bless {
default_expires_in => $default_expires_in,
serialize => $serialize,
deserialize => $deserialize,
redis => $redis,
namespace => $namespace,
nowait => $nowait,
}, $class;
}
sub get {
my ($self, $key) = @_;
$key = $self->{namespace} . $key;
my $data = $self->{redis}->get($key);
defined $data ? $self->{deserialize}->($data) : $data;
}
sub get_multi {
my ($self, @keys) = @_;
@keys = map { $self->{namespace} . $_ } @keys;
my @data = $self->{redis}->mget(@keys);
my $i = 0;
my $ret = {};
for my $key ( @keys ) {
if ( defined $data[$i] ) {
$ret->{$key} = $self->{deserialize}->($data[$i]);
}
$i++;
}
$ret;
}
sub set {
my ($self, $key, $value, $expire) = @_;
$self->_set($key, $value, $expire);
$self->{redis}->wait_all_responses unless $self->{nowait};
}
sub set_multi {
my ($self, @items) = @_;
for my $item ( @items ) {
$self->_set(@$item);
}
$self->{redis}->wait_all_responses unless $self->{nowait};
}
sub _set {
my ($self, $key, $value, $expire) = @_;
$key = $self->{namespace} . $key;
$expire ||= $self->{default_expires_in};
$self->{redis}->setex($key, $expire, $self->{serialize}->($value), sub {});
}
sub get_or_set {
my ($self, $key, $code, $expire) = @_;
my $data = $self->get($key);
unless (defined $data) {
$data = $code->();
$self->set($key, $data, $expire);
}
$data;
}
sub remove {
my ($self, $key) = @_;
my $data = $self->get($key);
$key = $self->{namespace} . $key;
$self->{redis}->del($key);
$data;
}
sub nowait_push {
shift->{redis}->wait_all_responses;
}
1;
__END__
=head1 NAME
Cache::Redis - Redis client specialized for cache
=head1 SYNOPSIS
use Cache::Redis;
my $cache = Cache::Redis->new(
server => 'localhost:9999',
namespace => 'cache:',
);
$cache->set('key', 'val');
my $val = $cache->get('key');
$cache->remove('key');
=head1 DESCRIPTION
This module is for cache of Redis backend having L<Cache::Cache> like interface.
B<THIS IS A DEVELOPMENT RELEASE. API MAY CHANGE WITHOUT NOTICE>.
=head1 INTERFACE
=head2 Methods
=head3 C<< my $obj = Cache::Redis->new(%options) >>
Create a new cache object. Various options may be set in C<%options>, which affect
the behaviour of the cache (defaults in parentheses):
=over
=item C<redis>
Instance of Redis class are used as backend. If this is not passed, L<Cache::Redis> load from C<redis_class> automatically.
=item C<redis_class ('Redis')>
The class for backend.
=item C<default_expires_in (60*60*24 * 30)>
The default expiration seconds for objects place in the cache.
=item C<namespace ('')>
The namespace associated with this cache.
=item C<nowait (0)>
If enabled, when you call a method that only returns its success status (like "set"), in a void context,
it sends the request to the server and returns immediately, not waiting the reply. This avoids the
round-trip latency at a cost of uncertain command outcome.
=item C<serializer ('Storable')>
Serializer. 'MessagePack' and 'Storable' are usable. if `serialize_methods` option
is specified, this option is ignored.
=item C<serialize_methods (undef)>
The value is a reference to an array holding two code references for serialization and
de-serialization routines respectively.
=item server (undef)
Redis server information. You can use `sock` option instead of this and can specify
all other L<Redis> constructor options to C<< Cache::Cache->new >> method.
=back
=head3 C<< $obj->set($key, $value, $expire) >>
Set a stuff to cache.
=head3 C<< $obj->set_multi([$key, $value, $expire], [$key, $value]) >>
Set multiple stuffs to cache. stuffs is array reference.
=head3 C<< my $stuff = $obj->get($key) >>
Get a stuff from cache.
=head3 C<< my $res = $obj->get_multi(@keys) >>
Get multiple stuffs as hash reference from cache. C<< @keys >> should be array.
A key is not stored on cache don't be contain C<< $res >>.
=head3 C<< $obj->remove($key) >>
Remove stuff of key from cache.
=head3 C<< $obj->get_or_set($key, $code, $expire) >>
Get a cache value for I<$key> if it's already cached. If it's not cached then,
run I<$code> and cache I<$expiration> seconds and return the value.
=head3 C<< $obj->nowait_push >>
Wait all response from Redis. This is intended for C<< $obj->nowait >>.
=head1 DEPENDENCIES
Perl 5.8.1 or later.
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 SEE ALSO
L<perl>
=head1 AUTHOR
Masayuki Matsuki E<lt>y.songmu@gmail.comE<gt>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2013, Masayuki Matsuki. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut