├── .shipit ├── ChangeLog ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── TODO ├── dev ├── bench.pl ├── bench_noreply.pl ├── cons-hash.pl └── minibench.pl ├── lib └── Cache │ ├── Memcached.pm │ └── Memcached │ └── GetParser.pm └── t ├── 01_use.t ├── 02_keys.t ├── 03_stats.t ├── 04_noreply.t ├── 05_reconnect_timeout.t ├── 06_utf8_key.t ├── 100_flush_bug.t └── 101_multiple_clients.t /.shipit: -------------------------------------------------------------------------------- 1 | # auto-generated shipit config file. 2 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN 3 | 4 | git.tagpattern = %v 5 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2012-05-19: version 1.30 2 | 3 | * Fix buck2sock corruption that causes errors like 4 | "No map found matching for GLOB" or "No sock found for" (hachi@cpan.org) 5 | https://rt.cpan.org/Ticket/Display.html?id=62872 6 | 7 | * Fix t/05_reconnect_timeout.t to not fail on networks that fast-reject 8 | TEST-NET-1 https://rt.cpan.org/Ticket/Display.html?id=74500 9 | 10 | * Fix warning about undefined value in GetParser.pm (kost@ropnet.ru) 11 | https://rt.cpan.org/Ticket/Display.html?id=31067 12 | 13 | * Add documentation of connect_timeout and select_timeout 14 | https://rt.cpan.org/Ticket/Display.html?id=30904 15 | 16 | 2010-06-17: version 1.29 17 | 18 | * fix warnings spew if calling stats on a down server 19 | 20 | * fix buck2sock confusion (Eddie Canales) 21 | 22 | * quell ipv6-related warning 23 | https://rt.cpan.org/Ticket/Display.html?id=51761 24 | 25 | 2009-10-21: version 1.28 26 | 27 | * IPv6 support (https://rt.cpan.org/Ticket/Display.html?id=50577) 28 | 29 | * Add Encode.pm requirement to Makefile.PL for perl 5.6.x (Ask). 30 | 31 | 2009-09-22: version 1.27 32 | 33 | * Fix get() with utf-8 keys (athomason) 34 | 35 | * "stats malloc" command is gone in 1.4; remove those tests (athomason) 36 | 37 | * Add append/prepend support (dormando) 38 | 39 | * Fix occasional failure in the 100_flush_bug.t test (Ask Bjørn Hansen) 40 | 41 | 2009-05-04: version 1.26 42 | 43 | * don't include "stats sizes" by default in the stats method, 44 | as that can hang big servers for a few seconds (Brad Fitzpatrick) 45 | 46 | 2009-05-02: version 1.25 47 | 48 | * Clear @buck2sock when calling disconnect_all. (Dennis Stosberg, 49 | [rt.cpan.org #45560] 50 | 51 | * Reconnects to a dead connection shouldn't happen every time when the 52 | connection has never succeded. Apply the dead timeout to sockets that 53 | never even came up. Add a test. 54 | 55 | * Warn when trying to put undef values into memcache. 56 | (Henry Lyne ) 57 | 58 | * flush_all now only returns success if there is a proper reply from all 59 | servers - Yann Kerherve 60 | 61 | * 'noreply' support from Tomash Brechko 62 | 63 | * various test updates from Ronald J Kimball 64 | 65 | 2007-07-17: version 1.24 66 | 67 | * update the stats method, including tests for it 68 | (Ronald J Kimball ) 69 | 70 | * arguments to 'new' constructor can be %hash or $hashref now 71 | (previously was only $hashref) 72 | 73 | * work around a Perl segfault (Matthieu PATOU ) 74 | see http://lists.danga.com/pipermail/memcached/2007-June/004511.html 75 | 76 | 2007-06-19: version 1.23 77 | 78 | * add 'remove' as an alias for 'delete' (Dave Cardwell ) 79 | 80 | 2007-06-18: version 1.22 81 | 82 | * lost connection handling broken due to wrong %sock_map indexing 83 | http://rt.cpan.org/Public/Bug/Display.html?id=27181 84 | fix from RHESA 85 | 86 | * let parser_class be configured as a constructor option, 87 | defaulting to XS if available, else regular. (unless 88 | $ENV{NO_XS} is set, in which case the default is regular) 89 | 90 | 2007-05-02: version 1.21 91 | 92 | * new faster optional interface for GetParser subclasses. doing 93 | this release so upcoming Cache::Memcached::GetParserXS can 94 | depend on this. otherwise this release isn't interesting. 95 | 96 | 2007-04-16: version 1.20 97 | 98 | * fix "Warning produced when flush_all called" from CDENT 99 | http://rt.cpan.org/Public/Bug/Display.html?id=22181 100 | 101 | * support access via unix domain sockets. (Nathan Neulinger ) 102 | 103 | * abstract out response parsing into own class, and add XS-module 104 | detection, so if you have the XS (C) version, things'll be faster. 105 | that part's not done yet. 106 | 107 | 2006-07-03 108 | * don't use dual scalar/glob sockets. makes it all profilable 109 | again under SmallProf, DProf, and Devel::Profiler, all three 110 | of which used to barf on those weird sockets previously 111 | * only init_buckets once, when servers are changed 112 | * don't call sock_to_host and get_sock as much: cache closer 113 | in get_multi 114 | * more internal caching (buck2sock, etc) 115 | * fast paths for namespaces/single sock/etc in a few more places 116 | * general micro-speedups all over 117 | 118 | 2006-06-27 119 | * patch from Maxim Dounin to fix a typo 120 | which caused no_rehash flag to not work. 121 | * release 1.18 122 | 123 | 2006-04-29 124 | * flush_all command from Patrick Michael Kane 125 | * document namespaces 126 | * release 1.17 127 | 128 | 2006-04-29 129 | * fix stats method (people have only been asking since 2004 :-/) 130 | * add tests 131 | * move Memcached to lib/Cache directory to be more CPAN-friendly 132 | * release 1.16 133 | 134 | 2005-09-20 135 | * configurable connect delays and callback on connect failure (brad) 136 | * release 1.15 137 | 138 | 2005-08-09 139 | * _connect_sock never works in blocking mode because of a bug in setting 140 | the default timeout. (Gaal) 141 | 142 | 2004-07-27 143 | * release 1.14 144 | 145 | 2004-07-27 146 | * kill buggy, slow ord() _hashfunc, replace with crc32. 147 | this adds String::CRC32 as a dependency. thanks to 148 | everybody's feedback on the mailing list. 149 | 150 | 2004-07-19 151 | * don't use pos() because it doesn't seem to work in 152 | taint mode. use $+[0] instead. (Dave Evans <..@djce.org.uk>) 153 | 154 | 2004-06-19 155 | * support multiple paths to memcache nodes (Brad) 156 | see 'set_pref_ip' 157 | 158 | 2004-05-30 159 | * release version 1.13 160 | 161 | 2004-05-26 (Whitaker ) 162 | * quiet warning 163 | 164 | 2004-05-25 (Whitaker ) 165 | * get_multi shouldn't modify caller's @_ 166 | 167 | 2004-05-18 (Michael ) 168 | * namespace support 169 | * use fields 170 | 171 | 2004-05-16 (Alexei Kozlov ) 172 | * remove warnings with vec 173 | 174 | 2004-04-09 (brad) 175 | * in perl 5.6, trap errors dethawing 5.8 storable objects 176 | and instead treat it like a cache miss 177 | 178 | 2004-04-01 179 | * use $! and not %! for perl 5.6 compat (Dave Evans <..@djce.org.uk>) 180 | * don't mark whole IP dead anymore when a node is down (Jason Titus ) 181 | * start version numbering (Jamie McCarthy ) 182 | 183 | 2004-03-09 (Brad/Avva) 184 | * _oneline can return more than one line (but always on a line break), 185 | so caller must decide when it's really time to quit. had to modify 186 | run_command to know that. (which is used by stats) 187 | 188 | 2004-03-05 (Dave Evans <..@djce.org.uk>) 189 | * Here's a really trivial patch for the Perl binding, 190 | Cache::Memcached. The bug is that the module assumes that the 191 | currently select()ed filehandle is STDOUT, but this might not be 192 | the case. So this patch ensures that the select()ed filehandle is 193 | preserved, not forced to STDOUT. 194 | 195 | 2004-02-29 (Brad) 196 | * add readonly option 197 | 198 | 2004-02-27 (Avva) 199 | * Cleaner handling of the case when _oneline is called without a 200 | line parameter (i.e. not to send anything, just read a line from 201 | the socket). Make it depend on $line being defined only, 202 | regardless of its content (thanks Brad!). 203 | 204 | 2004-02-25 (Avva) 205 | * Asyncify all I/O, finally get rid of alarm() yuckiness, unify all 206 | one-liner command/responses into a single internal API. 207 | 208 | 2004-02-17 209 | * document in POD the delete method 210 | 211 | 2004-02-03 212 | * fix bug with 2k read boundaries falling in the middle 213 | of "VALUE ..." or "END" lines, thus halting future 214 | parsing and responses. (eek!) 215 | * version 1.0.12 216 | 217 | 2003-12-01 218 | * merge stats/stats_reset patch from Jamie McCarthy 219 | * trailing whitespace cleanup 220 | 221 | 2003-11-08 222 | * work on Solaris/BSD where there's no MSG_NOSIGNAL. 223 | the expense is extra syscalls to change the local 224 | SIGPIPE handler all the time. in the future, it'd 225 | be nice to have an option so Solaris/BSD callers 226 | can say, "Hey, I've turned off SIGPIPE globally, 227 | don't worry about it." 228 | 229 | 2003-10-26 230 | * add a test file, so automated CPAN test hosts are happy 231 | * check MSG_NOSIGNAL immediately on module load, not on use, 232 | so Solaris dies early. (still on TODO to fix, but better 233 | to fail loudly) 234 | * version 1.0.11 235 | 236 | 2003-10-25 237 | * version 1.0.10, rename to Cache::Memcached, upload to CPAN 238 | 239 | 2003-10-18 240 | * implement read/write timeouts everywhere. Now the client shouldn't 241 | hang if the server machine goes down unexpectedly. (avva) 242 | 243 | 2003-10-16 244 | * use Storable::nfreeze instead of freeze, so hosts from different 245 | architectures can all use the same data. (all must use Perl, though. 246 | the different memcache APIs all store/pickle/serialize data differently) 247 | Suggestion by Jason Titus 248 | 249 | 2003-10-06 250 | * fix _incrdecr to return complete number, not just first 251 | digit (thanks to Ryan T. Dean) 252 | * release version 1.0.9 253 | 254 | 2003-10-04 255 | * document expiration times in POD (thanks to Tim Bunce 256 | for noting the omission) 257 | * release version 1.0.8 258 | 259 | 2003-10-03 260 | * add connect timeout of 0.25s, for dead host detection. 261 | We had 1 second a couple revs ago, but lost it when 262 | ditching IO::Socket module. (avva) 263 | 264 | 2003-10-02 265 | * fix _incrdecr with explicit-hashvalue keys (whitaker) 266 | 267 | 2003-10-01 268 | * add run_command API call. TODO: document, and document 269 | the $exptime on the setters 270 | 271 | 2003-09-30 272 | * use send instead of print, so we can set MSG_NOSIGNAL 273 | and not get SIGPIPES, which avoids 3 syscalls of localizing 274 | $SIG{PIPE} and sends everything at once, instead of 4k 275 | stdio chunks. in review: stdio buffered in, send unbuffered 276 | out. TODO: setvbuf so reads are buffered at more than 4k. 277 | 278 | 2003-09-29 279 | * yet faster parsing 280 | * switch to stdio/perlio instead of raw io: more correct, 281 | simpler parsing code. 282 | 283 | 2003-09-28 284 | * prevent some warnings 285 | * faster get() call that doesn't use get_multi() 286 | * optimizations for single-server case 287 | * use socket APIs directly, instead of uber-slow IO::* modules 288 | * new faster _load_items parsing 289 | 290 | 2003-09-04 291 | * emit debug when set/add/replace fails, in addition to succeed 292 | 293 | Version 1.0.7 294 | -- compression support (Brad Whitaker) 295 | 296 | Version 1.0.6 297 | -- incr/decr client support 298 | -- make delete optionally take second argument (server now supports 299 | a delay time on delete) 300 | -- doc updates from Jamie McCarthy 301 | -- better hashing after dead host detection: new requests go to different 302 | remaining hosts, instead of all to the same one. 303 | 304 | Version 1.0.2 305 | -- initial release, about. 306 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | ChangeLog 2 | MANIFEST 3 | MANIFEST.SKIP 4 | Makefile.PL 5 | README 6 | TODO 7 | lib/Cache/Memcached.pm 8 | lib/Cache/Memcached/GetParser.pm 9 | t/01_use.t 10 | t/02_keys.t 11 | t/03_stats.t 12 | t/04_noreply.t 13 | t/05_reconnect_timeout.t 14 | t/06_utf8_key.t 15 | t/100_flush_bug.t 16 | t/101_multiple_clients.t 17 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^dev/ 2 | 3 | # Avoid version control files. 4 | \bRCS\b 5 | \bCVS\b 6 | ,v$ 7 | \B\.svn\b 8 | \.git 9 | 10 | # Avoid Makemaker generated and utility files. 11 | \bMANIFEST\.bak 12 | \bMakefile$ 13 | \bblib/ 14 | \bMakeMaker-\d 15 | \bpm_to_blib$ 16 | 17 | # Avoid Module::Build generated and utility files. 18 | \bBuild$ 19 | \b_build/ 20 | 21 | # Avoid temp and backup files. 22 | ~$ 23 | \.old$ 24 | \#$ 25 | \b\.# 26 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use ExtUtils::MakeMaker; 2 | WriteMakefile( 'NAME' => 'Cache::Memcached', 3 | 'VERSION_FROM' => 'lib/Cache/Memcached.pm', 4 | 'PREREQ_PM' => { 5 | 'Storable' => 0, 6 | 'Time::HiRes' => 0, 7 | 'String::CRC32' => 0, 8 | 'Encode' => 0, 9 | }, 10 | ($] >= 5.005 ? 11 | (ABSTRACT_FROM => 'lib/Cache/Memcached.pm', 12 | AUTHOR => 'Brad Fitzpatrick ') : ()), 13 | ); 14 | 15 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is the Perl API for memcached, a distributed memory cache daemon. 2 | See the documentation within the module for details on its use. 3 | 4 | Information on the big picture is available at: 5 | 6 | http://www.danga.com/memcached/ 7 | 8 | Feel free to join the mailing list and ask any questions. 9 | 10 | -- 11 | Brad Fitzpatrick 12 | brad@danga.com 13 | 14 | 15 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | (currently empty) 2 | 3 | 4 | -------------------------------------------------------------------------------- /dev/bench.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 10 | Timeout => 3); 11 | if ($msock) { 12 | plan tests => 9; 13 | } else { 14 | plan skip_all => "No memcached instance running at $testaddr\n"; 15 | exit 0; 16 | } 17 | 18 | my $keys = 800; 19 | 20 | my $memd = Cache::Memcached->new({ 21 | # servers => [ $testaddr, $testaddr ], 22 | servers => [ $testaddr ], 23 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 24 | }); 25 | 26 | my %correct; 27 | for my $num (1..$keys) { 28 | $correct{"key$num"} = "key$num " . ("-" x ($num * 50)); 29 | $memd->set("key$num", $correct{"key$num"}) 30 | or die "Failed to init $num"; 31 | } 32 | 33 | srand(1); 34 | my $to = shift || 3000; 35 | for (1..$to) { 36 | warn "$_ / $to\n" if $_ % 100 == 0; 37 | my @multi = map { "key$_" } map { int(rand($keys * 2)) + 1 } (1..40); 38 | my $get = $memd->get_multi(@multi); 39 | #use Data::Dumper; 40 | #print Dumper(\@multi, $get); 41 | for (0..4) { # was 4 42 | my $k = $multi[$_]; 43 | die "no match for '$k': $get->{$k} vs $correct{$k}" unless $get->{$k} eq $correct{$k}; 44 | } 45 | } 46 | 47 | 48 | __END__ 49 | 50 | ok($memd->set("key1", "val1"), "set succeeded"); 51 | 52 | is($memd->get("key1"), "val1", "get worked"); 53 | ok(! $memd->add("key1", "val-replace"), "add properly failed"); 54 | ok($memd->add("key2", "val2"), "add worked on key2"); 55 | is($memd->get("key2"), "val2", "get worked"); 56 | 57 | ok($memd->replace("key2", "val-replace"), "replace worked"); 58 | ok(! $memd->replace("key-noexist", "bogus"), "replace failed"); 59 | 60 | my $stats = $memd->stats; 61 | ok($stats, "got stats"); 62 | is(ref $stats, "HASH", "is a hashref"); 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /dev/bench_noreply.pl: -------------------------------------------------------------------------------- 1 | #! /usr/bin/perl 2 | # 3 | use warnings; 4 | use strict; 5 | 6 | # Note: you may have to set PERL5LIB to point to the module. 7 | use Cache::Memcached; 8 | 9 | use FindBin; 10 | 11 | @ARGV == 1 or @ARGV == 2 12 | or die "Usage: $FindBin::Script HOST:PORT [COUNT]\n"; 13 | 14 | # Note that it's better to run the test over the wire, because for 15 | # localhost the task may become CPU bound. 16 | my $addr = $ARGV[0]; 17 | my $count = $ARGV[1] || 10_000; 18 | 19 | my $memd = Cache::Memcached->new({ 20 | servers => [ $addr ], 21 | namespace => '' 22 | }); 23 | 24 | die "$!\n" unless $memd; 25 | 26 | 27 | # By running 'noreply' test first we also ensure there are no reply 28 | # packets left in the network. 29 | foreach my $noreply (1, 0) { 30 | use Time::HiRes qw(gettimeofday tv_interval); 31 | 32 | print "'noreply' is ", $noreply ? "enabled" : "disabled", ":\n"; 33 | my $param = $noreply ? 'noreply' : ''; 34 | my $res; 35 | 36 | my $start = [gettimeofday]; 37 | if ($noreply) { 38 | foreach (1 .. $count) { 39 | $memd->add("foo", 1); 40 | $memd->set("foo", 1); 41 | $memd->replace("foo", 1); 42 | $memd->incr("foo", 1); 43 | $memd->decr("foo", 1); 44 | $memd->delete("foo"); 45 | } 46 | } else { 47 | foreach (1 .. $count) { 48 | $res = $memd->add("foo", 1); 49 | $res = $memd->set("foo", 1); 50 | $res = $memd->replace("foo", 1); 51 | $res = $memd->incr("foo", 1); 52 | $res = $memd->decr("foo", 1); 53 | $res = $memd->delete("foo"); 54 | } 55 | } 56 | my $end = [gettimeofday]; 57 | printf("update methods: %.2f secs\n\n", tv_interval($start, $end)); 58 | } 59 | -------------------------------------------------------------------------------- /dev/cons-hash.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use Digest::SHA1 qw(sha1); 5 | use String::CRC32 qw(crc32);; 6 | use Data::Dumper; 7 | 8 | my $set = Set::ConsistentHash->new; 9 | $set->modify_targets( 10 | A => 1, 11 | B => 1, 12 | C => 2, 13 | ); 14 | 15 | my $set2 = Set::ConsistentHash->new; 16 | $set2->modify_targets( 17 | A => 1, 18 | B => 1, 19 | C => 1, 20 | ); 21 | 22 | #print Dumper($set->bucket_counts); 23 | #print Dumper($set2->bucket_counts); 24 | 25 | 26 | if (0) { 27 | my %matched; 28 | my $total_trials = 100_000; 29 | for my $n (1..$total_trials) { 30 | my $rand = crc32("trial$n"); 31 | my $server = $set->target_of_point($rand); 32 | #print "matched $rand = $server\n"; 33 | $matched{$server}++; 34 | } 35 | 36 | foreach my $s ($set->targets) { 37 | printf("$s: expected=%0.02f%% actual=%0.02f%%\n", # space=%0.02f%%\n", 38 | $set->weight_percentage($s), 39 | 100 * $matched{$s} / $total_trials, 40 | #($space{$s} / 2**32) * 100, 41 | ); 42 | } 43 | } 44 | 45 | if (1) { 46 | my $total_trials = 100_000; 47 | my %tran; 48 | for my $n (1..$total_trials) { 49 | my $rand = crc32("trial$n"); 50 | #my $s1 = $set->target_of_point($rand); 51 | #my $s2 = $set2->target_of_point($rand); 52 | 53 | my $s1 = $set->target_of_bucket($rand); 54 | my $s2 = $set2->target_of_bucket($rand); 55 | $tran{"$s1-$s2"}++; 56 | $tran{"$s1-"}++; 57 | $tran{"-$s2"}++; 58 | } 59 | 60 | print Dumper(\%tran); 61 | } 62 | 63 | 64 | ############################################################################ 65 | 66 | package Set::ConsistentHash; 67 | use strict; 68 | use Digest::SHA1 qw(sha1); 69 | 70 | # creates a new consistent hashing set with no targets. you'll need to add targets. 71 | sub new { 72 | my ($class) = @_; 73 | return bless { 74 | weights => {}, # $target => integer $weight 75 | points => {}, # 32-bit value points on 'circle' => \$target 76 | order => [], # 32-bit points, sorted 77 | buckets => undef, # when requested, arrayref of 1024 buckets mapping to targets 78 | total_weight => undef, # when requested, total weight of all targets 79 | }, $class; 80 | } 81 | 82 | # returns sorted list of all configured $targets 83 | sub targets { 84 | my $self = shift; 85 | return sort keys %{$self->{weights}}; 86 | } 87 | 88 | 89 | # returns sum of all target's weight 90 | sub total_weight { 91 | my $self = shift; 92 | return $self->{total_weight} if defined $self->{total_weight}; 93 | my $sum = 0; 94 | foreach my $val (values %{$self->{weights}}) { 95 | $sum += $val; 96 | } 97 | return $self->{total_weight} = $sum; 98 | } 99 | 100 | # returns the configured weight percentage [0,100] of a target. 101 | sub weight_percentage { 102 | my ($self, $target) = @_; 103 | return 0 unless $self->{weights}{$target}; 104 | return 100 * $self->{weights}{$target} / $self->total_weight; 105 | } 106 | 107 | # remove all targets 108 | sub reset_targets { 109 | my $self = shift; 110 | $self->modify_targets(map { $_ => 0 } $self->targets); 111 | } 112 | 113 | # add/modify targets. parameters are %weights: $target -> $weight 114 | sub modify_targets { 115 | my ($self, %weights) = @_; 116 | 117 | # uncache stuff: 118 | $self->{total_weight} = undef; 119 | $self->{buckets} = undef; 120 | 121 | while (my ($target, $weight) = each %weights) { 122 | if ($weight) { 123 | $self->{weights}{$target} = $weight; 124 | } else { 125 | delete $self->{weight}{$target}; 126 | } 127 | } 128 | $self->_redo_circle; 129 | } 130 | *modify_target = \&modify_targets; 131 | 132 | sub _redo_circle { 133 | my $self = shift; 134 | 135 | my $pts = $self->{points} = {}; 136 | while (my ($target, $weight) = each %{$self->{weights}}) { 137 | my $num_pts = $weight * 100; 138 | foreach my $ptn (1..$num_pts) { 139 | my $key = "$target-$ptn"; 140 | my $val = unpack("L", substr(sha1($key), 0, 4)); 141 | $pts->{$val} = \$target; 142 | } 143 | } 144 | 145 | $self->{order} = [ sort { $a <=> $b } keys %$pts ]; 146 | } 147 | 148 | # returns arrayref of 1024 buckets. each array element is the $target for that bucket index. 149 | sub buckets { 150 | my $self = shift; 151 | return $self->{buckets} if $self->{buckets}; 152 | my $buckets = $self->{buckets} = []; 153 | my $by = 2**22; # 2**32 / 2**10 (1024) 154 | for my $n (0..1023) { 155 | my $pt = $n * $by; 156 | $buckets->[$n] = $self->target_of_point($pt); 157 | } 158 | 159 | return $buckets; 160 | } 161 | 162 | # returns hashref of $target -> $number of occurences in 1024 buckets 163 | sub bucket_counts { 164 | my $self = shift; 165 | my $ct = {}; 166 | foreach my $t (@{ $self->buckets }) { 167 | $ct->{$t}++; 168 | } 169 | return $ct; 170 | } 171 | 172 | # given an integer, returns $target (after modding on 1024 buckets) 173 | sub target_of_bucket { 174 | my ($self, $bucketpos) = @_; 175 | return ($self->{buckets} || $self->buckets)->[$bucketpos % 1024]; 176 | } 177 | 178 | # given a $point [0,2**32), returns the $target that's next going around the circle 179 | sub target_of_point { 180 | my ($self, $pt) = @_; # $pt is 32-bit unsigned integer 181 | 182 | my $order = $self->{order}; 183 | my $circle_pt = $self->{points}; 184 | 185 | my ($lo, $hi) = (0, scalar(@$order)-1); # inclusive candidates 186 | 187 | while (1) { 188 | my $mid = int(($lo + $hi) / 2); 189 | my $val_at_mid = $order->[$mid]; 190 | my $val_one_below = $mid ? $order->[$mid-1] : 0; 191 | 192 | # match 193 | return ${ $circle_pt->{$order->[$mid]} } if 194 | $pt <= $val_at_mid && $pt > $val_one_below; 195 | 196 | # wrap-around match 197 | return ${ $circle_pt->{$order->[0]} } if 198 | $lo == $hi; 199 | 200 | # too low, go up. 201 | if ($val_at_mid < $pt) { 202 | $lo = $mid + 1; 203 | $lo = $hi if $lo > $hi; 204 | } 205 | # too high 206 | else { 207 | $hi = $mid - 1; 208 | $hi = $lo if $hi < $lo; 209 | } 210 | 211 | next; 212 | } 213 | }; 214 | -------------------------------------------------------------------------------- /dev/minibench.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 10 | Timeout => 3); 11 | if ($msock) { 12 | plan tests => 9; 13 | } else { 14 | plan skip_all => "No memcached instance running at $testaddr\n"; 15 | exit 0; 16 | } 17 | 18 | my $keys = 800; 19 | 20 | my $memd = Cache::Memcached->new({ 21 | # servers => [ $testaddr, $testaddr ], 22 | servers => [ $testaddr ], 23 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 24 | }); 25 | 26 | my %correct; 27 | for my $num (1..$keys) { 28 | $correct{"key$num"} = "key$num " . ("-" x ($num * 1)); # 1 was 50 29 | $memd->set("key$num", $correct{"key$num"}) 30 | or die "Failed to init $num"; 31 | } 32 | 33 | srand(1); 34 | my $to = 3000; # was 3000 35 | for (1..$to) { 36 | warn "$_ / $to\n" if $_ % 100 == 0; 37 | my @multi = map { "key$_" } map { int(rand($keys * 2)) + 1 } (1..40); 38 | my $get = $memd->get_multi(@multi); 39 | #use Data::Dumper; 40 | #print Dumper(\@multi, $get); 41 | for (0..4) { # was 4 42 | my $k = $multi[$_]; 43 | die "no match for '$k': $get->{$k} vs $correct{$k}" unless $get->{$k} eq $correct{$k}; 44 | } 45 | } 46 | 47 | 48 | __END__ 49 | 50 | ok($memd->set("key1", "val1"), "set succeeded"); 51 | 52 | is($memd->get("key1"), "val1", "get worked"); 53 | ok(! $memd->add("key1", "val-replace"), "add properly failed"); 54 | ok($memd->add("key2", "val2"), "add worked on key2"); 55 | is($memd->get("key2"), "val2", "get worked"); 56 | 57 | ok($memd->replace("key2", "val-replace"), "replace worked"); 58 | ok(! $memd->replace("key-noexist", "bogus"), "replace failed"); 59 | 60 | my $stats = $memd->stats; 61 | ok($stats, "got stats"); 62 | is(ref $stats, "HASH", "is a hashref"); 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /lib/Cache/Memcached.pm: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | # 3 | # Copyright (c) 2003, 2004 Brad Fitzpatrick 4 | # 5 | # See COPYRIGHT section in pod text below for usage and distribution rights. 6 | # 7 | 8 | package Cache::Memcached; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | no strict 'refs'; 14 | use Storable (); 15 | use Socket qw( MSG_NOSIGNAL PF_INET PF_UNIX IPPROTO_TCP SOCK_STREAM ); 16 | use IO::Handle (); 17 | use Time::HiRes (); 18 | use String::CRC32; 19 | use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN ); 20 | use Cache::Memcached::GetParser; 21 | use Encode (); 22 | use fields qw{ 23 | debug no_rehash stats compress_threshold compress_enable stat_callback 24 | readonly select_timeout namespace namespace_len servers active buckets 25 | pref_ip 26 | bucketcount _single_sock _stime 27 | connect_timeout cb_connect_fail 28 | parser_class 29 | buck2sock buck2sock_generation 30 | }; 31 | 32 | # flag definitions 33 | use constant F_STORABLE => 1; 34 | use constant F_COMPRESS => 2; 35 | 36 | # size savings required before saving compressed value 37 | use constant COMPRESS_SAVINGS => 0.20; # percent 38 | 39 | use vars qw($VERSION $HAVE_ZLIB $FLAG_NOSIGNAL $HAVE_SOCKET6); 40 | $VERSION = "1.30"; 41 | 42 | BEGIN { 43 | $HAVE_ZLIB = eval "use Compress::Zlib (); 1;"; 44 | $HAVE_SOCKET6 = eval "use Socket6 qw(AF_INET6 PF_INET6); 1;"; 45 | } 46 | 47 | my $HAVE_XS = eval "use Cache::Memcached::GetParserXS; 1;"; 48 | $HAVE_XS = 0 if $ENV{NO_XS}; 49 | 50 | my $parser_class = $HAVE_XS ? "Cache::Memcached::GetParserXS" : "Cache::Memcached::GetParser"; 51 | if ($ENV{XS_DEBUG}) { 52 | print "using parser: $parser_class\n"; 53 | } 54 | 55 | $FLAG_NOSIGNAL = 0; 56 | eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; }; 57 | 58 | my %host_dead; # host -> unixtime marked dead until 59 | my %cache_sock; # host -> socket 60 | my $socket_cache_generation = 1; # Set to 1 here because below the buck2sock_generation is set to 0, keep them in order. 61 | 62 | my $PROTO_TCP; 63 | 64 | our $SOCK_TIMEOUT = 2.6; # default timeout in seconds 65 | 66 | sub new { 67 | my Cache::Memcached $self = shift; 68 | $self = fields::new( $self ) unless ref $self; 69 | 70 | my $args = (@_ == 1) ? shift : { @_ }; # hashref-ify args 71 | 72 | $self->{'buck2sock'}= []; 73 | $self->{'buck2sock_generation'} = 0; 74 | $self->set_servers($args->{'servers'}); 75 | $self->{'debug'} = $args->{'debug'} || 0; 76 | $self->{'no_rehash'} = $args->{'no_rehash'}; 77 | $self->{'stats'} = {}; 78 | $self->{'pref_ip'} = $args->{'pref_ip'} || {}; 79 | $self->{'compress_threshold'} = $args->{'compress_threshold'}; 80 | $self->{'compress_enable'} = 1; 81 | $self->{'stat_callback'} = $args->{'stat_callback'} || undef; 82 | $self->{'readonly'} = $args->{'readonly'}; 83 | $self->{'parser_class'} = $args->{'parser_class'} || $parser_class; 84 | 85 | # TODO: undocumented 86 | $self->{'connect_timeout'} = $args->{'connect_timeout'} || 0.25; 87 | $self->{'select_timeout'} = $args->{'select_timeout'} || 1.0; 88 | $self->{namespace} = $args->{namespace} || ''; 89 | $self->{namespace_len} = length $self->{namespace}; 90 | 91 | return $self; 92 | } 93 | 94 | sub set_pref_ip { 95 | my Cache::Memcached $self = shift; 96 | $self->{'pref_ip'} = shift; 97 | } 98 | 99 | sub set_servers { 100 | my Cache::Memcached $self = shift; 101 | my ($list) = @_; 102 | $self->{'servers'} = $list || []; 103 | $self->{'active'} = scalar @{$self->{'servers'}}; 104 | $self->{'buckets'} = undef; 105 | $self->{'bucketcount'} = 0; 106 | $self->init_buckets; 107 | 108 | # We didn't close any sockets, so we reset the buck2sock generation, not increment the global socket cache generation. 109 | $self->{'buck2sock_generation'} = 0; 110 | 111 | $self->{'_single_sock'} = undef; 112 | if (@{$self->{'servers'}} == 1) { 113 | $self->{'_single_sock'} = $self->{'servers'}[0]; 114 | } 115 | 116 | return $self; 117 | } 118 | 119 | sub set_cb_connect_fail { 120 | my Cache::Memcached $self = shift; 121 | $self->{'cb_connect_fail'} = shift; 122 | } 123 | 124 | sub set_connect_timeout { 125 | my Cache::Memcached $self = shift; 126 | $self->{'connect_timeout'} = shift; 127 | } 128 | 129 | sub set_debug { 130 | my Cache::Memcached $self = shift; 131 | my ($dbg) = @_; 132 | $self->{'debug'} = $dbg || 0; 133 | } 134 | 135 | sub set_readonly { 136 | my Cache::Memcached $self = shift; 137 | my ($ro) = @_; 138 | $self->{'readonly'} = $ro; 139 | } 140 | 141 | sub set_norehash { 142 | my Cache::Memcached $self = shift; 143 | my ($val) = @_; 144 | $self->{'no_rehash'} = $val; 145 | } 146 | 147 | sub set_compress_threshold { 148 | my Cache::Memcached $self = shift; 149 | my ($thresh) = @_; 150 | $self->{'compress_threshold'} = $thresh; 151 | } 152 | 153 | sub enable_compress { 154 | my Cache::Memcached $self = shift; 155 | my ($enable) = @_; 156 | $self->{'compress_enable'} = $enable; 157 | } 158 | 159 | sub forget_dead_hosts { 160 | my Cache::Memcached $self = shift; 161 | %host_dead = (); 162 | 163 | # We need to globally recalculate our buck2sock in all objects, so we increment the global generation. 164 | $socket_cache_generation++; 165 | 166 | return 1; 167 | } 168 | 169 | sub set_stat_callback { 170 | my Cache::Memcached $self = shift; 171 | my ($stat_callback) = @_; 172 | $self->{'stat_callback'} = $stat_callback; 173 | } 174 | 175 | my %sock_map; # stringified-$sock -> "$ip:$port" 176 | 177 | sub _dead_sock { 178 | my ($self, $sock, $ret, $dead_for) = @_; 179 | if (my $ipport = $sock_map{$sock}) { 180 | my $now = time(); 181 | $host_dead{$ipport} = $now + $dead_for 182 | if $dead_for; 183 | delete $cache_sock{$ipport}; 184 | delete $sock_map{$sock}; 185 | } 186 | # We need to globally recalculate our buck2sock in all objects, so we increment the global generation. 187 | $socket_cache_generation++; 188 | 189 | return $ret; # 0 or undef, probably, depending on what caller wants 190 | } 191 | 192 | sub _close_sock { 193 | my ($self, $sock) = @_; 194 | if (my $ipport = $sock_map{$sock}) { 195 | close $sock; 196 | delete $cache_sock{$ipport}; 197 | delete $sock_map{$sock}; 198 | } 199 | 200 | # We need to globally recalculate our buck2sock in all objects, so we increment the global generation. 201 | $socket_cache_generation++; 202 | 203 | return 1; 204 | } 205 | 206 | sub _connect_sock { # sock, sin, timeout 207 | my ($sock, $sin, $timeout) = @_; 208 | $timeout = 0.25 if not defined $timeout; 209 | 210 | # make the socket non-blocking from now on, 211 | # except if someone wants 0 timeout, meaning 212 | # a blocking connect, but even then turn it 213 | # non-blocking at the end of this function 214 | 215 | if ($timeout) { 216 | IO::Handle::blocking($sock, 0); 217 | } else { 218 | IO::Handle::blocking($sock, 1); 219 | } 220 | 221 | my $ret = connect($sock, $sin); 222 | 223 | if (!$ret && $timeout && $!==EINPROGRESS) { 224 | 225 | my $win=''; 226 | vec($win, fileno($sock), 1) = 1; 227 | 228 | if (select(undef, $win, undef, $timeout) > 0) { 229 | $ret = connect($sock, $sin); 230 | # EISCONN means connected & won't re-connect, so success 231 | $ret = 1 if !$ret && $!==EISCONN; 232 | } 233 | } 234 | 235 | unless ($timeout) { # socket was temporarily blocking, now revert 236 | IO::Handle::blocking($sock, 0); 237 | } 238 | 239 | # from here on, we use non-blocking (async) IO for the duration 240 | # of the socket's life 241 | 242 | return $ret; 243 | } 244 | 245 | sub sock_to_host { # (host) #why is this public? I wouldn't have to worry about undef $self if it weren't. 246 | my Cache::Memcached $self = ref $_[0] ? shift : undef; 247 | my $host = $_[0]; 248 | return $cache_sock{$host} if $cache_sock{$host}; 249 | 250 | my $now = time(); 251 | my ($ip, $port) = $host =~ /(.*):(\d+)$/; 252 | if (defined($ip)) { 253 | $ip =~ s/[\[\]]//g; # get rid of optional IPv6 brackets 254 | } 255 | 256 | return undef if 257 | $host_dead{$host} && $host_dead{$host} > $now; 258 | my $sock; 259 | 260 | my $connected = 0; 261 | my $sin; 262 | my $proto = $PROTO_TCP ||= getprotobyname('tcp'); 263 | 264 | if ( index($host, '/') != 0 ) 265 | { 266 | # if a preferred IP is known, try that first. 267 | if ($self && $self->{pref_ip}{$ip}) { 268 | my $prefip = $self->{pref_ip}{$ip}; 269 | if ($HAVE_SOCKET6 && index($prefip, ':') != -1) { 270 | no strict 'subs'; # for PF_INET6 and AF_INET6, weirdly imported 271 | socket($sock, PF_INET6, SOCK_STREAM, $proto); 272 | $sock_map{$sock} = $host; 273 | $sin = Socket6::pack_sockaddr_in6($port, 274 | Socket6::inet_pton(AF_INET6, $prefip)); 275 | } else { 276 | socket($sock, PF_INET, SOCK_STREAM, $proto); 277 | $sock_map{$sock} = $host; 278 | $sin = Socket::sockaddr_in($port, Socket::inet_aton($prefip)); 279 | } 280 | 281 | if (_connect_sock($sock,$sin,$self->{connect_timeout})) { 282 | $connected = 1; 283 | } else { 284 | if (my $cb = $self->{cb_connect_fail}) { 285 | $cb->($prefip); 286 | } 287 | close $sock; 288 | } 289 | } 290 | 291 | # normal path, or fallback path if preferred IP failed 292 | unless ($connected) { 293 | if ($HAVE_SOCKET6 && index($ip, ':') != -1) { 294 | no strict 'subs'; # for PF_INET6 and AF_INET6, weirdly imported 295 | socket($sock, PF_INET6, SOCK_STREAM, $proto); 296 | $sock_map{$sock} = $host; 297 | $sin = Socket6::pack_sockaddr_in6($port, 298 | Socket6::inet_pton(AF_INET6, $ip)); 299 | } else { 300 | socket($sock, PF_INET, SOCK_STREAM, $proto); 301 | $sock_map{$sock} = $host; 302 | $sin = Socket::sockaddr_in($port, Socket::inet_aton($ip)); 303 | } 304 | 305 | my $timeout = $self ? $self->{connect_timeout} : 0.25; 306 | unless (_connect_sock($sock, $sin, $timeout)) { 307 | my $cb = $self ? $self->{cb_connect_fail} : undef; 308 | $cb->($ip) if $cb; 309 | return _dead_sock($self, $sock, undef, 20 + int(rand(10))); 310 | } 311 | } 312 | } else { # it's a unix domain/local socket 313 | socket($sock, PF_UNIX, SOCK_STREAM, 0); 314 | $sock_map{$sock} = $host; 315 | $sin = Socket::sockaddr_un($host); 316 | my $timeout = $self ? $self->{connect_timeout} : 0.25; 317 | unless (_connect_sock($sock,$sin,$timeout)) { 318 | my $cb = $self ? $self->{cb_connect_fail} : undef; 319 | $cb->($host) if $cb; 320 | return _dead_sock($self, $sock, undef, 20 + int(rand(10))); 321 | } 322 | } 323 | 324 | # make the new socket not buffer writes. 325 | my $old = select($sock); 326 | $| = 1; 327 | select($old); 328 | 329 | $cache_sock{$host} = $sock; 330 | 331 | return $sock; 332 | } 333 | 334 | sub get_sock { # (key) 335 | my Cache::Memcached $self = $_[0]; 336 | my $key = $_[1]; 337 | return $self->sock_to_host($self->{'_single_sock'}) if $self->{'_single_sock'}; 338 | return undef unless $self->{'active'}; 339 | my $hv = ref $key ? int($key->[0]) : _hashfunc($key); 340 | 341 | my $real_key = ref $key ? $key->[1] : $key; 342 | my $tries = 0; 343 | while ($tries++ < 20) { 344 | my $host = $self->{'buckets'}->[$hv % $self->{'bucketcount'}]; 345 | my $sock = $self->sock_to_host($host); 346 | return $sock if $sock; 347 | return undef if $self->{'no_rehash'}; 348 | $hv += _hashfunc($tries . $real_key); # stupid, but works 349 | } 350 | return undef; 351 | } 352 | 353 | sub init_buckets { 354 | my Cache::Memcached $self = shift; 355 | return if $self->{'buckets'}; 356 | my $bu = $self->{'buckets'} = []; 357 | foreach my $v (@{$self->{'servers'}}) { 358 | if (ref $v eq "ARRAY") { 359 | for (1..$v->[1]) { push @$bu, $v->[0]; } 360 | } else { 361 | push @$bu, $v; 362 | } 363 | } 364 | $self->{'bucketcount'} = scalar @{$self->{'buckets'}}; 365 | } 366 | 367 | sub disconnect_all { 368 | my Cache::Memcached $self = shift; 369 | my $sock; 370 | foreach $sock (values %cache_sock) { 371 | close $sock; 372 | } 373 | %cache_sock = (); 374 | 375 | # We need to globally recalculate our buck2sock in all objects, so we increment the global generation. 376 | $socket_cache_generation++; 377 | } 378 | 379 | # writes a line, then reads result. by default stops reading after a 380 | # single line, but caller can override the $check_complete subref, 381 | # which gets passed a scalarref of buffer read thus far. 382 | sub _write_and_read { 383 | my Cache::Memcached $self = shift; 384 | my ($sock, $line, $check_complete) = @_; 385 | my $res; 386 | my ($ret, $offset) = (undef, 0); 387 | 388 | $check_complete ||= sub { 389 | return (rindex($ret, "\r\n") + 2 == length($ret)); 390 | }; 391 | 392 | # state: 0 - writing, 1 - reading, 2 - done 393 | my $state = 0; 394 | 395 | # the bitsets for select 396 | my ($rin, $rout, $win, $wout); 397 | my $nfound; 398 | 399 | my $copy_state = -1; 400 | local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL; 401 | 402 | # the select loop 403 | while(1) { 404 | if ($copy_state!=$state) { 405 | last if $state==2; 406 | ($rin, $win) = ('', ''); 407 | vec($rin, fileno($sock), 1) = 1 if $state==1; 408 | vec($win, fileno($sock), 1) = 1 if $state==0; 409 | $copy_state = $state; 410 | } 411 | $nfound = select($rout=$rin, $wout=$win, undef, 412 | $self->{'select_timeout'}); 413 | last unless $nfound; 414 | 415 | if (vec($wout, fileno($sock), 1)) { 416 | $res = send($sock, $line, $FLAG_NOSIGNAL); 417 | next 418 | if not defined $res and $!==EWOULDBLOCK; 419 | unless ($res > 0) { 420 | $self->_close_sock($sock); 421 | return undef; 422 | } 423 | if ($res == length($line)) { # all sent 424 | $state = 1; 425 | } else { # we only succeeded in sending some of it 426 | substr($line, 0, $res, ''); # delete the part we sent 427 | } 428 | } 429 | 430 | if (vec($rout, fileno($sock), 1)) { 431 | $res = sysread($sock, $ret, 255, $offset); 432 | next 433 | if !defined($res) and $!==EWOULDBLOCK; 434 | if ($res == 0) { # catches 0=conn closed or undef=error 435 | $self->_close_sock($sock); 436 | return undef; 437 | } 438 | $offset += $res; 439 | $state = 2 if $check_complete->(\$ret); 440 | } 441 | } 442 | 443 | unless ($state == 2) { 444 | $self->_dead_sock($sock); # improperly finished 445 | return undef; 446 | } 447 | 448 | return $ret; 449 | } 450 | 451 | sub delete { 452 | my Cache::Memcached $self = shift; 453 | my ($key, $time) = @_; 454 | return 0 if ! $self->{'active'} || $self->{'readonly'}; 455 | my $stime = Time::HiRes::time() if $self->{'stat_callback'}; 456 | my $sock = $self->get_sock($key); 457 | return 0 unless $sock; 458 | 459 | $self->{'stats'}->{"delete"}++; 460 | $key = ref $key ? $key->[1] : $key; 461 | $time = $time ? " $time" : ""; 462 | my $cmd = "delete $self->{namespace}$key$time\r\n"; 463 | my $res = _write_and_read($self, $sock, $cmd); 464 | 465 | if ($self->{'stat_callback'}) { 466 | my $etime = Time::HiRes::time(); 467 | $self->{'stat_callback'}->($stime, $etime, $sock, 'delete'); 468 | } 469 | 470 | return defined $res && $res eq "DELETED\r\n"; 471 | } 472 | *remove = \&delete; 473 | 474 | sub add { 475 | _set("add", @_); 476 | } 477 | 478 | sub replace { 479 | _set("replace", @_); 480 | } 481 | 482 | sub set { 483 | _set("set", @_); 484 | } 485 | 486 | sub append { 487 | _set("append", @_); 488 | } 489 | 490 | sub prepend { 491 | _set("prepend", @_); 492 | } 493 | 494 | sub _set { 495 | my $cmdname = shift; 496 | my Cache::Memcached $self = shift; 497 | my ($key, $val, $exptime) = @_; 498 | return 0 if ! $self->{'active'} || $self->{'readonly'}; 499 | my $stime = Time::HiRes::time() if $self->{'stat_callback'}; 500 | my $sock = $self->get_sock($key); 501 | return 0 unless $sock; 502 | 503 | use bytes; # return bytes from length() 504 | 505 | my $app_or_prep = $cmdname eq 'append' || $cmdname eq 'prepend' ? 1 : 0; 506 | $self->{'stats'}->{$cmdname}++; 507 | my $flags = 0; 508 | $key = ref $key ? $key->[1] : $key; 509 | 510 | if (ref $val) { 511 | die "append or prepend cannot take a reference" if $app_or_prep; 512 | local $Carp::CarpLevel = 2; 513 | $val = Storable::nfreeze($val); 514 | $flags |= F_STORABLE; 515 | } 516 | warn "value for memkey:$key is not defined" unless defined $val; 517 | 518 | my $len = length($val); 519 | 520 | if ($self->{'compress_threshold'} && $HAVE_ZLIB && $self->{'compress_enable'} && 521 | $len >= $self->{'compress_threshold'} && !$app_or_prep) { 522 | 523 | my $c_val = Compress::Zlib::memGzip($val); 524 | my $c_len = length($c_val); 525 | 526 | # do we want to keep it? 527 | if ($c_len < $len*(1 - COMPRESS_SAVINGS)) { 528 | $val = $c_val; 529 | $len = $c_len; 530 | $flags |= F_COMPRESS; 531 | } 532 | } 533 | 534 | $exptime = int($exptime || 0); 535 | 536 | local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL; 537 | my $line = "$cmdname $self->{namespace}$key $flags $exptime $len\r\n$val\r\n"; 538 | 539 | my $res = _write_and_read($self, $sock, $line); 540 | 541 | if ($self->{'debug'} && $line) { 542 | chop $line; chop $line; 543 | print STDERR "Cache::Memcache: $cmdname $self->{namespace}$key = $val ($line)\n"; 544 | } 545 | 546 | if ($self->{'stat_callback'}) { 547 | my $etime = Time::HiRes::time(); 548 | $self->{'stat_callback'}->($stime, $etime, $sock, $cmdname); 549 | } 550 | 551 | return defined $res && $res eq "STORED\r\n"; 552 | } 553 | 554 | sub incr { 555 | _incrdecr("incr", @_); 556 | } 557 | 558 | sub decr { 559 | _incrdecr("decr", @_); 560 | } 561 | 562 | sub _incrdecr { 563 | my $cmdname = shift; 564 | my Cache::Memcached $self = shift; 565 | my ($key, $value) = @_; 566 | return undef if ! $self->{'active'} || $self->{'readonly'}; 567 | my $stime = Time::HiRes::time() if $self->{'stat_callback'}; 568 | my $sock = $self->get_sock($key); 569 | return undef unless $sock; 570 | $key = $key->[1] if ref $key; 571 | $self->{'stats'}->{$cmdname}++; 572 | $value = 1 unless defined $value; 573 | 574 | my $line = "$cmdname $self->{namespace}$key $value\r\n"; 575 | my $res = _write_and_read($self, $sock, $line); 576 | 577 | if ($self->{'stat_callback'}) { 578 | my $etime = Time::HiRes::time(); 579 | $self->{'stat_callback'}->($stime, $etime, $sock, $cmdname); 580 | } 581 | 582 | return undef unless defined $res && $res =~ /^(\d+)/; 583 | return $1; 584 | } 585 | 586 | sub get { 587 | my Cache::Memcached $self = $_[0]; 588 | my $key = $_[1]; 589 | 590 | # TODO: make a fast path for this? or just keep using get_multi? 591 | my $r = $self->get_multi($key); 592 | my $kval = ref $key ? $key->[1] : $key; 593 | 594 | # key reconstituted from server won't have utf8 on, so turn it off on input 595 | # scalar to allow hash lookup to succeed 596 | Encode::_utf8_off($kval) if Encode::is_utf8($kval); 597 | 598 | return $r->{$kval}; 599 | } 600 | 601 | sub get_multi { 602 | my Cache::Memcached $self = shift; 603 | return {} unless $self->{'active'}; 604 | $self->{'_stime'} = Time::HiRes::time() if $self->{'stat_callback'}; 605 | $self->{'stats'}->{"get_multi"}++; 606 | 607 | my %val; # what we'll be returning a reference to (realkey -> value) 608 | my %sock_keys; # sockref_as_scalar -> [ realkeys ] 609 | my $sock; 610 | 611 | if ($self->{'_single_sock'}) { 612 | $sock = $self->sock_to_host($self->{'_single_sock'}); 613 | unless ($sock) { 614 | return {}; 615 | } 616 | foreach my $key (@_) { 617 | my $kval = ref $key ? $key->[1] : $key; 618 | push @{$sock_keys{$sock}}, $kval; 619 | } 620 | } else { 621 | my $bcount = $self->{'bucketcount'}; 622 | my $sock; 623 | 624 | if ($self->{'buck2sock_generation'} != $socket_cache_generation) { 625 | $self->{'buck2sock_generation'} = $socket_cache_generation; 626 | $self->{'buck2sock'} = []; 627 | } 628 | 629 | KEY: 630 | foreach my $key (@_) { 631 | my ($hv, $real_key) = ref $key ? 632 | (int($key->[0]), $key->[1]) : 633 | ((crc32($key) >> 16) & 0x7fff, $key); 634 | 635 | my $tries; 636 | while (1) { 637 | my $bucket = $hv % $bcount; 638 | 639 | # this segfaults perl 5.8.4 (and others?) if sock_to_host returns undef... wtf? 640 | #$sock = $buck2sock[$bucket] ||= $self->sock_to_host($self->{buckets}[ $bucket ]) 641 | # and last; 642 | 643 | # but this variant doesn't crash: 644 | $sock = $self->{'buck2sock'}->[$bucket] || $self->sock_to_host($self->{buckets}[ $bucket ]); 645 | if ($sock) { 646 | $self->{'buck2sock'}->[$bucket] = $sock; 647 | last; 648 | } 649 | 650 | next KEY if $tries++ >= 20; 651 | $hv += _hashfunc($tries . $real_key); 652 | } 653 | 654 | push @{$sock_keys{$sock}}, $real_key; 655 | } 656 | } 657 | 658 | $self->{'stats'}->{"get_keys"} += @_; 659 | $self->{'stats'}->{"get_socks"} += keys %sock_keys; 660 | 661 | local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL; 662 | 663 | _load_multi($self, \%sock_keys, \%val); 664 | 665 | if ($self->{'debug'}) { 666 | while (my ($k, $v) = each %val) { 667 | print STDERR "MemCache: got $k = $v\n"; 668 | } 669 | } 670 | return \%val; 671 | } 672 | 673 | sub _load_multi { 674 | use bytes; # return bytes from length() 675 | my Cache::Memcached $self; 676 | my ($sock_keys, $ret); 677 | 678 | ($self, $sock_keys, $ret) = @_; 679 | 680 | # all keyed by $sockstr: 681 | my %reading; # $sockstr -> $sock. bool, whether we're reading from this socket 682 | my %writing; # $sockstr -> $sock. bool, whether we're writing to this socket 683 | my %buf; # buffers, for writing 684 | 685 | my %parser; # $sockstr -> Cache::Memcached::GetParser 686 | 687 | my $active_changed = 1; # force rebuilding of select sets 688 | 689 | my $dead = sub { 690 | my $sock = shift; 691 | print STDERR "killing socket $sock\n" if $self->{'debug'} >= 2; 692 | delete $reading{$sock}; 693 | delete $writing{$sock}; 694 | 695 | if (my $p = $parser{$sock}) { 696 | my $key = $p->current_key; 697 | delete $ret->{$key} if $key; 698 | } 699 | 700 | if ($self->{'stat_callback'}) { 701 | my $etime = Time::HiRes::time(); 702 | $self->{'stat_callback'}->($self->{'_stime'}, $etime, $sock, 'get_multi'); 703 | } 704 | 705 | close $sock; 706 | $self->_dead_sock($sock); 707 | }; 708 | 709 | # $finalize->($key, $flags) 710 | # $finalize->({ $key => $flags, $key => $flags }); 711 | my $finalize = sub { 712 | my $map = $_[0]; 713 | $map = {@_} unless ref $map; 714 | 715 | while (my ($k, $flags) = each %$map) { 716 | 717 | # remove trailing \r\n 718 | chop $ret->{$k}; chop $ret->{$k}; 719 | 720 | $ret->{$k} = Compress::Zlib::memGunzip($ret->{$k}) 721 | if $HAVE_ZLIB && $flags & F_COMPRESS; 722 | if ($flags & F_STORABLE) { 723 | # wrapped in eval in case a perl 5.6 Storable tries to 724 | # unthaw data from a perl 5.8 Storable. (5.6 is stupid 725 | # and dies if the version number changes at all. in 5.8 726 | # they made it only die if it unencounters a new feature) 727 | eval { 728 | $ret->{$k} = Storable::thaw($ret->{$k}); 729 | }; 730 | # so if there was a problem, just treat it as a cache miss. 731 | if ($@) { 732 | delete $ret->{$k}; 733 | } 734 | } 735 | } 736 | }; 737 | 738 | foreach (keys %$sock_keys) { 739 | my $ipport = $sock_map{$_} or die "No map found matching for $_"; 740 | my $sock = $cache_sock{$ipport} or die "No sock found for $ipport"; 741 | print STDERR "processing socket $_\n" if $self->{'debug'} >= 2; 742 | $writing{$_} = $sock; 743 | if ($self->{namespace}) { 744 | $buf{$_} = join(" ", 'get', (map { "$self->{namespace}$_" } @{$sock_keys->{$_}}), "\r\n"); 745 | } else { 746 | $buf{$_} = join(" ", 'get', @{$sock_keys->{$_}}, "\r\n"); 747 | } 748 | 749 | $parser{$_} = $self->{parser_class}->new($ret, $self->{namespace_len}, $finalize); 750 | } 751 | 752 | my $read = sub { 753 | my $sockstr = "$_[0]"; # $sock is $_[0]; 754 | my $p = $parser{$sockstr} or die; 755 | my $rv = $p->parse_from_sock($_[0]); 756 | if ($rv > 0) { 757 | # okay, finished with this socket 758 | delete $reading{$sockstr}; 759 | } elsif ($rv < 0) { 760 | $dead->($_[0]); 761 | } 762 | return $rv; 763 | }; 764 | 765 | # returns 1 when it's done, for success or error. 0 if still working. 766 | my $write = sub { 767 | my ($sock, $sockstr) = ($_[0], "$_[0]"); 768 | my $res; 769 | 770 | $res = send($sock, $buf{$sockstr}, $FLAG_NOSIGNAL); 771 | 772 | return 0 773 | if not defined $res and $!==EWOULDBLOCK; 774 | unless ($res > 0) { 775 | $dead->($sock); 776 | return 1; 777 | } 778 | if ($res == length($buf{$sockstr})) { # all sent 779 | $buf{$sockstr} = ""; 780 | 781 | # switch the socket from writing to reading 782 | delete $writing{$sockstr}; 783 | $reading{$sockstr} = $sock; 784 | return 1; 785 | } else { # we only succeeded in sending some of it 786 | substr($buf{$sockstr}, 0, $res, ''); # delete the part we sent 787 | } 788 | return 0; 789 | }; 790 | 791 | # the bitsets for select 792 | my ($rin, $rout, $win, $wout); 793 | my $nfound; 794 | 795 | # the big select loop 796 | while(1) { 797 | if ($active_changed) { 798 | last unless %reading or %writing; # no sockets left? 799 | ($rin, $win) = ('', ''); 800 | foreach (values %reading) { 801 | vec($rin, fileno($_), 1) = 1; 802 | } 803 | foreach (values %writing) { 804 | vec($win, fileno($_), 1) = 1; 805 | } 806 | $active_changed = 0; 807 | } 808 | # TODO: more intelligent cumulative timeout? 809 | # TODO: select is interruptible w/ ptrace attach, signal, etc. should note that. 810 | $nfound = select($rout=$rin, $wout=$win, undef, 811 | $self->{'select_timeout'}); 812 | last unless $nfound; 813 | 814 | # TODO: possible robustness improvement: we could select 815 | # writing sockets for reading also, and raise hell if they're 816 | # ready (input unread from last time, etc.) 817 | # maybe do that on the first loop only? 818 | foreach (values %writing) { 819 | if (vec($wout, fileno($_), 1)) { 820 | $active_changed = 1 if $write->($_); 821 | } 822 | } 823 | foreach (values %reading) { 824 | if (vec($rout, fileno($_), 1)) { 825 | $active_changed = 1 if $read->($_); 826 | } 827 | } 828 | } 829 | 830 | # if there're active sockets left, they need to die 831 | foreach (values %writing) { 832 | $dead->($_); 833 | } 834 | foreach (values %reading) { 835 | $dead->($_); 836 | } 837 | 838 | return; 839 | } 840 | 841 | sub _hashfunc { 842 | return (crc32($_[0]) >> 16) & 0x7fff; 843 | } 844 | 845 | sub flush_all { 846 | my Cache::Memcached $self = shift; 847 | 848 | my $success = 1; 849 | 850 | my @hosts = @{$self->{'buckets'}}; 851 | foreach my $host (@hosts) { 852 | my $sock = $self->sock_to_host($host); 853 | my @res = $self->run_command($sock, "flush_all\r\n"); 854 | $success = 0 unless (scalar @res == 1 && (($res[0] || "") eq "OK\r\n")); 855 | } 856 | 857 | return $success; 858 | } 859 | 860 | # returns array of lines, or () on failure. 861 | sub run_command { 862 | my Cache::Memcached $self = shift; 863 | my ($sock, $cmd) = @_; 864 | return () unless $sock; 865 | my $ret; 866 | my $line = $cmd; 867 | while (my $res = _write_and_read($self, $sock, $line)) { 868 | undef $line; 869 | $ret .= $res; 870 | last if $ret =~ /(?:OK|END|ERROR)\r\n$/; 871 | } 872 | chop $ret; chop $ret; 873 | return map { "$_\r\n" } split(/\r\n/, $ret); 874 | } 875 | 876 | sub stats { 877 | my Cache::Memcached $self = shift; 878 | my ($types) = @_; 879 | return 0 unless $self->{'active'}; 880 | return 0 unless !ref($types) || ref($types) eq 'ARRAY'; 881 | if (!ref($types)) { 882 | if (!$types) { 883 | # I don't much care what the default is, it should just 884 | # be something reasonable. Obviously "reset" should not 885 | # be on the list :) but other types that might go in here 886 | # include maps, cachedump, slabs, or items. Note that 887 | # this does NOT include 'sizes' anymore, as that can freeze 888 | # bug servers for a couple seconds. 889 | $types = [ qw( misc malloc self ) ]; 890 | } else { 891 | $types = [ $types ]; 892 | } 893 | } 894 | 895 | my $stats_hr = { }; 896 | 897 | # The "self" stat type is special, it only applies to this very 898 | # object. 899 | if (grep /^self$/, @$types) { 900 | $stats_hr->{'self'} = \%{ $self->{'stats'} }; 901 | } 902 | 903 | my %misc_keys = map { $_ => 1 } 904 | qw/ bytes bytes_read bytes_written 905 | cmd_get cmd_set connection_structures curr_items 906 | get_hits get_misses 907 | total_connections total_items 908 | /; 909 | 910 | # Now handle the other types, passing each type to each host server. 911 | my @hosts = @{$self->{'buckets'}}; 912 | HOST: foreach my $host (@hosts) { 913 | my $sock = $self->sock_to_host($host); 914 | next HOST unless $sock; 915 | TYPE: foreach my $typename (grep !/^self$/, @$types) { 916 | my $type = $typename eq 'misc' ? "" : " $typename"; 917 | my $lines = _write_and_read($self, $sock, "stats$type\r\n", sub { 918 | my $bref = shift; 919 | return $$bref =~ /^(?:END|ERROR)\r?\n/m; 920 | }); 921 | unless ($lines) { 922 | $self->_dead_sock($sock); 923 | next HOST; 924 | } 925 | 926 | $lines =~ s/\0//g; # 'stats sizes' starts with NULL? 927 | 928 | # And, most lines end in \r\n but 'stats maps' (as of 929 | # July 2003 at least) ends in \n. ?? 930 | my @lines = split(/\r?\n/, $lines); 931 | 932 | # Some stats are key-value, some are not. malloc, 933 | # sizes, and the empty string are key-value. 934 | # ("self" was handled separately above.) 935 | if ($typename =~ /^(malloc|sizes|misc)$/) { 936 | # This stat is key-value. 937 | foreach my $line (@lines) { 938 | my ($key, $value) = $line =~ /^(?:STAT )?(\w+)\s(.*)/; 939 | if ($key) { 940 | $stats_hr->{'hosts'}{$host}{$typename}{$key} = $value; 941 | } 942 | $stats_hr->{'total'}{$key} += $value 943 | if $typename eq 'misc' && $key && $misc_keys{$key}; 944 | $stats_hr->{'total'}{"malloc_$key"} += $value 945 | if $typename eq 'malloc' && $key; 946 | } 947 | } else { 948 | # This stat is not key-value so just pull it 949 | # all out in one blob. 950 | $lines =~ s/^END\r?\n//m; 951 | $stats_hr->{'hosts'}{$host}{$typename} ||= ""; 952 | $stats_hr->{'hosts'}{$host}{$typename} .= "$lines"; 953 | } 954 | } 955 | } 956 | 957 | return $stats_hr; 958 | } 959 | 960 | sub stats_reset { 961 | my Cache::Memcached $self = shift; 962 | my ($types) = @_; 963 | return 0 unless $self->{'active'}; 964 | 965 | HOST: foreach my $host (@{$self->{'buckets'}}) { 966 | my $sock = $self->sock_to_host($host); 967 | next HOST unless $sock; 968 | my $ok = _write_and_read($self, $sock, "stats reset"); 969 | unless (defined $ok && $ok eq "RESET\r\n") { 970 | $self->_dead_sock($sock); 971 | } 972 | } 973 | return 1; 974 | } 975 | 976 | 1; 977 | __END__ 978 | 979 | =head1 NAME 980 | 981 | Cache::Memcached - client library for memcached (memory cache daemon) 982 | 983 | =head1 SYNOPSIS 984 | 985 | use Cache::Memcached; 986 | 987 | $memd = new Cache::Memcached { 988 | 'servers' => [ "10.0.0.15:11211", "10.0.0.15:11212", "/var/sock/memcached", 989 | "10.0.0.17:11211", [ "10.0.0.17:11211", 3 ] ], 990 | 'debug' => 0, 991 | 'compress_threshold' => 10_000, 992 | }; 993 | $memd->set_servers($array_ref); 994 | $memd->set_compress_threshold(10_000); 995 | $memd->enable_compress(0); 996 | 997 | $memd->set("my_key", "Some value"); 998 | $memd->set("object_key", { 'complex' => [ "object", 2, 4 ]}); 999 | 1000 | $val = $memd->get("my_key"); 1001 | $val = $memd->get("object_key"); 1002 | if ($val) { print $val->{'complex'}->[2]; } 1003 | 1004 | $memd->incr("key"); 1005 | $memd->decr("key"); 1006 | $memd->incr("key", 2); 1007 | 1008 | =head1 DESCRIPTION 1009 | 1010 | This is the Perl API for memcached, a distributed memory cache daemon. 1011 | More information is available at: 1012 | 1013 | http://www.danga.com/memcached/ 1014 | 1015 | =head1 CONSTRUCTOR 1016 | 1017 | =over 4 1018 | 1019 | =item C 1020 | 1021 | Takes one parameter, a hashref of options. The most important key is 1022 | C, but that can also be set later with the C 1023 | method. The servers must be an arrayref of hosts, each of which is 1024 | either a scalar of the form C<10.0.0.10:11211> or an arrayref of the 1025 | former and an integer weight value. (The default weight if 1026 | unspecified is 1.) It's recommended that weight values be kept as low 1027 | as possible, as this module currently allocates memory for bucket 1028 | distribution proportional to the total host weights. 1029 | 1030 | Use C to set a compression threshold, in bytes. 1031 | Values larger than this threshold will be compressed by C and 1032 | decompressed by C. 1033 | 1034 | Use C to disable finding a new memcached server when one 1035 | goes down. Your application may or may not need this, depending on 1036 | your expirations and key usage. 1037 | 1038 | Use C to disable writes to backend memcached servers. Only 1039 | get and get_multi will work. This is useful in bizarre debug and 1040 | profiling cases only. 1041 | 1042 | Use C to prefix all keys with the provided namespace value. 1043 | That is, if you set namespace to "app1:" and later do a set of "foo" 1044 | to "bar", memcached is actually seeing you set "app1:foo" to "bar". 1045 | 1046 | Use C and C to set connection and 1047 | polling timeouts. The C defaults to .25 second, and 1048 | the C defaults to 1 second. 1049 | 1050 | The other useful key is C, which when set to true will produce 1051 | diagnostics on STDERR. 1052 | 1053 | =back 1054 | 1055 | =head1 METHODS 1056 | 1057 | =over 4 1058 | 1059 | =item C 1060 | 1061 | Sets the server list this module distributes key gets and sets between. 1062 | The format is an arrayref of identical form as described in the C 1063 | constructor. 1064 | 1065 | =item C 1066 | 1067 | Sets the C flag. See C constructor for more information. 1068 | 1069 | =item C 1070 | 1071 | Sets the C flag. See C constructor for more information. 1072 | 1073 | =item C 1074 | 1075 | Sets the C flag. See C constructor for more information. 1076 | 1077 | =item C 1078 | 1079 | Sets the compression threshold. See C constructor for more information. 1080 | 1081 | =item C 1082 | 1083 | Sets the connect timeout. See C constructor for more information. 1084 | 1085 | =item C 1086 | 1087 | Sets the select timeout. See C constructor for more information. 1088 | 1089 | =item C 1090 | 1091 | Temporarily enable or disable compression. Has no effect if C 1092 | isn't set, but has an overriding effect if it is. 1093 | 1094 | =item C 1095 | 1096 | my $val = $memd->get($key); 1097 | 1098 | Retrieves a key from the memcache. Returns the value (automatically 1099 | thawed with Storable, if necessary) or undef. 1100 | 1101 | The $key can optionally be an arrayref, with the first element being the 1102 | hash value, if you want to avoid making this module calculate a hash 1103 | value. You may prefer, for example, to keep all of a given user's 1104 | objects on the same memcache server, so you could use the user's 1105 | unique id as the hash value. 1106 | 1107 | =item C 1108 | 1109 | my $hashref = $memd->get_multi(@keys); 1110 | 1111 | Retrieves multiple keys from the memcache doing just one query. 1112 | Returns a hashref of key/value pairs that were available. 1113 | 1114 | This method is recommended over regular 'get' as it lowers the number 1115 | of total packets flying around your network, reducing total latency, 1116 | since your app doesn't have to wait for each round-trip of 'get' 1117 | before sending the next one. 1118 | 1119 | =item C 1120 | 1121 | $memd->set($key, $value[, $exptime]); 1122 | 1123 | Unconditionally sets a key to a given value in the memcache. Returns true 1124 | if it was stored successfully. 1125 | 1126 | The $key can optionally be an arrayref, with the first element being the 1127 | hash value, as described above. 1128 | 1129 | The $exptime (expiration time) defaults to "never" if unspecified. If 1130 | you want the key to expire in memcached, pass an integer $exptime. If 1131 | value is less than 60*60*24*30 (30 days), time is assumed to be relative 1132 | from the present. If larger, it's considered an absolute Unix time. 1133 | 1134 | =item C 1135 | 1136 | $memd->add($key, $value[, $exptime]); 1137 | 1138 | Like C, but only stores in memcache if the key doesn't already exist. 1139 | 1140 | =item C 1141 | 1142 | $memd->replace($key, $value[, $exptime]); 1143 | 1144 | Like C, but only stores in memcache if the key already exists. The 1145 | opposite of C. 1146 | 1147 | =item C 1148 | 1149 | $memd->delete($key[, $time]); 1150 | 1151 | Deletes a key. You may optionally provide an integer time value (in seconds) to 1152 | tell the memcached server to block new writes to this key for that many seconds. 1153 | (Sometimes useful as a hacky means to prevent races.) Returns true if key 1154 | was found and deleted, and false otherwise. 1155 | 1156 | You may also use the alternate method name B, so 1157 | Cache::Memcached looks like the L API. 1158 | 1159 | =item C 1160 | 1161 | $memd->incr($key[, $value]); 1162 | 1163 | Sends a command to the server to atomically increment the value for 1164 | $key by $value, or by 1 if $value is undefined. Returns undef if $key 1165 | doesn't exist on server, otherwise it returns the new value after 1166 | incrementing. Value should be zero or greater. Overflow on server 1167 | is not checked. Be aware of values approaching 2**32. See decr. 1168 | 1169 | =item C 1170 | 1171 | $memd->decr($key[, $value]); 1172 | 1173 | Like incr, but decrements. Unlike incr, underflow is checked and new 1174 | values are capped at 0. If server value is 1, a decrement of 2 1175 | returns 0, not -1. 1176 | 1177 | =item C 1178 | 1179 | $memd->stats([$keys]); 1180 | 1181 | Returns a hashref of statistical data regarding the memcache server(s), 1182 | the $memd object, or both. $keys can be an arrayref of keys wanted, a 1183 | single key wanted, or absent (in which case the default value is malloc, 1184 | sizes, self, and the empty string). These keys are the values passed 1185 | to the 'stats' command issued to the memcached server(s), except for 1186 | 'self' which is internal to the $memd object. Allowed values are: 1187 | 1188 | =over 4 1189 | 1190 | =item C 1191 | 1192 | The stats returned by a 'stats' command: pid, uptime, version, 1193 | bytes, get_hits, etc. 1194 | 1195 | =item C 1196 | 1197 | The stats returned by a 'stats malloc': total_alloc, arena_size, etc. 1198 | 1199 | =item C 1200 | 1201 | The stats returned by a 'stats sizes'. 1202 | 1203 | =item C 1204 | 1205 | The stats for the $memd object itself (a copy of $memd->{'stats'}). 1206 | 1207 | =item C 1208 | 1209 | The stats returned by a 'stats maps'. 1210 | 1211 | =item C 1212 | 1213 | The stats returned by a 'stats cachedump'. 1214 | 1215 | =item C 1216 | 1217 | The stats returned by a 'stats slabs'. 1218 | 1219 | =item C 1220 | 1221 | The stats returned by a 'stats items'. 1222 | 1223 | =back 1224 | 1225 | =item C 1226 | 1227 | $memd->disconnect_all; 1228 | 1229 | Closes all cached sockets to all memcached servers. You must do this 1230 | if your program forks and the parent has used this module at all. 1231 | Otherwise the children will try to use cached sockets and they'll fight 1232 | (as children do) and garble the client/server protocol. 1233 | 1234 | =item C 1235 | 1236 | $memd->flush_all; 1237 | 1238 | Runs the memcached "flush_all" command on all configured hosts, 1239 | emptying all their caches. (or rather, invalidating all items 1240 | in the caches in an O(1) operation...) Running stats will still 1241 | show the item existing, they're just be non-existent and lazily 1242 | destroyed next time you try to detch any of them. 1243 | 1244 | =back 1245 | 1246 | =head1 BUGS 1247 | 1248 | When a server goes down, this module does detect it, and re-hashes the 1249 | request to the remaining servers, but the way it does it isn't very 1250 | clean. The result may be that it gives up during its rehashing and 1251 | refuses to get/set something it could've, had it been done right. 1252 | 1253 | =head1 COPYRIGHT 1254 | 1255 | This module is Copyright (c) 2003 Brad Fitzpatrick. 1256 | All rights reserved. 1257 | 1258 | You may distribute under the terms of either the GNU General Public 1259 | License or the Artistic License, as specified in the Perl README file. 1260 | 1261 | =head1 WARRANTY 1262 | 1263 | This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND. 1264 | 1265 | =head1 FAQ 1266 | 1267 | See the memcached website: 1268 | http://www.danga.com/memcached/ 1269 | 1270 | =head1 AUTHORS 1271 | 1272 | Brad Fitzpatrick 1273 | 1274 | Anatoly Vorobey 1275 | 1276 | Brad Whitaker 1277 | 1278 | Jamie McCarthy 1279 | -------------------------------------------------------------------------------- /lib/Cache/Memcached/GetParser.pm: -------------------------------------------------------------------------------- 1 | package Cache::Memcached::GetParser; 2 | use strict; 3 | use warnings; 4 | use integer; 5 | 6 | use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN ); 7 | 8 | use constant DEST => 0; # destination hashref we're writing into 9 | use constant NSLEN => 1; # length of namespace to ignore on keys 10 | use constant ON_ITEM => 2; 11 | use constant BUF => 3; # read buffer 12 | use constant STATE => 4; # 0 = waiting for a line, N = reading N bytes 13 | use constant OFFSET => 5; # offsets to read into buffers 14 | use constant FLAGS => 6; 15 | use constant KEY => 7; # current key we're parsing (without the namespace prefix) 16 | 17 | sub new { 18 | my ($class, $dest, $nslen, $on_item) = @_; 19 | return bless [$dest, $nslen, $on_item, '', 0, 0], $class; 20 | } 21 | 22 | sub current_key { 23 | return $_[0][KEY]; 24 | } 25 | 26 | # returns 1 on success, -1 on failure, and 0 if still working. 27 | sub parse_from_sock { 28 | my ($self, $sock) = @_; 29 | my $res; 30 | 31 | # where are we reading into? 32 | if ($self->[STATE]) { # reading value into $ret 33 | my $ret = $self->[DEST]; 34 | $res = sysread($sock, $ret->{$self->[KEY]}, 35 | $self->[STATE] - $self->[OFFSET], 36 | $self->[OFFSET]); 37 | 38 | return 0 39 | if !defined($res) and $!==EWOULDBLOCK; 40 | 41 | if ($res == 0) { # catches 0=conn closed or undef=error 42 | $self->[ON_ITEM] = undef; 43 | return -1; 44 | } 45 | 46 | $self->[OFFSET] += $res; 47 | if ($self->[OFFSET] == $self->[STATE]) { # finished reading 48 | $self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]); 49 | $self->[OFFSET] = 0; 50 | $self->[STATE] = 0; 51 | # wait for another VALUE line or END... 52 | } 53 | return 0; # still working, haven't got to end yet 54 | } 55 | 56 | # we're reading a single line. 57 | # first, read whatever's there, but be satisfied with 2048 bytes 58 | $res = sysread($sock, $self->[BUF], 59 | 128*1024, $self->[OFFSET]); 60 | return 0 61 | if !defined($res) and $!==EWOULDBLOCK; 62 | if (!defined($res) || $res == 0) { 63 | $self->[ON_ITEM] = undef; 64 | return -1; 65 | } 66 | 67 | $self->[OFFSET] += $res; 68 | 69 | return $self->parse_buffer; 70 | } 71 | 72 | # returns 1 on success, -1 on failure, and 0 if still working. 73 | sub parse_buffer { 74 | my ($self) = @_; 75 | my $ret = $self->[DEST]; 76 | 77 | SEARCH: 78 | while (1) { # may have to search many times 79 | 80 | # do we have a complete END line? 81 | if ($self->[BUF] =~ /^END\r\n/) { 82 | $self->[ON_ITEM] = undef; 83 | return 1; # we're done successfully, return 1 to finish 84 | } 85 | 86 | # do we have a complete VALUE line? 87 | if ($self->[BUF] =~ /^VALUE (\S+) (\d+) (\d+)\r\n/) { 88 | ($self->[KEY], $self->[FLAGS], $self->[STATE]) = 89 | (substr($1, $self->[NSLEN]), int($2), $3+2); 90 | # Note: we use $+[0] and not pos($self->[BUF]) because pos() 91 | # seems to have problems under perl's taint mode. nobody 92 | # on the list discovered why, but this seems a reasonable 93 | # work-around: 94 | my $p = $+[0]; 95 | my $len = length($self->[BUF]); 96 | my $copy = $len-$p > $self->[STATE] ? $self->[STATE] : $len-$p; 97 | $ret->{$self->[KEY]} = substr($self->[BUF], $p, $copy) 98 | if $copy; 99 | $self->[OFFSET] = $copy; 100 | substr($self->[BUF], 0, $p+$copy, ''); # delete the stuff we used 101 | 102 | if ($self->[OFFSET] == $self->[STATE]) { # have it all? 103 | $self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]); 104 | $self->[OFFSET] = 0; 105 | $self->[STATE] = 0; 106 | next SEARCH; # look again 107 | } 108 | 109 | last SEARCH; # buffer is empty now 110 | } 111 | 112 | # if we're here probably means we only have a partial VALUE 113 | # or END line in the buffer. Could happen with multi-get, 114 | # though probably very rarely. Exit the loop and let it read 115 | # more. 116 | 117 | # but first, make sure subsequent reads don't destroy our 118 | # partial VALUE/END line. 119 | $self->[OFFSET] = length($self->[BUF]); 120 | last SEARCH; 121 | } 122 | return 0; 123 | } 124 | 125 | 1; 126 | -------------------------------------------------------------------------------- /t/01_use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | 6 | plan tests => 1; 7 | 8 | use_ok('Cache::Memcached'); 9 | -------------------------------------------------------------------------------- /t/02_keys.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | unless ($^V) { 9 | plan skip_all => "This test requires perl 5.6.0+\n"; 10 | exit 0; 11 | } 12 | 13 | my $testaddr = "127.0.0.1:11211"; 14 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 15 | Timeout => 3); 16 | if ($msock) { 17 | plan tests => 20; 18 | } else { 19 | plan skip_all => "No memcached instance running at $testaddr\n"; 20 | exit 0; 21 | } 22 | 23 | my $memd = Cache::Memcached->new({ 24 | servers => [ $testaddr ], 25 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 26 | }); 27 | 28 | isa_ok($memd, 'Cache::Memcached'); 29 | 30 | my $memcached_version; 31 | 32 | eval { 33 | require version; 34 | die "version too old" unless $version::VERSION >= 0.77; 35 | $memcached_version = 36 | version->parse( 37 | $memd->stats('misc')->{hosts}->{$testaddr}->{misc}->{version} 38 | ); 39 | diag("Server version: $memcached_version") if $memcached_version; 40 | }; 41 | 42 | ok($memd->set("key1", "val1"), "set key1 as val1"); 43 | 44 | is($memd->get("key1"), "val1", "get key1 is val1"); 45 | ok(! $memd->add("key1", "val-replace"), "add key1 properly failed"); 46 | ok($memd->add("key2", "val2"), "add key2 as val2"); 47 | is($memd->get("key2"), "val2", "get key2 is val2"); 48 | 49 | ok($memd->replace("key2", "val-replace"), "replace key2 as val-replace"); 50 | is($memd->get("key2"), "val-replace", "get key2 is val-replace"); 51 | ok(! $memd->replace("key-noexist", "bogus"), "replace key-noexist properly failed"); 52 | 53 | ok($memd->delete("key1"), "delete key1"); 54 | ok(! $memd->get("key1"), "get key1 properly failed"); 55 | 56 | SKIP: { 57 | skip "Could not parse server version; version.pm 0.77 required", 7 58 | unless $memcached_version; 59 | skip "Only using prepend/append on memcached >= 1.2.4, you have $memcached_version", 7 60 | unless $memcached_version && $memcached_version >= v1.2.4; 61 | 62 | ok(! $memd->append("key-noexist", "bogus"), "append key-noexist properly failed"); 63 | ok(! $memd->prepend("key-noexist", "bogus"), "prepend key-noexist properly failed"); 64 | ok($memd->set("key3", "base"), "set key3 to base"); 65 | ok($memd->append("key3", "-end"), "appended -end to key3"); 66 | ok($memd->get("key3", "base-end"), "key3 is base-end"); 67 | ok($memd->prepend("key3", "start-"), "prepended start- to key3"); 68 | ok($memd->get("key3", "start-base-end"), "key3 is base-end"); 69 | } 70 | 71 | # also test creating the object with a list rather than a hash-ref 72 | my $mem2 = Cache::Memcached->new( 73 | servers => [ ], 74 | debug => 1, 75 | ); 76 | isa_ok($mem2, 'Cache::Memcached'); 77 | ok($mem2->{debug}, "debug is set on alt constructed instance"); 78 | -------------------------------------------------------------------------------- /t/03_stats.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 10 | Timeout => 3); 11 | 12 | my @misc_stats_keys = qw/ bytes bytes_read bytes_written 13 | cmd_get cmd_set connection_structures curr_items 14 | get_hits get_misses 15 | total_connections total_items 16 | /; 17 | 18 | if ($msock) { 19 | plan tests => 16 + scalar(@misc_stats_keys); 20 | } else { 21 | plan skip_all => "No memcached instance running at $testaddr\n"; 22 | exit 0; 23 | } 24 | 25 | my $memd = Cache::Memcached->new({ 26 | servers => [ $testaddr ], 27 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 28 | }); 29 | 30 | my $misc_stats = $memd->stats('misc'); 31 | ok($misc_stats, 'got misc stats'); 32 | isa_ok($misc_stats, 'HASH', 'misc stats'); 33 | isa_ok($misc_stats->{'total'}, 'HASH', 'misc stats total'); 34 | isa_ok($misc_stats->{'hosts'}, 'HASH', 'misc stats hosts'); 35 | isa_ok($misc_stats->{'hosts'}{$testaddr}, 'HASH', 36 | "misc stats hosts $testaddr"); 37 | 38 | foreach my $stat_key (@misc_stats_keys) { 39 | ok(exists $misc_stats->{'total'}{$stat_key}, 40 | "misc stats total contains $stat_key"); 41 | ok(exists $misc_stats->{'hosts'}{$testaddr}{'misc'}{$stat_key}, 42 | "misc stats hosts $testaddr misc contains $stat_key"); 43 | } 44 | -------------------------------------------------------------------------------- /t/04_noreply.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 10 | Timeout => 3); 11 | if ($msock) { 12 | plan tests => 7; 13 | } else { 14 | plan skip_all => "No memcached instance running at $testaddr\n"; 15 | exit 0; 16 | } 17 | 18 | my $memd = Cache::Memcached->new({ 19 | servers => [ $testaddr ], 20 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 21 | }); 22 | 23 | isa_ok($memd, 'Cache::Memcached'); 24 | 25 | 26 | use constant count => 30; 27 | 28 | $memd->flush_all; 29 | 30 | $memd->add("key", "add"); 31 | is($memd->get("key"), "add"); 32 | 33 | for (my $i = 0; $i < count; ++$i) { 34 | $memd->set("key", $i); 35 | } 36 | is($memd->get("key"), count - 1); 37 | 38 | $memd->replace("key", count); 39 | is($memd->get("key"), count); 40 | 41 | for (my $i = 0; $i < count; ++$i) { 42 | $memd->incr("key", 2); 43 | } 44 | is($memd->get("key"), count + 2 * count); 45 | 46 | for (my $i = 0; $i < count; ++$i) { 47 | $memd->decr("key", 1); 48 | } 49 | is($memd->get("key"), count + 1 * count); 50 | 51 | $memd->delete("key"); 52 | is($memd->get("key"), undef); 53 | -------------------------------------------------------------------------------- /t/05_reconnect_timeout.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | use Time::HiRes qw(gettimeofday tv_interval); 8 | 9 | ############################################################################## 10 | # This is connecting to TEST-NET-1 on purpose, because that's a space that is 11 | # guaranteed by RFC to have no hosts in it. Sometimes we still get fast RST 12 | # frames though, so we have to check before we trust it. 13 | # 14 | # DO NOT FIX THIS CODE TO CHECK AND MAKE SURE THE HOST IS UP. IT IS SUPPOSED 15 | # TO BE DOWN. :) --hachi 16 | ############################################################################## 17 | my $testaddr = "192.0.2.1:11211"; 18 | 19 | my $stime = [gettimeofday]; 20 | 21 | my $msock = IO::Socket::INET->new( 22 | PeerAddr => $testaddr, 23 | Timeout => 2, 24 | ); 25 | 26 | my $delta_t = tv_interval($stime); 27 | 28 | if ($delta_t >= 1) { 29 | plan tests => 2; 30 | } else { 31 | plan skip_all => "Somehow we got a fast return when connecting to $testaddr\n"; 32 | exit 0; 33 | } 34 | 35 | my $memd = Cache::Memcached->new({ 36 | servers => [ $testaddr ], 37 | namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/", 38 | }); 39 | 40 | 41 | my $time1 = Time::HiRes::time(); 42 | $memd->set("key", "bar"); 43 | my $time2 = Time::HiRes::time(); 44 | # 100ms is faster than the default connect timeout. 45 | ok($time2 - $time1 > .1, "Expected pause while connecting"); 46 | 47 | # 100ms should be slow enough that dead socket reconnects happen faster than it. 48 | $memd->set("key", "foo"); 49 | my $time3 = Time::HiRes::time(); 50 | ok($time3 - $time2 < .1, "Should return fast on retry"); 51 | -------------------------------------------------------------------------------- /t/06_utf8_key.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $msock = IO::Socket::INET->new(PeerAddr => $testaddr, 10 | Timeout => 3); 11 | if ($msock) { 12 | plan tests => 2; 13 | } else { 14 | plan skip_all => "No memcached instance running at $testaddr\n"; 15 | exit 0; 16 | } 17 | 18 | my $memd = Cache::Memcached->new({ 19 | servers => [ $testaddr ], 20 | }); 21 | 22 | use utf8; 23 | my $key = "Ïâ"; 24 | 25 | ok($memd->set($key, "val1"), "set key1 as val1"); 26 | is($memd->get($key), "val1", "get key1 is val1"); 27 | -------------------------------------------------------------------------------- /t/100_flush_bug.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $port = 11311; 9 | my $testaddr = "127.0.0.1:$port"; 10 | my $sock = IO::Socket::INET->new( 11 | LocalAddr => $testaddr, 12 | Proto => 'tcp', 13 | ReuseAddr => 1, 14 | ); 15 | 16 | my @res = ( 17 | ["OK\r\n", 1], 18 | ["ERROR\r\n", 0], 19 | ["\r\nERROR\r\n", 0], 20 | ["FOO\r\nERROR\r\n", 0], 21 | ["FOO\r\nOK\r\nERROR\r\n", 0], 22 | ["\r\n\r\nOK\r\n", 0], 23 | ["END\r\n", 0], 24 | ); 25 | 26 | if ($sock) { 27 | plan tests => scalar @res; 28 | } else { 29 | plan skip_all => "cannot bind to $testaddr\n"; 30 | exit 0; 31 | } 32 | close $sock; 33 | 34 | my $pid = fork; 35 | die "Cannot fork because: '$!'" unless defined $pid; 36 | unless ($pid) { 37 | 38 | my $sock = IO::Socket::INET->new( 39 | LocalAddr => $testaddr, 40 | Proto => 'tcp', 41 | ReuseAddr => 1, 42 | Listen => 1, 43 | ) or die "cannot open $testaddr: $!"; 44 | my $csock = $sock->accept(); 45 | while (defined (my $buf = <$csock>)) { 46 | my $res = shift @res; 47 | print $csock $res->[0]; 48 | } 49 | close $csock; 50 | close $sock; 51 | exit 0; 52 | } 53 | 54 | # give the forked server a chance to startup 55 | sleep 1; 56 | 57 | my $memd = Cache::Memcached->new({ servers => [ $testaddr ] }); 58 | 59 | for (@res) { 60 | ($_->[0] =~ s/\W//g); 61 | is $memd->flush_all, $_->[1], $_->[0]; 62 | } 63 | -------------------------------------------------------------------------------- /t/101_multiple_clients.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl -w 2 | 3 | use strict; 4 | use Test::More; 5 | use Cache::Memcached; 6 | use IO::Socket::INET; 7 | 8 | my $testaddr = "127.0.0.1:11211"; 9 | my $sock = IO::Socket::INET->new( 10 | PeerAddr => $testaddr, 11 | Proto => 'tcp', 12 | ReuseAddr => 1, 13 | ); 14 | 15 | if ($sock) { 16 | plan tests => 8; 17 | } else { 18 | plan skip_all => "cannot connect to $testaddr\n"; 19 | exit 0; 20 | } 21 | close $sock; 22 | 23 | my $mc = Cache::Memcached->new( 24 | servers => [ '127.0.0.1:11211', '127.1:11211' ], 25 | ); 26 | 27 | $mc->get('1'); 28 | pass("1-1"); 29 | 30 | $mc->get('2'); 31 | pass("1-2"); 32 | 33 | my $mc2 = Cache::Memcached->new( 34 | servers => [ '127.0.0.1:11211', '127.1:11211' ], 35 | ); 36 | 37 | $mc2->get('1'); 38 | pass("2-1"); 39 | 40 | $mc->get('1'); 41 | pass("2-2"); 42 | 43 | $mc->disconnect_all(); 44 | 45 | $mc2->get('1'); 46 | pass("2-1"); 47 | 48 | $mc->get('1'); 49 | pass("2-2"); 50 | 51 | $mc->get('2'); 52 | pass("2-3"); 53 | 54 | $mc2->get('2'); 55 | pass("2-4"); 56 | --------------------------------------------------------------------------------