Group :: Development/Perl
RPM: perl-Cache-Memcached
Navigation
Main Changelog Spec Patches Sources Download Gear Bugs and FR Repocop
Cache-Memcached-1.30/ 0000755 0000000 0000000 00000000000 12036531447 0014307 5 ustar 00root root 0000000 0000000 Cache-Memcached-1.30/ChangeLog 0000644 0000000 0000000 00000023126 12036531447 0016065 0 ustar 00root root 0000000 0000000 2012-05-19: version 1.30
* Fix buck2sock corruption that causes errors like
"No map found matching for GLOB" or "No sock found for" (hachi@cpan.org)
https://rt.cpan.org/Ticket/Display.html?id=62872
* Fix t/05_reconnect_timeout.t to not fail on networks that fast-reject
TEST-NET-1 https://rt.cpan.org/Ticket/Display.html?id=74500
* Fix warning about undefined value in GetParser.pm (kost@ropnet.ru)
https://rt.cpan.org/Ticket/Display.html?id=31067
* Add documentation of connect_timeout and select_timeout
https://rt.cpan.org/Ticket/Display.html?id=30904
2010-06-17: version 1.29
* fix warnings spew if calling stats on a down server
* fix buck2sock confusion (Eddie Canales)
* quell ipv6-related warning
https://rt.cpan.org/Ticket/Display.html?id=51761
2009-10-21: version 1.28
* IPv6 support (https://rt.cpan.org/Ticket/Display.html?id=50577)
* Add Encode.pm requirement to Makefile.PL for perl 5.6.x (Ask).
2009-09-22: version 1.27
* Fix get() with utf-8 keys (athomason)
* "stats malloc" command is gone in 1.4; remove those tests (athomason)
* Add append/prepend support (dormando)
* Fix occasional failure in the 100_flush_bug.t test (Ask Bjørn Hansen)
2009-05-04: version 1.26
* don't include "stats sizes" by default in the stats method,
as that can hang big servers for a few seconds (Brad Fitzpatrick)
2009-05-02: version 1.25
* Clear @buck2sock when calling disconnect_all. (Dennis Stosberg,
[rt.cpan.org #45560]
* Reconnects to a dead connection shouldn't happen every time when the
connection has never succeded. Apply the dead timeout to sockets that
never even came up. Add a test.
* Warn when trying to put undef values into memcache.
(Henry Lyne <hlyne@livejournalinc.com>)
* flush_all now only returns success if there is a proper reply from all
servers - Yann Kerherve <yann@sixapart.com>
* 'noreply' support from Tomash Brechko <tomash.brechko@gmail.com>
* various test updates from Ronald J Kimball <rkimball@pangeamedia.com>
2007-07-17: version 1.24
* update the stats method, including tests for it
(Ronald J Kimball <rkimball+memcached@pangeamedia.com>)
* arguments to 'new' constructor can be %hash or $hashref now
(previously was only $hashref)
* work around a Perl segfault (Matthieu PATOU <mp@oxado.com>)
see http://lists.danga.com/pipermail/memcached/2007-June/004511.html
2007-06-19: version 1.23
* add 'remove' as an alias for 'delete' (Dave Cardwell <dave@davecardwell.co.uk>)
2007-06-18: version 1.22
* lost connection handling broken due to wrong %sock_map indexing
http://rt.cpan.org/Public/Bug/Display.html?id=27181
fix from RHESA
* let parser_class be configured as a constructor option,
defaulting to XS if available, else regular. (unless
$ENV{NO_XS} is set, in which case the default is regular)
2007-05-02: version 1.21
* new faster optional interface for GetParser subclasses. doing
this release so upcoming Cache::Memcached::GetParserXS can
depend on this. otherwise this release isn't interesting.
2007-04-16: version 1.20
* fix "Warning produced when flush_all called" from CDENT
http://rt.cpan.org/Public/Bug/Display.html?id=22181
* support access via unix domain sockets. (Nathan Neulinger <nneul@umr.edu>)
* abstract out response parsing into own class, and add XS-module
detection, so if you have the XS (C) version, things'll be faster.
that part's not done yet.
2006-07-03
* don't use dual scalar/glob sockets. makes it all profilable
again under SmallProf, DProf, and Devel::Profiler, all three
of which used to barf on those weird sockets previously
* only init_buckets once, when servers are changed
* don't call sock_to_host and get_sock as much: cache closer
in get_multi
* more internal caching (buck2sock, etc)
* fast paths for namespaces/single sock/etc in a few more places
* general micro-speedups all over
2006-06-27
* patch from Maxim Dounin <mdounin@rambler-co.ru> to fix a typo
which caused no_rehash flag to not work.
* release 1.18
2006-04-29
* flush_all command from Patrick Michael Kane <modus-memcache@pr.es.to>
* document namespaces
* release 1.17
2006-04-29
* fix stats method (people have only been asking since 2004 :-/)
* add tests
* move Memcached to lib/Cache directory to be more CPAN-friendly
* release 1.16
2005-09-20
* configurable connect delays and callback on connect failure (brad)
* release 1.15
2005-08-09
* _connect_sock never works in blocking mode because of a bug in setting
the default timeout. (Gaal)
2004-07-27
* release 1.14
2004-07-27
* kill buggy, slow ord() _hashfunc, replace with crc32.
this adds String::CRC32 as a dependency. thanks to
everybody's feedback on the mailing list.
2004-07-19
* don't use pos() because it doesn't seem to work in
taint mode. use $+[0] instead. (Dave Evans <..@djce.org.uk>)
2004-06-19
* support multiple paths to memcache nodes (Brad)
see 'set_pref_ip'
2004-05-30
* release version 1.13
2004-05-26 (Whitaker <whitaker@danga.com>)
* quiet warning
2004-05-25 (Whitaker <whitaker@danga.com>)
* get_multi shouldn't modify caller's @_
2004-05-18 (Michael <ged@danga.com>)
* namespace support
* use fields
2004-05-16 (Alexei Kozlov <kozlov@w-m.ru>)
* remove warnings with vec
2004-04-09 (brad)
* in perl 5.6, trap errors dethawing 5.8 storable objects
and instead treat it like a cache miss
2004-04-01
* use $! and not %! for perl 5.6 compat (Dave Evans <..@djce.org.uk>)
* don't mark whole IP dead anymore when a node is down (Jason Titus <jtitus@postini.com>)
* start version numbering (Jamie McCarthy <jamie@mccarthy.vg>)
2004-03-09 (Brad/Avva)
* _oneline can return more than one line (but always on a line break),
so caller must decide when it's really time to quit. had to modify
run_command to know that. (which is used by stats)
2004-03-05 (Dave Evans <..@djce.org.uk>)
* Here's a really trivial patch for the Perl binding,
Cache::Memcached. The bug is that the module assumes that the
currently select()ed filehandle is STDOUT, but this might not be
the case. So this patch ensures that the select()ed filehandle is
preserved, not forced to STDOUT.
2004-02-29 (Brad)
* add readonly option
2004-02-27 (Avva)
* Cleaner handling of the case when _oneline is called without a
line parameter (i.e. not to send anything, just read a line from
the socket). Make it depend on $line being defined only,
regardless of its content (thanks Brad!).
2004-02-25 (Avva)
* Asyncify all I/O, finally get rid of alarm() yuckiness, unify all
one-liner command/responses into a single internal API.
2004-02-17
* document in POD the delete method
2004-02-03
* fix bug with 2k read boundaries falling in the middle
of "VALUE ..." or "END" lines, thus halting future
parsing and responses. (eek!)
* version 1.0.12
2003-12-01
* merge stats/stats_reset patch from Jamie McCarthy
* trailing whitespace cleanup
2003-11-08
* work on Solaris/BSD where there's no MSG_NOSIGNAL.
the expense is extra syscalls to change the local
SIGPIPE handler all the time. in the future, it'd
be nice to have an option so Solaris/BSD callers
can say, "Hey, I've turned off SIGPIPE globally,
don't worry about it."
2003-10-26
* add a test file, so automated CPAN test hosts are happy
* check MSG_NOSIGNAL immediately on module load, not on use,
so Solaris dies early. (still on TODO to fix, but better
to fail loudly)
* version 1.0.11
2003-10-25
* version 1.0.10, rename to Cache::Memcached, upload to CPAN
2003-10-18
* implement read/write timeouts everywhere. Now the client shouldn't
hang if the server machine goes down unexpectedly. (avva)
2003-10-16
* use Storable::nfreeze instead of freeze, so hosts from different
architectures can all use the same data. (all must use Perl, though.
the different memcache APIs all store/pickle/serialize data differently)
Suggestion by Jason Titus <jtitus@postini.com>
2003-10-06
* fix _incrdecr to return complete number, not just first
digit (thanks to Ryan T. Dean)
* release version 1.0.9
2003-10-04
* document expiration times in POD (thanks to Tim Bunce
for noting the omission)
* release version 1.0.8
2003-10-03
* add connect timeout of 0.25s, for dead host detection.
We had 1 second a couple revs ago, but lost it when
ditching IO::Socket module. (avva)
2003-10-02
* fix _incrdecr with explicit-hashvalue keys (whitaker)
2003-10-01
* add run_command API call. TODO: document, and document
the $exptime on the setters
2003-09-30
* use send instead of print, so we can set MSG_NOSIGNAL
and not get SIGPIPES, which avoids 3 syscalls of localizing
$SIG{PIPE} and sends everything at once, instead of 4k
stdio chunks. in review: stdio buffered in, send unbuffered
out. TODO: setvbuf so reads are buffered at more than 4k.
2003-09-29
* yet faster parsing
* switch to stdio/perlio instead of raw io: more correct,
simpler parsing code.
2003-09-28
* prevent some warnings
* faster get() call that doesn't use get_multi()
* optimizations for single-server case
* use socket APIs directly, instead of uber-slow IO::* modules
* new faster _load_items parsing
2003-09-04
* emit debug when set/add/replace fails, in addition to succeed
Version 1.0.7
-- compression support (Brad Whitaker)
Version 1.0.6
-- incr/decr client support
-- make delete optionally take second argument (server now supports
a delay time on delete)
-- doc updates from Jamie McCarthy
-- better hashing after dead host detection: new requests go to different
remaining hosts, instead of all to the same one.
Version 1.0.2
-- initial release, about.
Cache-Memcached-1.30/MANIFEST 0000644 0000000 0000000 00000000640 12036531447 0015440 0 ustar 00root root 0000000 0000000 ChangeLog
MANIFEST
MANIFEST.SKIP
Makefile.PL
README
TODO
lib/Cache/Memcached.pm
lib/Cache/Memcached/GetParser.pm
t/01_use.t
t/02_keys.t
t/03_stats.t
t/04_noreply.t
t/05_reconnect_timeout.t
t/06_utf8_key.t
t/100_flush_bug.t
t/101_multiple_clients.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
Cache-Memcached-1.30/MANIFEST.SKIP 0000644 0000000 0000000 00000000466 12036531447 0016213 0 ustar 00root root 0000000 0000000 ^dev/
# Avoid version control files.
\bRCS\b
\bCVS\b
,v$
\B\.svn\b
\.git
# Avoid Makemaker generated and utility files.
\bMANIFEST\.bak
\bMakefile$
\bblib/
\bMakeMaker-\d
\bpm_to_blib$
# Avoid Module::Build generated and utility files.
\bBuild$
\b_build/
# Avoid temp and backup files.
~$
\.old$
\#$
\b\.#
Cache-Memcached-1.30/META.json 0000644 0000000 0000000 00000001731 12036531447 0015732 0 ustar 00root root 0000000 0000000 {
"abstract" : "client library for memcached (memory cache daemon)",
"author" : [
"Brad Fitzpatrick <brad@danga.com>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "Cache-Memcached",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : 0
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : 0
}
},
"runtime" : {
"requires" : {
"Encode" : 0,
"Storable" : 0,
"String::CRC32" : 0,
"Time::HiRes" : 0
}
}
},
"release_status" : "stable",
"version" : "1.30"
}
Cache-Memcached-1.30/META.yml 0000644 0000000 0000000 00000001063 12036531447 0015560 0 ustar 00root root 0000000 0000000 ---
abstract: 'client library for memcached (memory cache daemon)'
author:
- 'Brad Fitzpatrick <brad@danga.com>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112621'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: Cache-Memcached
no_index:
directory:
- t
- inc
requires:
Encode: 0
Storable: 0
String::CRC32: 0
Time::HiRes: 0
version: 1.30
Cache-Memcached-1.30/Makefile.PL 0000644 0000000 0000000 00000001026 12036531447 0016260 0 ustar 00root root 0000000 0000000 use ExtUtils::MakeMaker;
WriteMakefile( 'NAME' => 'Cache::Memcached',
'VERSION_FROM' => 'lib/Cache/Memcached.pm',
'PREREQ_PM' => {
'Storable' => 0,
'Time::HiRes' => 0,
'String::CRC32' => 0,
'Encode' => 0,
},
($] >= 5.005 ?
(ABSTRACT_FROM => 'lib/Cache/Memcached.pm',
AUTHOR => 'Brad Fitzpatrick <brad@danga.com>') : ()),
);
Cache-Memcached-1.30/README 0000644 0000000 0000000 00000000501 12036531447 0015163 0 ustar 00root root 0000000 0000000 This is the Perl API for memcached, a distributed memory cache daemon.
See the documentation within the module for details on its use.
Information on the big picture is available at:
http://www.danga.com/memcached/
Feel free to join the mailing list and ask any questions.
--
Brad Fitzpatrick
brad@danga.com
Cache-Memcached-1.30/TODO 0000644 0000000 0000000 00000000024 12036531447 0014773 0 ustar 00root root 0000000 0000000 (currently empty)
Cache-Memcached-1.30/lib/ 0000755 0000000 0000000 00000000000 12036531447 0015055 5 ustar 00root root 0000000 0000000 Cache-Memcached-1.30/lib/Cache/ 0000755 0000000 0000000 00000000000 12036531447 0016060 5 ustar 00root root 0000000 0000000 Cache-Memcached-1.30/lib/Cache/Memcached.pm 0000644 0000000 0000000 00000113044 12036531447 0020267 0 ustar 00root root 0000000 0000000 # $Id$
#
# Copyright (c) 2003, 2004 Brad Fitzpatrick <brad@danga.com>
#
# See COPYRIGHT section in pod text below for usage and distribution rights.
#
package Cache::Memcached;
use strict;
use warnings;
no strict 'refs';
use Storable ();
use Socket qw( MSG_NOSIGNAL PF_INET PF_UNIX IPPROTO_TCP SOCK_STREAM );
use IO::Handle ();
use Time::HiRes ();
use String::CRC32;
use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN );
use Cache::Memcached::GetParser;
use Encode ();
use fields qw{
debug no_rehash stats compress_threshold compress_enable stat_callback
readonly select_timeout namespace namespace_len servers active buckets
pref_ip
bucketcount _single_sock _stime
connect_timeout cb_connect_fail
parser_class
buck2sock buck2sock_generation
};
# flag definitions
use constant F_STORABLE => 1;
use constant F_COMPRESS => 2;
# size savings required before saving compressed value
use constant COMPRESS_SAVINGS => 0.20; # percent
use vars qw($VERSION $HAVE_ZLIB $FLAG_NOSIGNAL $HAVE_SOCKET6);
$VERSION = "1.30";
BEGIN {
$HAVE_ZLIB = eval "use Compress::Zlib (); 1;";
$HAVE_SOCKET6 = eval "use Socket6 qw(AF_INET6 PF_INET6); 1;";
}
my $HAVE_XS = eval "use Cache::Memcached::GetParserXS; 1;";
$HAVE_XS = 0 if $ENV{NO_XS};
my $parser_class = $HAVE_XS ? "Cache::Memcached::GetParserXS" : "Cache::Memcached::GetParser";
if ($ENV{XS_DEBUG}) {
print "using parser: $parser_class\n";
}
$FLAG_NOSIGNAL = 0;
eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; };
my %host_dead; # host -> unixtime marked dead until
my %cache_sock; # host -> socket
my $socket_cache_generation = 1; # Set to 1 here because below the buck2sock_generation is set to 0, keep them in order.
my $PROTO_TCP;
our $SOCK_TIMEOUT = 2.6; # default timeout in seconds
sub new {
my Cache::Memcached $self = shift;
$self = fields::new( $self ) unless ref $self;
my $args = (@_ == 1) ? shift : { @_ }; # hashref-ify args
$self->{'buck2sock'}= [];
$self->{'buck2sock_generation'} = 0;
$self->set_servers($args->{'servers'});
$self->{'debug'} = $args->{'debug'} || 0;
$self->{'no_rehash'} = $args->{'no_rehash'};
$self->{'stats'} = {};
$self->{'pref_ip'} = $args->{'pref_ip'} || {};
$self->{'compress_threshold'} = $args->{'compress_threshold'};
$self->{'compress_enable'} = 1;
$self->{'stat_callback'} = $args->{'stat_callback'} || undef;
$self->{'readonly'} = $args->{'readonly'};
$self->{'parser_class'} = $args->{'parser_class'} || $parser_class;
# TODO: undocumented
$self->{'connect_timeout'} = $args->{'connect_timeout'} || 0.25;
$self->{'select_timeout'} = $args->{'select_timeout'} || 1.0;
$self->{namespace} = $args->{namespace} || '';
$self->{namespace_len} = length $self->{namespace};
return $self;
}
sub set_pref_ip {
my Cache::Memcached $self = shift;
$self->{'pref_ip'} = shift;
}
sub set_servers {
my Cache::Memcached $self = shift;
my ($list) = @_;
$self->{'servers'} = $list || [];
$self->{'active'} = scalar @{$self->{'servers'}};
$self->{'buckets'} = undef;
$self->{'bucketcount'} = 0;
$self->init_buckets;
# We didn't close any sockets, so we reset the buck2sock generation, not increment the global socket cache generation.
$self->{'buck2sock_generation'} = 0;
$self->{'_single_sock'} = undef;
if (@{$self->{'servers'}} == 1) {
$self->{'_single_sock'} = $self->{'servers'}[0];
}
return $self;
}
sub set_cb_connect_fail {
my Cache::Memcached $self = shift;
$self->{'cb_connect_fail'} = shift;
}
sub set_connect_timeout {
my Cache::Memcached $self = shift;
$self->{'connect_timeout'} = shift;
}
sub set_debug {
my Cache::Memcached $self = shift;
my ($dbg) = @_;
$self->{'debug'} = $dbg || 0;
}
sub set_readonly {
my Cache::Memcached $self = shift;
my ($ro) = @_;
$self->{'readonly'} = $ro;
}
sub set_norehash {
my Cache::Memcached $self = shift;
my ($val) = @_;
$self->{'no_rehash'} = $val;
}
sub set_compress_threshold {
my Cache::Memcached $self = shift;
my ($thresh) = @_;
$self->{'compress_threshold'} = $thresh;
}
sub enable_compress {
my Cache::Memcached $self = shift;
my ($enable) = @_;
$self->{'compress_enable'} = $enable;
}
sub forget_dead_hosts {
my Cache::Memcached $self = shift;
%host_dead = ();
# We need to globally recalculate our buck2sock in all objects, so we increment the global generation.
$socket_cache_generation++;
return 1;
}
sub set_stat_callback {
my Cache::Memcached $self = shift;
my ($stat_callback) = @_;
$self->{'stat_callback'} = $stat_callback;
}
my %sock_map; # stringified-$sock -> "$ip:$port"
sub _dead_sock {
my ($self, $sock, $ret, $dead_for) = @_;
if (my $ipport = $sock_map{$sock}) {
my $now = time();
$host_dead{$ipport} = $now + $dead_for
if $dead_for;
delete $cache_sock{$ipport};
delete $sock_map{$sock};
}
# We need to globally recalculate our buck2sock in all objects, so we increment the global generation.
$socket_cache_generation++;
return $ret; # 0 or undef, probably, depending on what caller wants
}
sub _close_sock {
my ($self, $sock) = @_;
if (my $ipport = $sock_map{$sock}) {
close $sock;
delete $cache_sock{$ipport};
delete $sock_map{$sock};
}
# We need to globally recalculate our buck2sock in all objects, so we increment the global generation.
$socket_cache_generation++;
return 1;
}
sub _connect_sock { # sock, sin, timeout
my ($sock, $sin, $timeout) = @_;
$timeout = 0.25 if not defined $timeout;
# make the socket non-blocking from now on,
# except if someone wants 0 timeout, meaning
# a blocking connect, but even then turn it
# non-blocking at the end of this function
if ($timeout) {
IO::Handle::blocking($sock, 0);
} else {
IO::Handle::blocking($sock, 1);
}
my $ret = connect($sock, $sin);
if (!$ret && $timeout && $!==EINPROGRESS) {
my $win='';
vec($win, fileno($sock), 1) = 1;
if (select(undef, $win, undef, $timeout) > 0) {
$ret = connect($sock, $sin);
# EISCONN means connected & won't re-connect, so success
$ret = 1 if !$ret && $!==EISCONN;
}
}
unless ($timeout) { # socket was temporarily blocking, now revert
IO::Handle::blocking($sock, 0);
}
# from here on, we use non-blocking (async) IO for the duration
# of the socket's life
return $ret;
}
sub sock_to_host { # (host) #why is this public? I wouldn't have to worry about undef $self if it weren't.
my Cache::Memcached $self = ref $_[0] ? shift : undef;
my $host = $_[0];
return $cache_sock{$host} if $cache_sock{$host};
my $now = time();
my ($ip, $port) = $host =~ /(.*):(\d+)$/;
if (defined($ip)) {
$ip =~ s/[\[\]]//g; # get rid of optional IPv6 brackets
}
return undef if
$host_dead{$host} && $host_dead{$host} > $now;
my $sock;
my $connected = 0;
my $sin;
my $proto = $PROTO_TCP ||= getprotobyname('tcp');
if ( index($host, '/') != 0 )
{
# if a preferred IP is known, try that first.
if ($self && $self->{pref_ip}{$ip}) {
my $prefip = $self->{pref_ip}{$ip};
if ($HAVE_SOCKET6 && index($prefip, ':') != -1) {
no strict 'subs'; # for PF_INET6 and AF_INET6, weirdly imported
socket($sock, PF_INET6, SOCK_STREAM, $proto);
$sock_map{$sock} = $host;
$sin = Socket6::pack_sockaddr_in6($port,
Socket6::inet_pton(AF_INET6, $prefip));
} else {
socket($sock, PF_INET, SOCK_STREAM, $proto);
$sock_map{$sock} = $host;
$sin = Socket::sockaddr_in($port, Socket::inet_aton($prefip));
}
if (_connect_sock($sock,$sin,$self->{connect_timeout})) {
$connected = 1;
} else {
if (my $cb = $self->{cb_connect_fail}) {
$cb->($prefip);
}
close $sock;
}
}
# normal path, or fallback path if preferred IP failed
unless ($connected) {
if ($HAVE_SOCKET6 && index($ip, ':') != -1) {
no strict 'subs'; # for PF_INET6 and AF_INET6, weirdly imported
socket($sock, PF_INET6, SOCK_STREAM, $proto);
$sock_map{$sock} = $host;
$sin = Socket6::pack_sockaddr_in6($port,
Socket6::inet_pton(AF_INET6, $ip));
} else {
socket($sock, PF_INET, SOCK_STREAM, $proto);
$sock_map{$sock} = $host;
$sin = Socket::sockaddr_in($port, Socket::inet_aton($ip));
}
my $timeout = $self ? $self->{connect_timeout} : 0.25;
unless (_connect_sock($sock, $sin, $timeout)) {
my $cb = $self ? $self->{cb_connect_fail} : undef;
$cb->($ip) if $cb;
return _dead_sock($self, $sock, undef, 20 + int(rand(10)));
}
}
} else { # it's a unix domain/local socket
socket($sock, PF_UNIX, SOCK_STREAM, 0);
$sock_map{$sock} = $host;
$sin = Socket::sockaddr_un($host);
my $timeout = $self ? $self->{connect_timeout} : 0.25;
unless (_connect_sock($sock,$sin,$timeout)) {
my $cb = $self ? $self->{cb_connect_fail} : undef;
$cb->($host) if $cb;
return _dead_sock($self, $sock, undef, 20 + int(rand(10)));
}
}
# make the new socket not buffer writes.
my $old = select($sock);
$| = 1;
select($old);
$cache_sock{$host} = $sock;
return $sock;
}
sub get_sock { # (key)
my Cache::Memcached $self = $_[0];
my $key = $_[1];
return $self->sock_to_host($self->{'_single_sock'}) if $self->{'_single_sock'};
return undef unless $self->{'active'};
my $hv = ref $key ? int($key->[0]) : _hashfunc($key);
my $real_key = ref $key ? $key->[1] : $key;
my $tries = 0;
while ($tries++ < 20) {
my $host = $self->{'buckets'}->[$hv % $self->{'bucketcount'}];
my $sock = $self->sock_to_host($host);
return $sock if $sock;
return undef if $self->{'no_rehash'};
$hv += _hashfunc($tries . $real_key); # stupid, but works
}
return undef;
}
sub init_buckets {
my Cache::Memcached $self = shift;
return if $self->{'buckets'};
my $bu = $self->{'buckets'} = [];
foreach my $v (@{$self->{'servers'}}) {
if (ref $v eq "ARRAY") {
for (1..$v->[1]) { push @$bu, $v->[0]; }
} else {
push @$bu, $v;
}
}
$self->{'bucketcount'} = scalar @{$self->{'buckets'}};
}
sub disconnect_all {
my Cache::Memcached $self = shift;
my $sock;
foreach $sock (values %cache_sock) {
close $sock;
}
%cache_sock = ();
# We need to globally recalculate our buck2sock in all objects, so we increment the global generation.
$socket_cache_generation++;
}
# writes a line, then reads result. by default stops reading after a
# single line, but caller can override the $check_complete subref,
# which gets passed a scalarref of buffer read thus far.
sub _write_and_read {
my Cache::Memcached $self = shift;
my ($sock, $line, $check_complete) = @_;
my $res;
my ($ret, $offset) = (undef, 0);
$check_complete ||= sub {
return (rindex($ret, "\r\n") + 2 == length($ret));
};
# state: 0 - writing, 1 - reading, 2 - done
my $state = 0;
# the bitsets for select
my ($rin, $rout, $win, $wout);
my $nfound;
my $copy_state = -1;
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
# the select loop
while(1) {
if ($copy_state!=$state) {
last if $state==2;
($rin, $win) = ('', '');
vec($rin, fileno($sock), 1) = 1 if $state==1;
vec($win, fileno($sock), 1) = 1 if $state==0;
$copy_state = $state;
}
$nfound = select($rout=$rin, $wout=$win, undef,
$self->{'select_timeout'});
last unless $nfound;
if (vec($wout, fileno($sock), 1)) {
$res = send($sock, $line, $FLAG_NOSIGNAL);
next
if not defined $res and $!==EWOULDBLOCK;
unless ($res > 0) {
$self->_close_sock($sock);
return undef;
}
if ($res == length($line)) { # all sent
$state = 1;
} else { # we only succeeded in sending some of it
substr($line, 0, $res, ''); # delete the part we sent
}
}
if (vec($rout, fileno($sock), 1)) {
$res = sysread($sock, $ret, 255, $offset);
next
if !defined($res) and $!==EWOULDBLOCK;
if ($res == 0) { # catches 0=conn closed or undef=error
$self->_close_sock($sock);
return undef;
}
$offset += $res;
$state = 2 if $check_complete->(\$ret);
}
}
unless ($state == 2) {
$self->_dead_sock($sock); # improperly finished
return undef;
}
return $ret;
}
sub delete {
my Cache::Memcached $self = shift;
my ($key, $time) = @_;
return 0 if ! $self->{'active'} || $self->{'readonly'};
my $stime = Time::HiRes::time() if $self->{'stat_callback'};
my $sock = $self->get_sock($key);
return 0 unless $sock;
$self->{'stats'}->{"delete"}++;
$key = ref $key ? $key->[1] : $key;
$time = $time ? " $time" : "";
my $cmd = "delete $self->{namespace}$key$time\r\n";
my $res = _write_and_read($self, $sock, $cmd);
if ($self->{'stat_callback'}) {
my $etime = Time::HiRes::time();
$self->{'stat_callback'}->($stime, $etime, $sock, 'delete');
}
return defined $res && $res eq "DELETED\r\n";
}
*remove = \&delete;
sub add {
_set("add", @_);
}
sub replace {
_set("replace", @_);
}
sub set {
_set("set", @_);
}
sub append {
_set("append", @_);
}
sub prepend {
_set("prepend", @_);
}
sub _set {
my $cmdname = shift;
my Cache::Memcached $self = shift;
my ($key, $val, $exptime) = @_;
return 0 if ! $self->{'active'} || $self->{'readonly'};
my $stime = Time::HiRes::time() if $self->{'stat_callback'};
my $sock = $self->get_sock($key);
return 0 unless $sock;
use bytes; # return bytes from length()
my $app_or_prep = $cmdname eq 'append' || $cmdname eq 'prepend' ? 1 : 0;
$self->{'stats'}->{$cmdname}++;
my $flags = 0;
$key = ref $key ? $key->[1] : $key;
if (ref $val) {
die "append or prepend cannot take a reference" if $app_or_prep;
local $Carp::CarpLevel = 2;
$val = Storable::nfreeze($val);
$flags |= F_STORABLE;
}
warn "value for memkey:$key is not defined" unless defined $val;
my $len = length($val);
if ($self->{'compress_threshold'} && $HAVE_ZLIB && $self->{'compress_enable'} &&
$len >= $self->{'compress_threshold'} && !$app_or_prep) {
my $c_val = Compress::Zlib::memGzip($val);
my $c_len = length($c_val);
# do we want to keep it?
if ($c_len < $len*(1 - COMPRESS_SAVINGS)) {
$val = $c_val;
$len = $c_len;
$flags |= F_COMPRESS;
}
}
$exptime = int($exptime || 0);
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
my $line = "$cmdname $self->{namespace}$key $flags $exptime $len\r\n$val\r\n";
my $res = _write_and_read($self, $sock, $line);
if ($self->{'debug'} && $line) {
chop $line; chop $line;
print STDERR "Cache::Memcache: $cmdname $self->{namespace}$key = $val ($line)\n";
}
if ($self->{'stat_callback'}) {
my $etime = Time::HiRes::time();
$self->{'stat_callback'}->($stime, $etime, $sock, $cmdname);
}
return defined $res && $res eq "STORED\r\n";
}
sub incr {
_incrdecr("incr", @_);
}
sub decr {
_incrdecr("decr", @_);
}
sub _incrdecr {
my $cmdname = shift;
my Cache::Memcached $self = shift;
my ($key, $value) = @_;
return undef if ! $self->{'active'} || $self->{'readonly'};
my $stime = Time::HiRes::time() if $self->{'stat_callback'};
my $sock = $self->get_sock($key);
return undef unless $sock;
$key = $key->[1] if ref $key;
$self->{'stats'}->{$cmdname}++;
$value = 1 unless defined $value;
my $line = "$cmdname $self->{namespace}$key $value\r\n";
my $res = _write_and_read($self, $sock, $line);
if ($self->{'stat_callback'}) {
my $etime = Time::HiRes::time();
$self->{'stat_callback'}->($stime, $etime, $sock, $cmdname);
}
return undef unless defined $res && $res =~ /^(\d+)/;
return $1;
}
sub get {
my Cache::Memcached $self = $_[0];
my $key = $_[1];
# TODO: make a fast path for this? or just keep using get_multi?
my $r = $self->get_multi($key);
my $kval = ref $key ? $key->[1] : $key;
# key reconstituted from server won't have utf8 on, so turn it off on input
# scalar to allow hash lookup to succeed
Encode::_utf8_off($kval) if Encode::is_utf8($kval);
return $r->{$kval};
}
sub get_multi {
my Cache::Memcached $self = shift;
return {} unless $self->{'active'};
$self->{'_stime'} = Time::HiRes::time() if $self->{'stat_callback'};
$self->{'stats'}->{"get_multi"}++;
my %val; # what we'll be returning a reference to (realkey -> value)
my %sock_keys; # sockref_as_scalar -> [ realkeys ]
my $sock;
if ($self->{'_single_sock'}) {
$sock = $self->sock_to_host($self->{'_single_sock'});
unless ($sock) {
return {};
}
foreach my $key (@_) {
my $kval = ref $key ? $key->[1] : $key;
push @{$sock_keys{$sock}}, $kval;
}
} else {
my $bcount = $self->{'bucketcount'};
my $sock;
if ($self->{'buck2sock_generation'} != $socket_cache_generation) {
$self->{'buck2sock_generation'} = $socket_cache_generation;
$self->{'buck2sock'} = [];
}
KEY:
foreach my $key (@_) {
my ($hv, $real_key) = ref $key ?
(int($key->[0]), $key->[1]) :
((crc32($key) >> 16) & 0x7fff, $key);
my $tries;
while (1) {
my $bucket = $hv % $bcount;
# this segfaults perl 5.8.4 (and others?) if sock_to_host returns undef... wtf?
#$sock = $buck2sock[$bucket] ||= $self->sock_to_host($self->{buckets}[ $bucket ])
# and last;
# but this variant doesn't crash:
$sock = $self->{'buck2sock'}->[$bucket] || $self->sock_to_host($self->{buckets}[ $bucket ]);
if ($sock) {
$self->{'buck2sock'}->[$bucket] = $sock;
last;
}
next KEY if $tries++ >= 20;
$hv += _hashfunc($tries . $real_key);
}
push @{$sock_keys{$sock}}, $real_key;
}
}
$self->{'stats'}->{"get_keys"} += @_;
$self->{'stats'}->{"get_socks"} += keys %sock_keys;
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
_load_multi($self, \%sock_keys, \%val);
if ($self->{'debug'}) {
while (my ($k, $v) = each %val) {
print STDERR "MemCache: got $k = $v\n";
}
}
return \%val;
}
sub _load_multi {
use bytes; # return bytes from length()
my Cache::Memcached $self;
my ($sock_keys, $ret);
($self, $sock_keys, $ret) = @_;
# all keyed by $sockstr:
my %reading; # $sockstr -> $sock. bool, whether we're reading from this socket
my %writing; # $sockstr -> $sock. bool, whether we're writing to this socket
my %buf; # buffers, for writing
my %parser; # $sockstr -> Cache::Memcached::GetParser
my $active_changed = 1; # force rebuilding of select sets
my $dead = sub {
my $sock = shift;
print STDERR "killing socket $sock\n" if $self->{'debug'} >= 2;
delete $reading{$sock};
delete $writing{$sock};
if (my $p = $parser{$sock}) {
my $key = $p->current_key;
delete $ret->{$key} if $key;
}
if ($self->{'stat_callback'}) {
my $etime = Time::HiRes::time();
$self->{'stat_callback'}->($self->{'_stime'}, $etime, $sock, 'get_multi');
}
close $sock;
$self->_dead_sock($sock);
};
# $finalize->($key, $flags)
# $finalize->({ $key => $flags, $key => $flags });
my $finalize = sub {
my $map = $_[0];
$map = {@_} unless ref $map;
while (my ($k, $flags) = each %$map) {
# remove trailing \r\n
chop $ret->{$k}; chop $ret->{$k};
$ret->{$k} = Compress::Zlib::memGunzip($ret->{$k})
if $HAVE_ZLIB && $flags & F_COMPRESS;
if ($flags & F_STORABLE) {
# wrapped in eval in case a perl 5.6 Storable tries to
# unthaw data from a perl 5.8 Storable. (5.6 is stupid
# and dies if the version number changes at all. in 5.8
# they made it only die if it unencounters a new feature)
eval {
$ret->{$k} = Storable::thaw($ret->{$k});
};
# so if there was a problem, just treat it as a cache miss.
if ($@) {
delete $ret->{$k};
}
}
}
};
foreach (keys %$sock_keys) {
my $ipport = $sock_map{$_} or die "No map found matching for $_";
my $sock = $cache_sock{$ipport} or die "No sock found for $ipport";
print STDERR "processing socket $_\n" if $self->{'debug'} >= 2;
$writing{$_} = $sock;
if ($self->{namespace}) {
$buf{$_} = join(" ", 'get', (map { "$self->{namespace}$_" } @{$sock_keys->{$_}}), "\r\n");
} else {
$buf{$_} = join(" ", 'get', @{$sock_keys->{$_}}, "\r\n");
}
$parser{$_} = $self->{parser_class}->new($ret, $self->{namespace_len}, $finalize);
}
my $read = sub {
my $sockstr = "$_[0]"; # $sock is $_[0];
my $p = $parser{$sockstr} or die;
my $rv = $p->parse_from_sock($_[0]);
if ($rv > 0) {
# okay, finished with this socket
delete $reading{$sockstr};
} elsif ($rv < 0) {
$dead->($_[0]);
}
return $rv;
};
# returns 1 when it's done, for success or error. 0 if still working.
my $write = sub {
my ($sock, $sockstr) = ($_[0], "$_[0]");
my $res;
$res = send($sock, $buf{$sockstr}, $FLAG_NOSIGNAL);
return 0
if not defined $res and $!==EWOULDBLOCK;
unless ($res > 0) {
$dead->($sock);
return 1;
}
if ($res == length($buf{$sockstr})) { # all sent
$buf{$sockstr} = "";
# switch the socket from writing to reading
delete $writing{$sockstr};
$reading{$sockstr} = $sock;
return 1;
} else { # we only succeeded in sending some of it
substr($buf{$sockstr}, 0, $res, ''); # delete the part we sent
}
return 0;
};
# the bitsets for select
my ($rin, $rout, $win, $wout);
my $nfound;
# the big select loop
while(1) {
if ($active_changed) {
last unless %reading or %writing; # no sockets left?
($rin, $win) = ('', '');
foreach (values %reading) {
vec($rin, fileno($_), 1) = 1;
}
foreach (values %writing) {
vec($win, fileno($_), 1) = 1;
}
$active_changed = 0;
}
# TODO: more intelligent cumulative timeout?
# TODO: select is interruptible w/ ptrace attach, signal, etc. should note that.
$nfound = select($rout=$rin, $wout=$win, undef,
$self->{'select_timeout'});
last unless $nfound;
# TODO: possible robustness improvement: we could select
# writing sockets for reading also, and raise hell if they're
# ready (input unread from last time, etc.)
# maybe do that on the first loop only?
foreach (values %writing) {
if (vec($wout, fileno($_), 1)) {
$active_changed = 1 if $write->($_);
}
}
foreach (values %reading) {
if (vec($rout, fileno($_), 1)) {
$active_changed = 1 if $read->($_);
}
}
}
# if there're active sockets left, they need to die
foreach (values %writing) {
$dead->($_);
}
foreach (values %reading) {
$dead->($_);
}
return;
}
sub _hashfunc {
return (crc32($_[0]) >> 16) & 0x7fff;
}
sub flush_all {
my Cache::Memcached $self = shift;
my $success = 1;
my @hosts = @{$self->{'buckets'}};
foreach my $host (@hosts) {
my $sock = $self->sock_to_host($host);
my @res = $self->run_command($sock, "flush_all\r\n");
$success = 0 unless (scalar @res == 1 && (($res[0] || "") eq "OK\r\n"));
}
return $success;
}
# returns array of lines, or () on failure.
sub run_command {
my Cache::Memcached $self = shift;
my ($sock, $cmd) = @_;
return () unless $sock;
my $ret;
my $line = $cmd;
while (my $res = _write_and_read($self, $sock, $line)) {
undef $line;
$ret .= $res;
last if $ret =~ /(?:OK|END|ERROR)\r\n$/;
}
chop $ret; chop $ret;
return map { "$_\r\n" } split(/\r\n/, $ret);
}
sub stats {
my Cache::Memcached $self = shift;
my ($types) = @_;
return 0 unless $self->{'active'};
return 0 unless !ref($types) || ref($types) eq 'ARRAY';
if (!ref($types)) {
if (!$types) {
# I don't much care what the default is, it should just
# be something reasonable. Obviously "reset" should not
# be on the list :) but other types that might go in here
# include maps, cachedump, slabs, or items. Note that
# this does NOT include 'sizes' anymore, as that can freeze
# bug servers for a couple seconds.
$types = [ qw( misc malloc self ) ];
} else {
$types = [ $types ];
}
}
my $stats_hr = { };
# The "self" stat type is special, it only applies to this very
# object.
if (grep /^self$/, @$types) {
$stats_hr->{'self'} = \%{ $self->{'stats'} };
}
my %misc_keys = map { $_ => 1 }
qw/ bytes bytes_read bytes_written
cmd_get cmd_set connection_structures curr_items
get_hits get_misses
total_connections total_items
/;
# Now handle the other types, passing each type to each host server.
my @hosts = @{$self->{'buckets'}};
HOST: foreach my $host (@hosts) {
my $sock = $self->sock_to_host($host);
next HOST unless $sock;
TYPE: foreach my $typename (grep !/^self$/, @$types) {
my $type = $typename eq 'misc' ? "" : " $typename";
my $lines = _write_and_read($self, $sock, "stats$type\r\n", sub {
my $bref = shift;
return $$bref =~ /^(?:END|ERROR)\r?\n/m;
});
unless ($lines) {
$self->_dead_sock($sock);
next HOST;
}
$lines =~ s/\0//g; # 'stats sizes' starts with NULL?
# And, most lines end in \r\n but 'stats maps' (as of
# July 2003 at least) ends in \n. ??
my @lines = split(/\r?\n/, $lines);
# Some stats are key-value, some are not. malloc,
# sizes, and the empty string are key-value.
# ("self" was handled separately above.)
if ($typename =~ /^(malloc|sizes|misc)$/) {
# This stat is key-value.
foreach my $line (@lines) {
my ($key, $value) = $line =~ /^(?:STAT )?(\w+)\s(.*)/;
if ($key) {
$stats_hr->{'hosts'}{$host}{$typename}{$key} = $value;
}
$stats_hr->{'total'}{$key} += $value
if $typename eq 'misc' && $key && $misc_keys{$key};
$stats_hr->{'total'}{"malloc_$key"} += $value
if $typename eq 'malloc' && $key;
}
} else {
# This stat is not key-value so just pull it
# all out in one blob.
$lines =~ s/^END\r?\n//m;
$stats_hr->{'hosts'}{$host}{$typename} ||= "";
$stats_hr->{'hosts'}{$host}{$typename} .= "$lines";
}
}
}
return $stats_hr;
}
sub stats_reset {
my Cache::Memcached $self = shift;
my ($types) = @_;
return 0 unless $self->{'active'};
HOST: foreach my $host (@{$self->{'buckets'}}) {
my $sock = $self->sock_to_host($host);
next HOST unless $sock;
my $ok = _write_and_read($self, $sock, "stats reset");
unless (defined $ok && $ok eq "RESET\r\n") {
$self->_dead_sock($sock);
}
}
return 1;
}
1;
__END__
=head1 NAME
Cache::Memcached - client library for memcached (memory cache daemon)
=head1 SYNOPSIS
use Cache::Memcached;
$memd = new Cache::Memcached {
'servers' => [ "10.0.0.15:11211", "10.0.0.15:11212", "/var/sock/memcached",
"10.0.0.17:11211", [ "10.0.0.17:11211", 3 ] ],
'debug' => 0,
'compress_threshold' => 10_000,
};
$memd->set_servers($array_ref);
$memd->set_compress_threshold(10_000);
$memd->enable_compress(0);
$memd->set("my_key", "Some value");
$memd->set("object_key", { 'complex' => [ "object", 2, 4 ]});
$val = $memd->get("my_key");
$val = $memd->get("object_key");
if ($val) { print $val->{'complex'}->[2]; }
$memd->incr("key");
$memd->decr("key");
$memd->incr("key", 2);
=head1 DESCRIPTION
This is the Perl API for memcached, a distributed memory cache daemon.
More information is available at:
http://www.danga.com/memcached/
=head1 CONSTRUCTOR
=over 4
=item C<new>
Takes one parameter, a hashref of options. The most important key is
C<servers>, but that can also be set later with the C<set_servers>
method. The servers must be an arrayref of hosts, each of which is
either a scalar of the form C<10.0.0.10:11211> or an arrayref of the
former and an integer weight value. (The default weight if
unspecified is 1.) It's recommended that weight values be kept as low
as possible, as this module currently allocates memory for bucket
distribution proportional to the total host weights.
Use C<compress_threshold> to set a compression threshold, in bytes.
Values larger than this threshold will be compressed by C<set> and
decompressed by C<get>.
Use C<no_rehash> to disable finding a new memcached server when one
goes down. Your application may or may not need this, depending on
your expirations and key usage.
Use C<readonly> to disable writes to backend memcached servers. Only
get and get_multi will work. This is useful in bizarre debug and
profiling cases only.
Use C<namespace> to prefix all keys with the provided namespace value.
That is, if you set namespace to "app1:" and later do a set of "foo"
to "bar", memcached is actually seeing you set "app1:foo" to "bar".
Use C<connect_timeout> and C<select_timeout> to set connection and
polling timeouts. The C<connect_timeout> defaults to .25 second, and
the C<select_timeout> defaults to 1 second.
The other useful key is C<debug>, which when set to true will produce
diagnostics on STDERR.
=back
=head1 METHODS
=over 4
=item C<set_servers>
Sets the server list this module distributes key gets and sets between.
The format is an arrayref of identical form as described in the C<new>
constructor.
=item C<set_debug>
Sets the C<debug> flag. See C<new> constructor for more information.
=item C<set_readonly>
Sets the C<readonly> flag. See C<new> constructor for more information.
=item C<set_norehash>
Sets the C<no_rehash> flag. See C<new> constructor for more information.
=item C<set_compress_threshold>
Sets the compression threshold. See C<new> constructor for more information.
=item C<set_connect_timeout>
Sets the connect timeout. See C<new> constructor for more information.
=item C<set_select_timeout>
Sets the select timeout. See C<new> constructor for more information.
=item C<enable_compress>
Temporarily enable or disable compression. Has no effect if C<compress_threshold>
isn't set, but has an overriding effect if it is.
=item C<get>
my $val = $memd->get($key);
Retrieves a key from the memcache. Returns the value (automatically
thawed with Storable, if necessary) or undef.
The $key can optionally be an arrayref, with the first element being the
hash value, if you want to avoid making this module calculate a hash
value. You may prefer, for example, to keep all of a given user's
objects on the same memcache server, so you could use the user's
unique id as the hash value.
=item C<get_multi>
my $hashref = $memd->get_multi(@keys);
Retrieves multiple keys from the memcache doing just one query.
Returns a hashref of key/value pairs that were available.
This method is recommended over regular 'get' as it lowers the number
of total packets flying around your network, reducing total latency,
since your app doesn't have to wait for each round-trip of 'get'
before sending the next one.
=item C<set>
$memd->set($key, $value[, $exptime]);
Unconditionally sets a key to a given value in the memcache. Returns true
if it was stored successfully.
The $key can optionally be an arrayref, with the first element being the
hash value, as described above.
The $exptime (expiration time) defaults to "never" if unspecified. If
you want the key to expire in memcached, pass an integer $exptime. If
value is less than 60*60*24*30 (30 days), time is assumed to be relative
from the present. If larger, it's considered an absolute Unix time.
=item C<add>
$memd->add($key, $value[, $exptime]);
Like C<set>, but only stores in memcache if the key doesn't already exist.
=item C<replace>
$memd->replace($key, $value[, $exptime]);
Like C<set>, but only stores in memcache if the key already exists. The
opposite of C<add>.
=item C<delete>
$memd->delete($key[, $time]);
Deletes a key. You may optionally provide an integer time value (in seconds) to
tell the memcached server to block new writes to this key for that many seconds.
(Sometimes useful as a hacky means to prevent races.) Returns true if key
was found and deleted, and false otherwise.
You may also use the alternate method name B<remove>, so
Cache::Memcached looks like the L<Cache::Cache> API.
=item C<incr>
$memd->incr($key[, $value]);
Sends a command to the server to atomically increment the value for
$key by $value, or by 1 if $value is undefined. Returns undef if $key
doesn't exist on server, otherwise it returns the new value after
incrementing. Value should be zero or greater. Overflow on server
is not checked. Be aware of values approaching 2**32. See decr.
=item C<decr>
$memd->decr($key[, $value]);
Like incr, but decrements. Unlike incr, underflow is checked and new
values are capped at 0. If server value is 1, a decrement of 2
returns 0, not -1.
=item C<stats>
$memd->stats([$keys]);
Returns a hashref of statistical data regarding the memcache server(s),
the $memd object, or both. $keys can be an arrayref of keys wanted, a
single key wanted, or absent (in which case the default value is malloc,
sizes, self, and the empty string). These keys are the values passed
to the 'stats' command issued to the memcached server(s), except for
'self' which is internal to the $memd object. Allowed values are:
=over 4
=item C<misc>
The stats returned by a 'stats' command: pid, uptime, version,
bytes, get_hits, etc.
=item C<malloc>
The stats returned by a 'stats malloc': total_alloc, arena_size, etc.
=item C<sizes>
The stats returned by a 'stats sizes'.
=item C<self>
The stats for the $memd object itself (a copy of $memd->{'stats'}).
=item C<maps>
The stats returned by a 'stats maps'.
=item C<cachedump>
The stats returned by a 'stats cachedump'.
=item C<slabs>
The stats returned by a 'stats slabs'.
=item C<items>
The stats returned by a 'stats items'.
=back
=item C<disconnect_all>
$memd->disconnect_all;
Closes all cached sockets to all memcached servers. You must do this
if your program forks and the parent has used this module at all.
Otherwise the children will try to use cached sockets and they'll fight
(as children do) and garble the client/server protocol.
=item C<flush_all>
$memd->flush_all;
Runs the memcached "flush_all" command on all configured hosts,
emptying all their caches. (or rather, invalidating all items
in the caches in an O(1) operation...) Running stats will still
show the item existing, they're just be non-existent and lazily
destroyed next time you try to detch any of them.
=back
=head1 BUGS
When a server goes down, this module does detect it, and re-hashes the
request to the remaining servers, but the way it does it isn't very
clean. The result may be that it gives up during its rehashing and
refuses to get/set something it could've, had it been done right.
=head1 COPYRIGHT
This module is Copyright (c) 2003 Brad Fitzpatrick.
All rights reserved.
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
=head1 WARRANTY
This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
=head1 FAQ
See the memcached website:
http://www.danga.com/memcached/
=head1 AUTHORS
Brad Fitzpatrick <brad@danga.com>
Anatoly Vorobey <mellon@pobox.com>
Brad Whitaker <whitaker@danga.com>
Jamie McCarthy <jamie@mccarthy.vg>
Cache-Memcached-1.30/lib/Cache/Memcached/ 0000755 0000000 0000000 00000000000 12036531447 0017726 5 ustar 00root root 0000000 0000000 Cache-Memcached-1.30/lib/Cache/Memcached/GetParser.pm 0000644 0000000 0000000 00000007753 12036531447 0022174 0 ustar 00root root 0000000 0000000 package Cache::Memcached::GetParser;
use strict;
use warnings;
use integer;
use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN );
use constant DEST => 0; # destination hashref we're writing into
use constant NSLEN => 1; # length of namespace to ignore on keys
use constant ON_ITEM => 2;
use constant BUF => 3; # read buffer
use constant STATE => 4; # 0 = waiting for a line, N = reading N bytes
use constant OFFSET => 5; # offsets to read into buffers
use constant FLAGS => 6;
use constant KEY => 7; # current key we're parsing (without the namespace prefix)
sub new {
my ($class, $dest, $nslen, $on_item) = @_;
return bless [$dest, $nslen, $on_item, '', 0, 0], $class;
}
sub current_key {
return $_[0][KEY];
}
# returns 1 on success, -1 on failure, and 0 if still working.
sub parse_from_sock {
my ($self, $sock) = @_;
my $res;
# where are we reading into?
if ($self->[STATE]) { # reading value into $ret
my $ret = $self->[DEST];
$res = sysread($sock, $ret->{$self->[KEY]},
$self->[STATE] - $self->[OFFSET],
$self->[OFFSET]);
return 0
if !defined($res) and $!==EWOULDBLOCK;
if ($res == 0) { # catches 0=conn closed or undef=error
$self->[ON_ITEM] = undef;
return -1;
}
$self->[OFFSET] += $res;
if ($self->[OFFSET] == $self->[STATE]) { # finished reading
$self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]);
$self->[OFFSET] = 0;
$self->[STATE] = 0;
# wait for another VALUE line or END...
}
return 0; # still working, haven't got to end yet
}
# we're reading a single line.
# first, read whatever's there, but be satisfied with 2048 bytes
$res = sysread($sock, $self->[BUF],
128*1024, $self->[OFFSET]);
return 0
if !defined($res) and $!==EWOULDBLOCK;
if (!defined($res) || $res == 0) {
$self->[ON_ITEM] = undef;
return -1;
}
$self->[OFFSET] += $res;
return $self->parse_buffer;
}
# returns 1 on success, -1 on failure, and 0 if still working.
sub parse_buffer {
my ($self) = @_;
my $ret = $self->[DEST];
SEARCH:
while (1) { # may have to search many times
# do we have a complete END line?
if ($self->[BUF] =~ /^END\r\n/) {
$self->[ON_ITEM] = undef;
return 1; # we're done successfully, return 1 to finish
}
# do we have a complete VALUE line?
if ($self->[BUF] =~ /^VALUE (\S+) (\d+) (\d+)\r\n/) {
($self->[KEY], $self->[FLAGS], $self->[STATE]) =
(substr($1, $self->[NSLEN]), int($2), $3+2);
# Note: we use $+[0] and not pos($self->[BUF]) because pos()
# seems to have problems under perl's taint mode. nobody
# on the list discovered why, but this seems a reasonable
# work-around:
my $p = $+[0];
my $len = length($self->[BUF]);
my $copy = $len-$p > $self->[STATE] ? $self->[STATE] : $len-$p;
$ret->{$self->[KEY]} = substr($self->[BUF], $p, $copy)
if $copy;
$self->[OFFSET] = $copy;
substr($self->[BUF], 0, $p+$copy, ''); # delete the stuff we used
if ($self->[OFFSET] == $self->[STATE]) { # have it all?
$self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]);
$self->[OFFSET] = 0;
$self->[STATE] = 0;
next SEARCH; # look again
}
last SEARCH; # buffer is empty now
}
# if we're here probably means we only have a partial VALUE
# or END line in the buffer. Could happen with multi-get,
# though probably very rarely. Exit the loop and let it read
# more.
# but first, make sure subsequent reads don't destroy our
# partial VALUE/END line.
$self->[OFFSET] = length($self->[BUF]);
last SEARCH;
}
return 0;
}
1;
Cache-Memcached-1.30/t/ 0000755 0000000 0000000 00000000000 12036531447 0014552 5 ustar 00root root 0000000 0000000 Cache-Memcached-1.30/t/01_use.t 0000644 0000000 0000000 00000000143 12036531447 0016031 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
plan tests => 1;
use_ok('Cache::Memcached');
Cache-Memcached-1.30/t/02_keys.t 0000644 0000000 0000000 00000005110 12036531447 0016210 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
unless ($^V) {
plan skip_all => "This test requires perl 5.6.0+\n";
exit 0;
}
my $testaddr = "127.0.0.1:11211";
my $msock = IO::Socket::INET->new(PeerAddr => $testaddr,
Timeout => 3);
if ($msock) {
plan tests => 20;
} else {
plan skip_all => "No memcached instance running at $testaddr\n";
exit 0;
}
my $memd = Cache::Memcached->new({
servers => [ $testaddr ],
namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/",
});
isa_ok($memd, 'Cache::Memcached');
my $memcached_version;
eval {
require version;
die "version too old" unless $version::VERSION >= 0.77;
$memcached_version =
version->parse(
$memd->stats('misc')->{hosts}->{$testaddr}->{misc}->{version}
);
diag("Server version: $memcached_version") if $memcached_version;
};
ok($memd->set("key1", "val1"), "set key1 as val1");
is($memd->get("key1"), "val1", "get key1 is val1");
ok(! $memd->add("key1", "val-replace"), "add key1 properly failed");
ok($memd->add("key2", "val2"), "add key2 as val2");
is($memd->get("key2"), "val2", "get key2 is val2");
ok($memd->replace("key2", "val-replace"), "replace key2 as val-replace");
is($memd->get("key2"), "val-replace", "get key2 is val-replace");
ok(! $memd->replace("key-noexist", "bogus"), "replace key-noexist properly failed");
ok($memd->delete("key1"), "delete key1");
ok(! $memd->get("key1"), "get key1 properly failed");
SKIP: {
skip "Could not parse server version; version.pm 0.77 required", 7
unless $memcached_version;
skip "Only using prepend/append on memcached >= 1.2.4, you have $memcached_version", 7
unless $memcached_version && $memcached_version >= v1.2.4;
ok(! $memd->append("key-noexist", "bogus"), "append key-noexist properly failed");
ok(! $memd->prepend("key-noexist", "bogus"), "prepend key-noexist properly failed");
ok($memd->set("key3", "base"), "set key3 to base");
ok($memd->append("key3", "-end"), "appended -end to key3");
ok($memd->get("key3", "base-end"), "key3 is base-end");
ok($memd->prepend("key3", "start-"), "prepended start- to key3");
ok($memd->get("key3", "start-base-end"), "key3 is base-end");
}
# also test creating the object with a list rather than a hash-ref
my $mem2 = Cache::Memcached->new(
servers => [ ],
debug => 1,
);
isa_ok($mem2, 'Cache::Memcached');
ok($mem2->{debug}, "debug is set on alt constructed instance");
Cache-Memcached-1.30/t/03_stats.t 0000644 0000000 0000000 00000002561 12036531447 0016403 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
my $testaddr = "127.0.0.1:11211";
my $msock = IO::Socket::INET->new(PeerAddr => $testaddr,
Timeout => 3);
my @misc_stats_keys = qw/ bytes bytes_read bytes_written
cmd_get cmd_set connection_structures curr_items
get_hits get_misses
total_connections total_items
/;
if ($msock) {
plan tests => 16 + scalar(@misc_stats_keys);
} else {
plan skip_all => "No memcached instance running at $testaddr\n";
exit 0;
}
my $memd = Cache::Memcached->new({
servers => [ $testaddr ],
namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/",
});
my $misc_stats = $memd->stats('misc');
ok($misc_stats, 'got misc stats');
isa_ok($misc_stats, 'HASH', 'misc stats');
isa_ok($misc_stats->{'total'}, 'HASH', 'misc stats total');
isa_ok($misc_stats->{'hosts'}, 'HASH', 'misc stats hosts');
isa_ok($misc_stats->{'hosts'}{$testaddr}, 'HASH',
"misc stats hosts $testaddr");
foreach my $stat_key (@misc_stats_keys) {
ok(exists $misc_stats->{'total'}{$stat_key},
"misc stats total contains $stat_key");
ok(exists $misc_stats->{'hosts'}{$testaddr}{'misc'}{$stat_key},
"misc stats hosts $testaddr misc contains $stat_key");
}
Cache-Memcached-1.30/t/04_noreply.t 0000644 0000000 0000000 00000002062 12036531447 0016732 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
my $testaddr = "127.0.0.1:11211";
my $msock = IO::Socket::INET->new(PeerAddr => $testaddr,
Timeout => 3);
if ($msock) {
plan tests => 7;
} else {
plan skip_all => "No memcached instance running at $testaddr\n";
exit 0;
}
my $memd = Cache::Memcached->new({
servers => [ $testaddr ],
namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/",
});
isa_ok($memd, 'Cache::Memcached');
use constant count => 30;
$memd->flush_all;
$memd->add("key", "add");
is($memd->get("key"), "add");
for (my $i = 0; $i < count; ++$i) {
$memd->set("key", $i);
}
is($memd->get("key"), count - 1);
$memd->replace("key", count);
is($memd->get("key"), count);
for (my $i = 0; $i < count; ++$i) {
$memd->incr("key", 2);
}
is($memd->get("key"), count + 2 * count);
for (my $i = 0; $i < count; ++$i) {
$memd->decr("key", 1);
}
is($memd->get("key"), count + 1 * count);
$memd->delete("key");
is($memd->get("key"), undef);
Cache-Memcached-1.30/t/05_reconnect_timeout.t 0000644 0000000 0000000 00000002725 12036531447 0020777 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
use Time::HiRes qw(gettimeofday tv_interval);
##############################################################################
# This is connecting to TEST-NET-1 on purpose, because that's a space that is
# guaranteed by RFC to have no hosts in it. Sometimes we still get fast RST
# frames though, so we have to check before we trust it.
#
# DO NOT FIX THIS CODE TO CHECK AND MAKE SURE THE HOST IS UP. IT IS SUPPOSED
# TO BE DOWN. :) --hachi
##############################################################################
my $testaddr = "192.0.2.1:11211";
my $stime = [gettimeofday];
my $msock = IO::Socket::INET->new(
PeerAddr => $testaddr,
Timeout => 2,
);
my $delta_t = tv_interval($stime);
if ($delta_t >= 1) {
plan tests => 2;
} else {
plan skip_all => "Somehow we got a fast return when connecting to $testaddr\n";
exit 0;
}
my $memd = Cache::Memcached->new({
servers => [ $testaddr ],
namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/",
});
my $time1 = Time::HiRes::time();
$memd->set("key", "bar");
my $time2 = Time::HiRes::time();
# 100ms is faster than the default connect timeout.
ok($time2 - $time1 > .1, "Expected pause while connecting");
# 100ms should be slow enough that dead socket reconnects happen faster than it.
$memd->set("key", "foo");
my $time3 = Time::HiRes::time();
ok($time3 - $time2 < .1, "Should return fast on retry");
Cache-Memcached-1.30/t/06_utf8_key.t 0000644 0000000 0000000 00000001067 12036531447 0017006 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
my $testaddr = "127.0.0.1:11211";
my $msock = IO::Socket::INET->new(PeerAddr => $testaddr,
Timeout => 3);
if ($msock) {
plan tests => 2;
} else {
plan skip_all => "No memcached instance running at $testaddr\n";
exit 0;
}
my $memd = Cache::Memcached->new({
servers => [ $testaddr ],
});
use utf8;
my $key = "Ïâ";
ok($memd->set($key, "val1"), "set key1 as val1");
is($memd->get($key), "val1", "get key1 is val1");
Cache-Memcached-1.30/t/100_flush_bug.t 0000644 0000000 0000000 00000002363 12036531447 0017301 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
my $port = 11311;
my $testaddr = "127.0.0.1:$port";
my $sock = IO::Socket::INET->new(
LocalAddr => $testaddr,
Proto => 'tcp',
ReuseAddr => 1,
);
my @res = (
["OK\r\n", 1],
["ERROR\r\n", 0],
["\r\nERROR\r\n", 0],
["FOO\r\nERROR\r\n", 0],
["FOO\r\nOK\r\nERROR\r\n", 0],
["\r\n\r\nOK\r\n", 0],
["END\r\n", 0],
);
if ($sock) {
plan tests => scalar @res;
} else {
plan skip_all => "cannot bind to $testaddr\n";
exit 0;
}
close $sock;
my $pid = fork;
die "Cannot fork because: '$!'" unless defined $pid;
unless ($pid) {
my $sock = IO::Socket::INET->new(
LocalAddr => $testaddr,
Proto => 'tcp',
ReuseAddr => 1,
Listen => 1,
) or die "cannot open $testaddr: $!";
my $csock = $sock->accept();
while (defined (my $buf = <$csock>)) {
my $res = shift @res;
print $csock $res->[0];
}
close $csock;
close $sock;
exit 0;
}
# give the forked server a chance to startup
sleep 1;
my $memd = Cache::Memcached->new({ servers => [ $testaddr ] });
for (@res) {
($_->[0] =~ s/\W//g);
is $memd->flush_all, $_->[1], $_->[0];
}
Cache-Memcached-1.30/t/101_multiple_clients.t 0000644 0000000 0000000 00000001442 12036531447 0020675 0 ustar 00root root 0000000 0000000 #!/usr/bin/env perl -w
use strict;
use Test::More;
use Cache::Memcached;
use IO::Socket::INET;
my $testaddr = "127.0.0.1:11211";
my $sock = IO::Socket::INET->new(
PeerAddr => $testaddr,
Proto => 'tcp',
ReuseAddr => 1,
);
if ($sock) {
plan tests => 8;
} else {
plan skip_all => "cannot connect to $testaddr\n";
exit 0;
}
close $sock;
my $mc = Cache::Memcached->new(
servers => [ '127.0.0.1:11211', '127.1:11211' ],
);
$mc->get('1');
pass("1-1");
$mc->get('2');
pass("1-2");
my $mc2 = Cache::Memcached->new(
servers => [ '127.0.0.1:11211', '127.1:11211' ],
);
$mc2->get('1');
pass("2-1");
$mc->get('1');
pass("2-2");
$mc->disconnect_all();
$mc2->get('1');
pass("2-1");
$mc->get('1');
pass("2-2");
$mc->get('2');
pass("2-3");
$mc2->get('2');
pass("2-4");