[memcached] bradfitz, r380: give the 1.1.x branch some love:
commits at code.sixapart.com
commits at code.sixapart.com
Sat Sep 9 17:13:41 UTC 2006
give the 1.1.x branch some love:
-- import test suite from 1.2.x branch
-- report pointer size (for test suite)
-- build both a no-asserts and with-assert (-debug) binary
U branches/memcached-1.1.x/Makefile.am
U branches/memcached-1.1.x/memcached.c
A branches/memcached-1.1.x/t/
A branches/memcached-1.1.x/t/00-startup.t
A branches/memcached-1.1.x/t/64bit.t
A branches/memcached-1.1.x/t/binary-get.t
A branches/memcached-1.1.x/t/bogus-commands.t
A branches/memcached-1.1.x/t/daemonize.t
A branches/memcached-1.1.x/t/delete-window.t
A branches/memcached-1.1.x/t/expirations.t
A branches/memcached-1.1.x/t/flags.t
A branches/memcached-1.1.x/t/flush-all.t
A branches/memcached-1.1.x/t/getset.t
A branches/memcached-1.1.x/t/incrdecr.t
A branches/memcached-1.1.x/t/lib/
A branches/memcached-1.1.x/t/lib/MemcachedTest.pm
A branches/memcached-1.1.x/t/lru.t
A branches/memcached-1.1.x/t/managed-buckets.t
A branches/memcached-1.1.x/t/multiversioning.t
A branches/memcached-1.1.x/t/slab-reassign.t
A branches/memcached-1.1.x/t/stats.t
A branches/memcached-1.1.x/t/stress-memcached.pl
A branches/memcached-1.1.x/t/udp.t
A branches/memcached-1.1.x/t/unixsocket.t
Modified: branches/memcached-1.1.x/Makefile.am
===================================================================
--- branches/memcached-1.1.x/Makefile.am 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/Makefile.am 2006-09-09 17:13:40 UTC (rev 380)
@@ -1,16 +1,20 @@
-bin_PROGRAMS = memcached
+bin_PROGRAMS = memcached-debug
-memcached_SOURCES = memcached.c slabs.c items.c memcached.h assoc.c
+memcached_SOURCES = memcached.c slabs.c items.c assoc.c memcached.h
+memcached_debug_SOURCES = $(memcached_SOURCES)
+memcached_CPPFLAGS = -DNDEBUG
memcached_LDADD = @LIBOBJS@
+memcached_debug_LDADD = $(memcached_LDADD)
SUBDIRS = doc
DIST_DIRS = scripts
EXTRA_DIST = doc scripts TODO
-AM_CFLAGS=-DNDEBUG
+test: memcached-debug
+ prove t
dist-hook:
rm -rf $(distdir)/doc/.svn/
rm -rf $(distdir)/scripts/.svn/
-
-
+ rm -rf $(distdir)/t/.svn/
+ rm -rf $(distdir)/t/lib/.svn/
Modified: branches/memcached-1.1.x/memcached.c
===================================================================
--- branches/memcached-1.1.x/memcached.c 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/memcached.c 2006-09-09 17:13:40 UTC (rev 380)
@@ -342,6 +342,7 @@
pos += sprintf(pos, "STAT uptime %lu\r\n", now - stats.started);
pos += sprintf(pos, "STAT time %ld\r\n", now);
pos += sprintf(pos, "STAT version " VERSION "\r\n");
+ pos += sprintf(pos, "STAT pointer_size %d\r\n", 8 * sizeof(void*));
pos += sprintf(pos, "STAT rusage_user %ld.%06ld\r\n", usage.ru_utime.tv_sec, usage.ru_utime.tv_usec);
pos += sprintf(pos, "STAT rusage_system %ld.%06ld\r\n", usage.ru_stime.tv_sec, usage.ru_stime.tv_usec);
pos += sprintf(pos, "STAT curr_items %u\r\n", stats.curr_items);
Added: branches/memcached-1.1.x/t/00-startup.t
===================================================================
--- branches/memcached-1.1.x/t/00-startup.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/00-startup.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+
+ok($server, "started the server");
Property changes on: branches/memcached-1.1.x/t/00-startup.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/64bit.t
===================================================================
--- branches/memcached-1.1.x/t/64bit.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/64bit.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+$ENV{T_MEMD_INITIAL_MALLOC} = "4294967328"; # 2**32 + 32 :)
+$ENV{T_MEMD_SLABS_ALLOC} = 0; # don't preallocate slabs
+
+my $server = new_memcached("-m 4097 -M");
+my $sock = $server->sock;
+
+my ($stats, $slabs) = @_;
+
+$stats = mem_stats($sock);
+
+if ($stats->{'pointer_size'} eq "32") {
+ plan skip_all => 'Skipping 64-bit tests on 32-bit build';
+ exit 0;
+} else {
+ plan tests => 6;
+}
+
+is($stats->{'pointer_size'}, 64, "is 64 bit");
+is($stats->{'limit_maxbytes'}, "4296015872", "max bytes is 4097 MB");
+
+$slabs = mem_stats($sock, 'slabs');
+is($slabs->{'total_malloced'}, "4294967328", "expected (faked) value of total_malloced");
+is($slabs->{'active_slabs'}, 0, "no active slabs");
+
+my $hit_limit = 0;
+for (1..3) {
+ my $size = 400 * 1024;
+ my $data = "a" x $size;
+ print $sock "set big$_ 0 0 $size\r\n$data\r\n";
+ my $res = <$sock>;
+ $hit_limit = 1 if $res ne "STORED\r\n";
+}
+ok($hit_limit, "hit size limit");
+
+$slabs = mem_stats($sock, 'slabs');
+is($slabs->{'active_slabs'}, 1, "1 active slab");
Property changes on: branches/memcached-1.1.x/t/64bit.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/binary-get.t
===================================================================
--- branches/memcached-1.1.x/t/binary-get.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/binary-get.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/binary-get.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/bogus-commands.t
===================================================================
--- branches/memcached-1.1.x/t/bogus-commands.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/bogus-commands.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 1;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
+print $sock "boguscommand slkdsldkfjsd\r\n";
+is(scalar <$sock>, "ERROR\r\n", "got error back");
Property changes on: branches/memcached-1.1.x/t/bogus-commands.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/daemonize.t
===================================================================
--- branches/memcached-1.1.x/t/daemonize.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/daemonize.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 7;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+use File::Temp qw(tempfile);
+
+my (undef, $tmpfn) = tempfile();
+
+my $server = new_memcached("-d -P $tmpfn");
+my $sock = $server->sock;
+sleep 0.5;
+
+ok(-e $tmpfn, "pid file exists");
+ok(-s $tmpfn, "pid file has length");
+
+open (my $fh, $tmpfn) or die;
+my $readpid = do { local $/; <$fh>; };
+chomp $readpid;
+close ($fh);
+
+ok(kill(0, $readpid), "process is still running");
+
+my $stats = mem_stats($sock);
+is($stats->{pid}, $readpid, "memcached reports same pid as file");
+
+ok($server->new_sock, "opened new socket");
+ok(kill(9, $readpid), "sent KILL signal");
+sleep 0.5;
+ok(! $server->new_sock, "failed to open new socket");
Property changes on: branches/memcached-1.1.x/t/daemonize.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/delete-window.t
===================================================================
--- branches/memcached-1.1.x/t/delete-window.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/delete-window.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,68 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 20;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+my $line = sub { return scalar <$sock> };
+
+# immediate set/deletes
+print $sock "set foo 0 0 6\r\nfooval\r\ndelete foo\r\nset foo 0 0 6\r\nfooval\r\ndelete foo\r\n";
+is($line->(), "STORED\r\n", "pipeline set");
+is($line->(), "DELETED\r\n", "pipeline delete");
+is($line->(), "STORED\r\n", "pipeline set");
+is($line->(), "DELETED\r\n", "pipeline delete");
+
+# not found test
+print $sock "delete foo\r\n";
+is($line->(), "NOT_FOUND\r\n", "thing not found to delete");
+
+# test the cool-down window (see protocol doc) whereby add/replace commands can't
+# work n seconds after deleting.
+print $sock "set foo 0 0 3\r\nbar\r\n";
+is($line->(), "STORED\r\n", "stored foo");
+print $sock "delete foo 1\r\n";
+is($line->(), "DELETED\r\n", "deleted with 1 second window");
+mem_get_is($sock, "foo", undef);
+print $sock "add foo 0 0 7\r\nfoo-add\r\n";
+is($line->(), "NOT_STORED\r\n", "didn't add foo");
+print $sock "replace foo 0 0 11\r\nfoo-replace\r\n";
+is($line->(), "NOT_STORED\r\n", "didn't replace foo");
+print $sock "set foo 0 0 7\r\nfoo-set\r\n";
+is($line->(), "STORED\r\n", "stored foo-set");
+
+# add can work after expiration time
+print $sock "set foo 0 0 3\r\nbar\r\n";
+is($line->(), "STORED\r\n", "stored foo");
+print $sock "delete foo 1\r\n";
+is($line->(), "DELETED\r\n", "deleted with 1 second window");
+sleep(1.2);
+print $sock "add foo 0 0 7\r\nfoo-add\r\n";
+is($line->(), "STORED\r\n", "stored foo-add");
+
+mem_get_is($sock, "foo", "foo-add", "foo == 'foo-add' (before deleter)");
+
+# test 'baz' with set, delete w/ timer, set, wait 5.2 seconds (for 5
+# second deleter event), then get to see which we get.
+print $sock "set baz 0 0 4\r\nval1\r\n";
+is($line->(), "STORED\r\n", "stored baz = val1");
+print $sock "delete baz 1\r\n";
+is($line->(), "DELETED\r\n", "deleted with 1 second window");
+print $sock "set baz 0 0 4\r\nval2\r\n";
+is($line->(), "STORED\r\n", "stored baz = val2");
+
+diag("waiting 5 seconds for the deleter event...");
+sleep(5.2);
+
+# follow-up on 1st test:
+mem_get_is($sock, "foo", "foo-add", "foo == 'foo-add' (after deleter)");
+
+# and follow-up on 2nd test:
+mem_get_is($sock, "baz", "val2", "baz=='val2'");
+
+
+
Property changes on: branches/memcached-1.1.x/t/delete-window.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/expirations.t
===================================================================
--- branches/memcached-1.1.x/t/expirations.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/expirations.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 8;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+my $expire;
+
+print $sock "set foo 0 1 6\r\nfooval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+
+mem_get_is($sock, "foo", "fooval");
+sleep(1.5);
+mem_get_is($sock, "foo", undef);
+
+$expire = time() - 1;
+print $sock "set foo 0 $expire 6\r\nfooval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+mem_get_is($sock, "foo", undef, "already expired");
+
+$expire = time() + 1;
+print $sock "set foo 0 $expire 6\r\nfoov+1\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+mem_get_is($sock, "foo", "foov+1");
+sleep(2.2);
+mem_get_is($sock, "foo", undef, "now expired");
+
Property changes on: branches/memcached-1.1.x/t/expirations.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/flags.t
===================================================================
--- branches/memcached-1.1.x/t/flags.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/flags.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 6;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
+# set foo (and should get it)
+for my $flags (0, 123, 2**16-1) {
+ print $sock "set foo $flags 0 6\r\nfooval\r\n";
+ is(scalar <$sock>, "STORED\r\n", "stored foo");
+ mem_get_is({ sock => $sock,
+ flags => $flags }, "foo", "fooval", "got flags $flags back");
+}
Property changes on: branches/memcached-1.1.x/t/flags.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/flush-all.t
===================================================================
--- branches/memcached-1.1.x/t/flush-all.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/flush-all.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 11;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+my $expire;
+
+print $sock "set foo 0 0 6\r\nfooval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+
+mem_get_is($sock, "foo", "fooval");
+print $sock "flush_all\r\n";
+is(scalar <$sock>, "OK\r\n", "did flush_all");
+
+mem_get_is($sock, "foo", undef);
+SKIP: {
+ skip "flush_all is still only second-granularity. need atomic counter on flush_all.", 2 unless 0;
+
+ print $sock "set foo 0 0 3\r\nnew\r\n";
+ is(scalar <$sock>, "STORED\r\n", "stored foo = 'new'");
+ mem_get_is($sock, "foo", 'new');
+}
+
+sleep 1;
+mem_get_is($sock, "foo", undef);
+
+# and the other form, specifying a flush_all time...
+my $expire = time() + 2;
+print $sock "flush_all $expire\r\n";
+is(scalar <$sock>, "OK\r\n", "did flush_all in future");
+
+print $sock "set foo 0 0 4\r\n1234\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo = '1234'");
+mem_get_is($sock, "foo", '1234');
+sleep(2.2);
+mem_get_is($sock, "foo", undef);
Property changes on: branches/memcached-1.1.x/t/flush-all.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/getset.t
===================================================================
--- branches/memcached-1.1.x/t/getset.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/getset.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 14;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
+# set foo (and should get it)
+print $sock "set foo 0 0 6\r\nfooval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+mem_get_is($sock, "foo", "fooval");
+
+# add bar (and should get it)
+print $sock "add bar 0 0 6\r\nbarval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored barval");
+mem_get_is($sock, "bar", "barval");
+
+# add foo (but shouldn't get new value)
+print $sock "add foo 0 0 5\r\nfoov2\r\n";
+is(scalar <$sock>, "NOT_STORED\r\n", "not stored");
+mem_get_is($sock, "foo", "fooval");
+
+# replace bar (should work)
+print $sock "replace bar 0 0 6\r\nbarva2\r\n";
+is(scalar <$sock>, "STORED\r\n", "replaced barval 2");
+
+# replace notexist (shouldn't work)
+print $sock "replace notexist 0 0 6\r\nbarva2\r\n";
+is(scalar <$sock>, "NOT_STORED\r\n", "didn't replace notexist");
+
+# delete foo.
+print $sock "delete foo\r\n";
+is(scalar <$sock>, "DELETED\r\n", "deleted foo");
+
+# delete foo again. not found this time.
+print $sock "delete foo\r\n";
+is(scalar <$sock>, "NOT_FOUND\r\n", "deleted foo, but not found");
+
+# pipeling is okay
+print $sock "set foo 0 0 6\r\nfooval\r\ndelete foo\r\nset foo 0 0 6\r\nfooval\r\ndelete foo\r\n";
+is(scalar <$sock>, "STORED\r\n", "pipeline set");
+is(scalar <$sock>, "DELETED\r\n", "pipeline delete");
+is(scalar <$sock>, "STORED\r\n", "pipeline set");
+is(scalar <$sock>, "DELETED\r\n", "pipeline delete");
+
+
+
Property changes on: branches/memcached-1.1.x/t/getset.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/incrdecr.t
===================================================================
--- branches/memcached-1.1.x/t/incrdecr.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/incrdecr.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 13;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
+print $sock "set num 0 0 1\r\n1\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored num");
+mem_get_is($sock, "num", 1, "stored 1");
+
+print $sock "incr num 1\r\n";
+is(scalar <$sock>, "2\r\n", "+ 1 = 2");
+mem_get_is($sock, "num", 2);
+
+print $sock "incr num 8\r\n";
+is(scalar <$sock>, "10\r\n", "+ 8 = 10");
+mem_get_is($sock, "num", 10);
+
+print $sock "decr num 1\r\n";
+is(scalar <$sock>, "9\r\n", "- 1 = 9");
+
+print $sock "decr num 9\r\n";
+is(scalar <$sock>, "0\r\n", "- 9 = 0");
+
+print $sock "decr num 5\r\n";
+is(scalar <$sock>, "0\r\n", "- 5 = 0");
+
+print $sock "decr bogus 5\r\n";
+is(scalar <$sock>, "NOT_FOUND\r\n", "can't decr bogus key");
+
+print $sock "decr incr 5\r\n";
+is(scalar <$sock>, "NOT_FOUND\r\n", "can't incr bogus key");
+
+print $sock "set text 0 0 2\r\nhi\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored text");
+print $sock "incr text 1\r\n";
+is(scalar <$sock>, "1\r\n", "hi - 1 = 0");
+
+
Property changes on: branches/memcached-1.1.x/t/incrdecr.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/lib/MemcachedTest.pm
===================================================================
--- branches/memcached-1.1.x/t/lib/MemcachedTest.pm 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/lib/MemcachedTest.pm 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,153 @@
+package MemcachedTest;
+use strict;
+use IO::Socket::INET;
+use Exporter 'import';
+use FindBin qw($Bin);
+use Carp qw(croak);
+use vars qw(@EXPORT);
+
+ at EXPORT = qw(new_memcached sleep mem_get_is mem_stats free_port);
+
+sub sleep {
+ my $n = shift;
+ select undef, undef, undef, $n;
+}
+
+sub mem_stats {
+ my ($sock, $type) = @_;
+ $type = $type ? " $type" : "";
+ print $sock "stats$type\r\n";
+ my $stats = {};
+ while (<$sock>) {
+ last if /^(\.|END)/;
+ /^STAT (\S+) (\d+)/;
+ #print " slabs: $_";
+ $stats->{$1} = $2;
+ }
+ return $stats;
+}
+
+sub mem_get_is {
+ # works on single-line values only. no newlines in value.
+ my ($sock_opts, $key, $val, $msg) = @_;
+ my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
+ my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
+
+ my $expect_flags = $opts->{flags} || 0;
+ my $dval = defined $val ? "'$val'" : "<undef>";
+ $msg ||= "$key == $dval";
+
+ print $sock "get $key\r\n";
+ if (! defined $val) {
+ my $line = scalar <$sock>;
+ if ($line =~ /^VALUE/) {
+ $line .= scalar(<$sock>) . scalar(<$sock>);
+ }
+ Test::More::is($line, "END\r\n", $msg);
+ } else {
+ my $len = length($val);
+ my $body = scalar(<$sock>);
+ my $expected = "VALUE $key $expect_flags $len\r\n$val\r\nEND\r\n";
+ if (!$body || $body =~ /^END/) {
+ Test::More::is($body, $expected, $msg);
+ return;
+ }
+ $body .= scalar(<$sock>) . scalar(<$sock>);
+ Test::More::is($body, $expected, $msg);
+ }
+}
+
+sub free_port {
+ my $type = shift || "tcp";
+ my $sock;
+ my $port;
+ while (!$sock) {
+ $port = int(rand(20000)) + 30000;
+ $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
+ LocalPort => $port,
+ Proto => $type,
+ ReuseAddr => 1);
+ }
+ return $port;
+}
+
+sub supports_udp {
+ my $output = `$Bin/../memcached-debug -h`;
+ return 0 if $output =~ /^memcached 1\.1\./;
+ return 1;
+}
+
+sub new_memcached {
+ my $args = shift || "";
+ my $port = free_port();
+ my $udpport = free_port("udp");
+ $args .= " -p $port";
+ if (supports_udp()) {
+ $args .= " -U $udpport";
+ }
+ if ($< == 0) {
+ $args .= " -u root";
+ }
+ my $childpid = fork();
+
+ my $exe = "$Bin/../memcached-debug";
+ croak("memcached binary doesn't exist. Haven't run 'make' ?\n") unless -e $exe;
+ croak("memcached binary not executable\n") unless -x _;
+
+ unless ($childpid) {
+ exec "$exe $args";
+ exit; # never gets here.
+ }
+
+ for (1..20) {
+ my $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
+ if ($conn) {
+ return Memcached::Handle->new(pid => $childpid,
+ conn => $conn,
+ udpport => $udpport,
+ port => $port);
+ }
+ select undef, undef, undef, 0.10;
+ }
+ croak("Failed to startup/connect to memcached server.");
+
+}
+
+############################################################################
+package Memcached::Handle;
+sub new {
+ my ($class, %params) = @_;
+ return bless \%params, $class;
+}
+
+sub DESTROY {
+ my $self = shift;
+ kill 9, $self->{pid};
+}
+
+sub port { $_[0]{port} }
+sub udpport { $_[0]{udpport} }
+
+sub sock {
+ my $self = shift;
+ return $self->{conn} if $self->{conn} && getpeername($self->{conn});
+ return $self->new_sock;
+}
+
+sub new_sock {
+ my $self = shift;
+ return IO::Socket::INET->new(PeerAddr => "127.0.0.1:$self->{port}");
+}
+
+sub new_udp_sock {
+ my $self = shift;
+ return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
+ PeerPort => $self->{udpport},
+ Proto => 'udp',
+ LocalAddr => '127.0.0.1',
+ LocalPort => MemcachedTest::free_port('udp'),
+ );
+
+}
+
+1;
Added: branches/memcached-1.1.x/t/lru.t
===================================================================
--- branches/memcached-1.1.x/t/lru.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/lru.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/lru.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/managed-buckets.t
===================================================================
--- branches/memcached-1.1.x/t/managed-buckets.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/managed-buckets.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/managed-buckets.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/multiversioning.t
===================================================================
--- branches/memcached-1.1.x/t/multiversioning.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/multiversioning.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More tests => 13;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+my $sock2 = $server->new_sock;
+
+ok($sock != $sock2, "have two different connections open");
+
+# set large value
+my $size = 256 * 1024; # 256 kB
+my $bigval = "0123456789abcdef" x ($size / 16);
+$bigval =~ s/^0/\[/; $bigval =~ s/f$/\]/;
+my $bigval2 = uc($bigval);
+
+print $sock "set big 0 0 $size\r\n$bigval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+mem_get_is($sock, "big", $bigval, "big value got correctly");
+
+print $sock "get big\r\n";
+my $buf;
+is(read($sock, $buf, $size / 2), $size / 2, "read half the answer back");
+like($buf, qr/VALUE big/, "buf has big value header in it");
+like($buf, qr/abcdef/, "buf has some data in it");
+unlike($buf, qr/abcde\]/, "buf doesn't yet close");
+
+# sock2 interrupts (maybe sock1 is slow) and deletes stuff:
+print $sock2 "delete big\r\n";
+is(scalar <$sock2>, "DELETED\r\n", "deleted big from sock2 while sock1's still reading it");
+mem_get_is($sock2, "big", undef, "nothing from sock2 now. gone from namespace.");
+print $sock2 "set big 0 0 $size\r\n$bigval2\r\n";
+is(scalar <$sock2>, "STORED\r\n", "stored big w/ val2");
+mem_get_is($sock2, "big", $bigval2, "big value2 got correctly");
+
+# sock1 resumes reading...
+$buf .= <$sock>;
+$buf .= <$sock>;
+like($buf, qr/abcde\]/, "buf now closes");
+
+# and if sock1 reads again, it's the uppercase version:
+mem_get_is($sock, "big", $bigval2, "big value2 got correctly from sock1");
Property changes on: branches/memcached-1.1.x/t/multiversioning.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/slab-reassign.t
===================================================================
--- branches/memcached-1.1.x/t/slab-reassign.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/slab-reassign.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/slab-reassign.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/stats.t
===================================================================
--- branches/memcached-1.1.x/t/stats.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/stats.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/stats.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/stress-memcached.pl
===================================================================
--- branches/memcached-1.1.x/t/stress-memcached.pl 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/stress-memcached.pl 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,101 @@
+#!/usr/bin/perl
+#
+
+use strict;
+use lib '../api/perl';
+use MemCachedClient;
+use Time::HiRes qw(time);
+
+unless (@ARGV == 2) {
+ die "Usage: stress-memcached.pl ip:port threads\n";
+}
+
+my $host = shift;
+my $threads = shift;
+
+my $memc = new MemCachedClient;
+$memc->set_servers([$host]);
+
+unless ($memc->set("foo", "bar") &&
+ $memc->get("foo") eq "bar") {
+ die "memcached not running at $host ?\n";
+}
+$memc->disconnect_all();
+
+
+my $running = 0;
+while (1) {
+ if ($running < $threads) {
+ my $cpid = fork();
+ if ($cpid) {
+ $running++;
+ #print "Launched $cpid. Running $running threads.\n";
+ } else {
+ stress();
+ exit 0;
+ }
+ } else {
+ wait();
+ $running--;
+ }
+}
+
+sub stress {
+ undef $memc;
+ $memc = new MemCachedClient;
+ $memc->set_servers([$host]);
+
+ my ($t1, $t2);
+ my $start = sub { $t1 = time(); };
+ my $stop = sub {
+ my $op = shift;
+ $t2 = time();
+ my $td = sprintf("%0.3f", $t2 - $t1);
+ if ($td > 0.25) { print "Took $td seconds for: $op\n"; }
+ };
+
+ my $max = rand(50);
+ my $sets = 0;
+
+ for (my $i = 0; $i < $max; $i++) {
+ my $key = key($i);
+ my $set = $memc->set($key, $key);
+ $sets++ if $set;
+ }
+
+ for (1..int(rand(500))) {
+ my $rand = int(rand($max));
+ my $key = key($rand);
+ my $meth = int(rand(3));
+ my $exp = int(rand(3));
+ undef $exp unless $exp;
+ $start->();
+ if ($meth == 0) {
+ $memc->add($key, $key, $exp);
+ $stop->("add");
+ } elsif ($meth == 1) {
+ $memc->delete($key);
+ $stop->("delete");
+ } else {
+ $memc->set($key, $key, $exp);
+ $stop->("set");
+ }
+ $rand = int(rand($max));
+ $key = key($rand);
+ $start->();
+ my $v = $memc->get($key);
+ $stop->("get");
+ if ($v && $v ne $key) { die "Bogus: $v for key $rand\n"; }
+ }
+
+ $start->();
+ my $multi = $memc->get_multi(map { key(int(rand($max))) } (1..$max));
+ $stop->("get_multi");
+}
+
+sub key {
+ my $n = shift;
+ $_ = sprintf("%04d", $n);
+ if ($n % 2) { $_ .= "a"x20; }
+ $_;
+}
Property changes on: branches/memcached-1.1.x/t/stress-memcached.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/udp.t
===================================================================
--- branches/memcached-1.1.x/t/udp.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/udp.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,138 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More;
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+if (MemcachedTest::supports_udp()) {
+ plan tests => 33;
+} else {
+ plan 'skip_all' => "No UDP support in this release.";
+ exit 0;
+}
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
+# set foo (and should get it)
+print $sock "set foo 0 0 6\r\nfooval\r\n";
+is(scalar <$sock>, "STORED\r\n", "stored foo");
+mem_get_is($sock, "foo", "fooval");
+
+my $usock = $server->new_udp_sock
+ or die "Can't bind : $@\n";
+
+# test all the steps, one by one:
+test_single($usock);
+
+# testing sequence numbers
+for my $offt (1, 1, 2) {
+ my $seq = 160 + $offt;
+ my $res = send_udp_request($usock, $seq, "get foo\r\n");
+ ok($res, "got result");
+ is(keys %$res, 1, "one key (one packet)");
+ ok($res->{0}, "only got seq number 0");
+ is(substr($res->{0}, 8), "VALUE foo 0 6\r\nfooval\r\nEND\r\n");
+ is(hexify(substr($res->{0}, 0, 2)), hexify(pack("n", $seq)), "sequence number in response ($seq) is correct");
+}
+
+# testing non-existent stuff
+my $res = send_udp_request($usock, 404, "get notexist\r\n");
+ok($res, "got result");
+is(keys %$res, 1, "one key (one packet)");
+ok($res->{0}, "only got seq number 0");
+is(hexify(substr($res->{0}, 0, 2)), hexify(pack("n", 404)), "sequence number 404 correct");
+is(substr($res->{0}, 8), "END\r\n");
+
+# test multi-packet response
+{
+ my $big = "abcd" x 1024;
+ my $len = length $big;
+ print $sock "set big 0 0 $len\r\n$big\r\n";
+ is(scalar <$sock>, "STORED\r\n", "stored big");
+ mem_get_is($sock, "big", $big, "big value matches");
+ my $res = send_udp_request($usock, 999, "get big\r\n");
+ is(scalar keys %$res, 3, "three packet response");
+ like($res->{0}, qr/VALUE big 0 4096/, "first packet has value line");
+ like($res->{2}, qr/\r\nEND\r\n/, "last packet has end");
+ is(hexify(substr($res->{1}, 0, 2)), hexify(pack("n", 999)), "sequence number of middle packet is correct");
+}
+
+sub test_single {
+ my $usock = shift;
+ my $req = pack("nnnn", 45, 0, 1, 0); # request id (opaque), seq num, #packets, reserved (must be 0)
+ $req .= "get foo\r\n";
+ ok(defined send($usock, $req, 0), "sent request");
+
+ my $rin = '';
+ vec($rin, fileno($usock), 1) = 1;
+ my $rout;
+ ok(select($rout = $rin, undef, undef, 2.0), "got readability");
+
+ my $sender;
+ my $res;
+ $sender = $usock->recv($res, 1500, 0);
+
+ my $id = pack("n", 45);
+ is(hexify(substr($res, 0, 8)), hexify($id) . '0000' . '0001' . '0000', "header is correct");
+ is(length $res, 36, '');
+ is(substr($res, 8), "VALUE foo 0 6\r\nfooval\r\nEND\r\n", "payload is as expected");
+}
+
+sub hexify {
+ my $val = shift;
+ $val =~ s/(.)/sprintf("%02x", ord($1))/egs;
+ return $val;
+}
+
+# returns undef on select timeout, or hashref of "seqnum" -> payload (including headers)
+sub send_udp_request {
+ my ($sock, $reqid, $req) = @_;
+
+ my $pkt = pack("nnnn", $reqid, 0, 1, 0); # request id (opaque), seq num, #packets, reserved (must be 0)
+ $pkt .= $req;
+ my $fail = sub {
+ my $msg = shift;
+ warn " FAILING send_udp because: $msg\n";
+ return undef;
+ };
+ return $fail->("send") unless send($sock, $pkt, 0);
+
+ my $ret = {};
+
+ my $got = 0; # packets got
+ my $numpkts = undef;
+
+ while (!defined($numpkts) || $got < $numpkts) {
+ my $rin = '';
+ vec($rin, fileno($sock), 1) = 1;
+ my $rout;
+ return $fail->("timeout after $got packets") unless
+ select($rout = $rin, undef, undef, 1.5);
+
+ my $res;
+ my $sender = $sock->recv($res, 1500, 0);
+ my ($resid, $seq, $this_numpkts, $resv) = unpack("nnnn", substr($res, 0, 8));
+ die "Response ID of $resid doesn't match request if of $reqid" unless $resid == $reqid;
+ die "Reserved area not zero" unless $resv == 0;
+ die "num packets changed midstream!" if defined $numpkts && $this_numpkts != $numpkts;
+ $numpkts = $this_numpkts;
+ $ret->{$seq} = $res;
+ $got++;
+ }
+ return $ret;
+}
+
+__END__
+$sender = recv($usock, $ans, 1050, 0);
+
+__END__
+$usock->send
+
+
+ ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!";
+($port, $hisiaddr) = sockaddr_in($hispaddr);
+$host = gethostbyaddr($hisiaddr, AF_INET);
+$histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;
Property changes on: branches/memcached-1.1.x/t/udp.t
___________________________________________________________________
Name: svn:executable
+ *
Added: branches/memcached-1.1.x/t/unixsocket.t
===================================================================
--- branches/memcached-1.1.x/t/unixsocket.t 2006-09-07 20:38:00 UTC (rev 379)
+++ branches/memcached-1.1.x/t/unixsocket.t 2006-09-09 17:13:40 UTC (rev 380)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use Test::More skip_all => "Tests not written."; # tests => 1
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use MemcachedTest;
+
+my $server = new_memcached();
+my $sock = $server->sock;
+
Property changes on: branches/memcached-1.1.x/t/unixsocket.t
___________________________________________________________________
Name: svn:executable
+ *
More information about the memcached-commits
mailing list