5 use Test
::More tests
=> 3539;
10 my $server = new_memcached();
11 ok($server, "started the server");
13 # Based almost 100% off testClient.py which is:
14 # Copyright (c) 2007 Dustin Sallings <dustin@spy.net>
17 use constant CMD_GET => 0x00;
18 use constant CMD_SET => 0x01;
19 use constant CMD_ADD => 0x02;
20 use constant CMD_REPLACE => 0x03;
21 use constant CMD_DELETE => 0x04;
22 use constant CMD_INCR => 0x05;
23 use constant CMD_DECR => 0x06;
24 use constant CMD_QUIT => 0x07;
25 use constant CMD_FLUSH => 0x08;
26 use constant CMD_GETQ => 0x09;
27 use constant CMD_NOOP => 0x0A;
28 use constant CMD_VERSION => 0x0B;
29 use constant CMD_GETK => 0x0C;
30 use constant CMD_GETKQ => 0x0D;
31 use constant CMD_APPEND => 0x0E;
32 use constant CMD_PREPEND => 0x0F;
33 use constant CMD_STAT => 0x10;
34 use constant CMD_SETQ => 0x11;
35 use constant CMD_ADDQ => 0x12;
36 use constant CMD_REPLACEQ => 0x13;
37 use constant CMD_DELETEQ => 0x14;
38 use constant CMD_INCREMENTQ => 0x15;
39 use constant CMD_DECREMENTQ => 0x16;
40 use constant CMD_QUITQ => 0x17;
41 use constant CMD_FLUSHQ => 0x18;
42 use constant CMD_APPENDQ => 0x19;
43 use constant CMD_PREPENDQ => 0x1A;
44 use constant CMD_TOUCH => 0x1C;
45 use constant CMD_GAT => 0x1D;
46 use constant CMD_GATQ => 0x1E;
47 use constant CMD_GATK => 0x23;
48 use constant CMD_GATKQ => 0x24;
50 # REQ and RES formats are divided even though they currently share
51 # the same format, since they _could_ differ in the future.
52 use constant REQ_PKT_FMT => "CCnCCnNNNN";
53 use constant RES_PKT_FMT => "CCnCCnNNNN";
54 use constant INCRDECR_PKT_FMT => "NNNNN";
55 use constant MIN_RECV_BYTES => length(pack(RES_PKT_FMT));
56 use constant REQ_MAGIC => 0x80;
57 use constant RES_MAGIC => 0x81;
59 my $mc = MC::Client->new;
61 # Let's turn on detail stats for all this stuff
63 $mc->stats('detail on');
66 my ($key, $orig_flags, $orig_val) = @_;
67 my ($flags, $val, $cas) = $mc->get($key);
68 is($flags, $orig_flags, "Flags is set properly");
69 ok($val eq $orig_val || $val == $orig_val, $val . " = " . $orig_val);
73 my ($key, $exp, $orig_flags, $orig_value) = @_;
74 $mc->set($key, $orig_value, $orig_flags, $exp);
75 $check->($key, $orig_flags, $orig_value);
80 my $rv =()= eval { $mc->get($key) };
81 is($rv, 0, "Didn't get a result from get");
82 ok($@->not_found, "We got a not found error when we expected one");
86 my ($key, $when) = @_;
87 $mc->delete($key, $when);
91 # diag "Test Version";
93 ok(defined $v && length($v), "Proper version: $v");
97 my %stats1 = $mc->stats('');
99 my %stats2 = $mc->stats('');
101 is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
102 "Stats not updated on a binary flush");
105 # diag "Flushing...";
111 # diag "Simple set/get";
112 $set->('x', 5, 19, "somevalue");
118 $set->('x', 5, 19, "somevaluex");
119 $set->('y', 5, 17, "somevaluey");
127 $mc->add('i', 'ex', 5, 10);
128 $check->('i', 5, "ex");
130 my $rv =()= eval { $mc->add('i', "ex2", 10, 5) };
131 is($rv, 0, "Add didn't return anything");
132 ok($@->exists, "Expected exists error received");
133 $check->('i', 5, "ex");
139 $mc->set('toobig', 'not too big', 10, 10);
141 my $bigval = ("x" x (1024*1024)) . "x";
142 $mc->set('toobig', $bigval, 10, 10);
144 ok($@->too_big, "Was too big");
152 my $rv =()= eval { $mc->replace('j', "ex", 19, 5) };
153 is($rv, 0, "Replace didn't return anything");
154 ok($@->not_found, "Expected not_found error received");
156 $mc->add('j', "ex2", 14, 5);
157 $check->('j', 14, "ex2");
158 $mc->replace('j', "ex3", 24, 5);
159 $check->('j', 24, "ex3");
164 $mc->add('xx', "ex", 1, 5);
165 $mc->add('wye', "why", 2, 5);
166 my $rv = $mc->get_multi(qw(xx wye zed));
168 # CAS is returned with all gets.
171 is_deeply
($rv->{xx
}, [1, 'ex', 0], "X is correct");
172 is_deeply
($rv->{wye
}, [2, 'why', 0], "Y is correct");
173 is
(keys(%$rv), 2, "Got only two answers like we expect");
176 # diag "Test increment";
178 is
($mc->incr("x"), 0, "First incr call is zero");
179 is
($mc->incr("x"), 1, "Second incr call is one");
180 is
($mc->incr("x", 211), 212, "Adding 211 gives you 212");
181 is
($mc->incr("x", 2**33), 8589934804, "Blast the 32bit border");
183 # diag "Issue 48 - incrementing plain text.";
185 $mc->set("issue48", "text", 0, 0);
186 my $rv =()= eval { $mc->incr('issue48'); };
187 ok
($@
&& $@
->delta_badval, "Expected invalid value when incrementing text.");
188 $check->('issue48', 0, "text");
190 $rv =()= eval { $mc->decr('issue48'); };
191 ok
($@
&& $@
->delta_badval, "Expected invalid value when decrementing text.");
192 $check->('issue48', 0, "text");
196 # diag "Test decrement";
198 is
($mc->incr("x", undef, 5), 5, "Initial value");
199 is
($mc->decr("x"), 4, "Decrease by one");
200 is
($mc->decr("x", 211), 0, "Floor is zero");
204 my ($rv, $cas) = $mc->set("bug220", "100", 0, 0);
205 my ($irv, $icas) = $mc->incr_cas("bug220", 999);
207 is
($irv, 1099, "Incr amount failed");
208 my ($flags, $val, $gcas) = $mc->get("bug220");
209 is
($gcas, $icas, "CAS didn't match after incr/gets");
211 ($irv, $icas) = $mc->incr_cas("bug220", 999);
213 is
($irv, 2098, "Incr amount failed");
214 ($flags, $val, $gcas) = $mc->get("bug220");
215 is
($gcas, $icas, "CAS didn't match after incr/gets");
220 $mc->add("bug21", "9223372036854775807", 0, 0);
221 is
($mc->incr("bug21"), 9223372036854775808, "First incr for bug21.");
222 is
($mc->incr("bug21"), 9223372036854775809, "Second incr for bug21.");
223 is
($mc->decr("bug21"), 9223372036854775808, "Decr for bug21.");
231 my $rv =()= eval { $mc->set("x", "bad value", 19, 5, 0x7FFFFFF) };
232 is
($rv, 0, "Empty return on expected failure");
233 ok
($@
->not_found, "Error was 'not found' as expected");
236 my ($r, $rcas) = $mc->add("x", "original value", 5, 19);
238 my ($flags, $val, $i) = $mc->get("x");
239 is
($val, "original value", "->gets returned proper value");
240 is
($rcas, $i, "Add CAS matched.");
243 my $rv =()= eval { $mc->set("x", "broken value", 19, 5, $i+1) };
244 is
($rv, 0, "Empty return on expected failure (1)");
245 ok
($@
->exists, "Expected error state of 'exists' (1)");
248 ($r, $rcas) = $mc->set("x", "new value", 19, 5, $i);
250 my ($newflags, $newval, $newi) = $mc->get("x");
251 is
($newval, "new value", "CAS properly overwrote value");
252 is
($rcas, $newi, "Get CAS matched.");
255 my $rv =()= eval { $mc->set("x", "replay value", 19, 5, $i) };
256 is
($rv, 0, "Empty return on expected failure (2)");
257 ok
($@
->exists, "Expected error state of 'exists' (2)");
261 # diag "Touch commands";
264 $mc->set("totouch", "toast", 0, 1);
265 my $res = $mc->touch("totouch", 10);
267 $check->("totouch", 0, "toast");
269 $mc->set("totouch", "toast2", 0, 1);
270 my ($flags, $val, $i) = $mc->gat("totouch", 10);
271 is
($val, "toast2", "GAT returned correct value");
273 $check->("totouch", 0, "toast2");
278 # diag "Silent set.";
279 $mc->silent_mutation(::CMD_SETQ
, 'silentset', 'silentsetval');
281 # diag "Silent add.";
282 $mc->silent_mutation(::CMD_ADDQ
, 'silentadd', 'silentaddval');
284 # diag "Silent replace.";
286 my $key = "silentreplace";
287 my $extra = pack "NN", 829, 0;
289 # $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
292 $mc->add($key, "xval", 831, 0);
293 $check->($key, 831, 'xval');
295 $mc->send_silent(::CMD_REPLACEQ
, $key, 'somevalue', 7278552, $extra, 0);
296 $check->($key, 829, 'somevalue');
299 # diag "Silent delete";
301 my $key = "silentdelete";
303 $mc->set($key, "some val", 19, 0);
304 $mc->send_silent(::CMD_DELETEQ
, $key, '', 772);
308 # diag "Silent increment";
310 my $key = "silentincr";
311 my $opaque = 98428747;
313 $mc->silent_incrdecr(::CMD_INCREMENTQ
, $key, 0, 0, 0);
314 is
($mc->incr($key, 0), 0, "First call is 0");
316 $mc->silent_incrdecr(::CMD_INCREMENTQ
, $key, 8, 0, 0);
317 is
($mc->incr($key, 0), 8);
320 # diag "Silent decrement";
322 my $key = "silentdecr";
323 my $opaque = 98428147;
325 $mc->silent_incrdecr(::CMD_DECREMENTQ
, $key, 0, 185, 0);
326 is
($mc->incr($key, 0), 185);
328 $mc->silent_incrdecr(::CMD_DECREMENTQ
, $key, 8, 0, 0);
329 is
($mc->incr($key, 0), 177);
332 # diag "Silent flush";
334 my %stats1 = $mc->stats('');
336 $set->('x', 5, 19, "somevaluex");
337 $set->('y', 5, 17, "somevaluey");
338 $mc->send_silent(::CMD_FLUSHQ
, '', '', 2775256);
342 my %stats2 = $mc->stats('');
343 is
($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
344 "Stats not updated on a binary quiet flush");
349 my $key = "appendkey";
350 my $value = "some value";
351 $set->($key, 8, 19, $value);
352 $mc->_append_prepend(::CMD_APPEND
, $key, " more");
353 $check->($key, 19, $value . " more");
358 my $key = "prependkey";
359 my $value = "some value";
360 $set->($key, 8, 19, $value);
361 $mc->_append_prepend(::CMD_PREPEND
, $key, "prefixed ");
362 $check->($key, 19, "prefixed " . $value);
365 # diag "Silent append";
367 my $key = "appendqkey";
368 my $value = "some value";
369 $set->($key, 8, 19, $value);
370 $mc->send_silent(::CMD_APPENDQ
, $key, " more", 7284492);
371 $check->($key, 19, $value . " more");
374 # diag "Silent prepend";
376 my $key = "prependqkey";
377 my $value = "some value";
378 $set->($key, 8, 19, $value);
379 $mc->send_silent(::CMD_PREPENDQ
, $key, "prefixed ", 7284492);
380 $check->($key, 19, "prefixed " . $value);
383 # diag "Leaky binary get test.";
384 # # http://code.google.com/p/memcached/issues/detail?id=16
386 # Get a new socket so we can speak text to it.
387 my $sock = $server->new_sock;
388 my $max = 1024 * 1024;
389 my $big = "a big value that's > .5M and < 1M. ";
390 while (length($big) * 2 < $max) {
393 my $biglen = length($big);
396 my $key = "some_key_$_";
397 # print STDERR "Key is $key\n";
398 # print $sock "set $key 0 0 $vallen\r\n$value\r\n";
399 print $sock "set $key 0 0 $biglen\r\n$big\r\n";
400 is
(scalar <$sock>, "STORED\r\n", "stored big");
401 my ($f, $v, $c) = $mc->get($key);
405 # diag "Test stats settings."
407 my %stats = $mc->stats('settings');
409 is
(1024, $stats{'maxconns'});
410 is
('NULL', $stats{'domain_socket'});
411 is
('on', $stats{'evictions'});
412 is
('yes', $stats{'cas_enabled'});
415 # diag "Test quit commands.";
417 my $s2 = new_memcached
();
418 my $mc2 = MC
::Client
->new($s2);
419 $mc2->send_command(CMD_QUITQ
, '', '', 0, '', 0);
421 # Five seconds ought to be enough to get hung up on.
422 my $oldalarmt = alarm(5);
424 # Verify we can't read anything.
427 local $SIG{'ALRM'} = sub { die "timeout" };
429 $bytesread = sysread($mc2->{socket}, $data, 24),
431 is
($bytesread, 0, "Read after quit.");
433 # Restore signal stuff.
437 # diag "Test protocol boundary overruns";
439 use List
::Util qw
[min
];
440 # Attempting some protocol overruns by toying around with the edge
441 # of the data buffer at a few different sizes. This assumes the
442 # boundary is at or around 2048 bytes.
443 for (my $i = 1900; $i < 2100; $i++) {
444 my $k = "test_key_$i";
446 # diag "Trying $i $k";
447 my $extra = pack "NN", 82, 0;
448 my $data = $mc->build_command(::CMD_SETQ
, $k, $v, 0, $extra, 0);
449 $data .= $mc->build_command(::CMD_SETQ
, "alt_$k", "blah", 0, $extra, 0);
450 if (length($data) > 2024) {
451 for (my $j = 2024; $j < min
(2096, length($data)); $j++) {
452 $mc->{socket}->send(substr($data, 0, $j));
455 $mc->{socket}->send(substr($data, $j));
459 $mc->{socket}->send($data);
462 $check->($k, 82, $v);
463 $check->("alt_$k", 82, "blah");
467 # Along with the assertion added to the code to verify we're staying
468 # within bounds when we do a stats detail dump (detail turned on at
470 my %stats = $mc->stats('detail dump');
472 # This test causes a disconnection.
474 # diag "Key too large.";
477 $mc->get($key, 'should die', 10, 10);
479 ok
($@
->einval, "Invalid key length");
482 # ######################################################################
483 # Test ends around here.
484 # ######################################################################
490 use fields
qw(socket);
491 use IO
::Socket
::INET
;
496 $s = $server unless defined $s;
498 $self = fields
::new
($self);
499 $self->{socket} = $sock;
505 die "Not enough args to send_command" unless @_ >= 4;
506 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
508 $extra_header = '' unless defined $extra_header;
509 my $keylen = length($key);
510 my $vallen = length($val);
511 my $extralen = length($extra_header);
512 my $datatype = 0; # field for future use
513 my $reserved = 0; # field for future use
514 my $totallen = $keylen + $vallen + $extralen;
519 $ident_hi = int($cas / 2 ** 32);
520 $ident_lo = int($cas % 2 ** 32);
523 my $msg = pack(::REQ_PKT_FMT
, ::REQ_MAGIC
, $cmd, $keylen, $extralen,
524 $datatype, $reserved, $totallen, $opaque, $ident_hi,
526 my $full_msg = $msg . $extra_header . $key . $val;
532 die "Not enough args to send_command" unless @_ >= 4;
533 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
535 my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
537 my $sent = $self->{socket}->send($full_msg);
538 die("Send failed: $!") unless $sent;
539 if($sent != length($full_msg)) {
540 die("only sent $sent of " . length($full_msg) . " bytes");
546 $self->{socket}->flush;
549 # Send a silent command and ensure it doesn't respond.
552 die "Not enough args to send_silent" unless @_ >= 4;
553 my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
555 $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
556 $self->send_command(::CMD_NOOP
, '', '', $opaque + 1);
558 my ($ropaque, $data) = $self->_handle_single_response;
559 Test
::More
::is
($ropaque, $opaque + 1);
562 sub silent_mutation
{
564 my ($cmd, $key, $value) = @_;
567 my $extra = pack "NN", 82, 0;
568 $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
569 $check->($key, 82, $value);
572 sub _handle_single_response
{
574 my $myopaque = shift;
577 while(::MIN_RECV_BYTES
- length($hdr) > 0) {
578 $self->{socket}->recv(my $response, ::MIN_RECV_BYTES
- length($hdr));
581 Test
::More
::is
(length($hdr), ::MIN_RECV_BYTES
, "Expected read length");
583 my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
584 $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT
, $hdr);
585 Test
::More
::is
($magic, ::RES_MAGIC
, "Got proper response magic");
587 my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
589 return ($opaque, '', $cas, 0) if($remaining == 0);
593 while($remaining - length($rv) > 0) {
594 $self->{socket}->recv(my $buf, $remaining - length($rv));
597 if(length($rv) != $remaining) {
598 my $found = length($rv);
599 die("Expected $remaining bytes, got $found");
602 if (defined $myopaque) {
603 Test
::More
::is
($opaque, $myopaque, "Expected opaque");
605 Test
::More
::pass
("Implicit pass since myopaque is undefined");
609 die MC
::Error
->new($status, $rv);
612 return ($opaque, $rv, $cas, $keylen);
618 my ($cmd, $key, $val, $extra_header, $cas) = @_;
620 $extra_header = '' unless defined $extra_header;
621 my $opaque = int(rand(2**32));
622 $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
623 my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);
627 sub _incrdecr_header
{
629 my ($amt, $init, $exp) = @_;
631 my $amt_hi = int($amt / 2 ** 32);
632 my $amt_lo = int($amt % 2 ** 32);
634 my $init_hi = int($init / 2 ** 32);
635 my $init_lo = int($init % 2 ** 32);
637 my $extra_header = pack(::INCRDECR_PKT_FMT
, $amt_hi, $amt_lo, $init_hi,
640 return $extra_header;
645 my ($cmd, $key, $amt, $init, $exp) = @_;
647 my ($data, $rcas) = $self->_do_command($cmd, $key, '',
648 $self->_incrdecr_header($amt, $init, $exp));
650 my $header = substr $data, 0, 8, '';
651 my ($resp_hi, $resp_lo) = unpack "NN", $header;
652 my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
659 my ($v, $c) = $self->_incrdecr_cas(@_);
663 sub silent_incrdecr
{
665 my ($cmd, $key, $amt, $init, $exp) = @_;
666 my $opaque = 8275753;
668 $mc->send_silent($cmd, $key, '', $opaque,
669 $mc->_incrdecr_header($amt, $init, $exp));
676 my $opaque = int(rand(2**32));
677 $self->send_command(::CMD_STAT
, $key, '', $opaque, '', $cas);
683 my ($op, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
685 $found_key = substr($data, 0, $keylen);
686 $found_val = substr($data, $keylen);
687 $rv{$found_key} = $found_val;
691 } while($found_key ne '');
698 my ($rv, $cas) = $self->_do_command(::CMD_GET
, $key, '', '');
700 my $header = substr $rv, 0, 4, '';
701 my $flags = unpack("N", $header);
703 return ($flags, $rv, $cas);
710 for (my $i = 0; $i < @keys; $i++) {
711 $self->send_command(::CMD_GETQ
, $keys[$i], '', $i, '', 0);
714 my $terminal = @keys + 10;
715 $self->send_command(::CMD_NOOP
, '', '', $terminal);
719 my ($opaque, $data) = $self->_handle_single_response;
720 last if $opaque == $terminal;
722 my $header = substr $data, 0, 4, '';
723 my $flags = unpack("N", $header);
725 $return{$keys[$opaque]} = [$flags, $data];
728 return %return if wantarray;
734 my ($key, $expire) = @_;
735 my $extra_header = pack "N", $expire;
737 return $self->_do_command(::CMD_TOUCH
, $key, '', $extra_header, $cas);
744 my $extra_header = pack "N", $expire;
745 my ($rv, $cas) = $self->_do_command(::CMD_GAT
, $key, '', $extra_header);
747 my $header = substr $rv, 0, 4, '';
748 my $flags = unpack("N", $header);
750 return ($flags, $rv, $cas);
755 return $self->_do_command(::CMD_VERSION
, '', '');
760 return $self->_do_command(::CMD_FLUSH
, '', '');
765 my ($key, $val, $flags, $expire) = @_;
766 my $extra_header = pack "NN", $flags, $expire;
768 return $self->_do_command(::CMD_ADD
, $key, $val, $extra_header, $cas);
773 my ($key, $val, $flags, $expire, $cas) = @_;
774 my $extra_header = pack "NN", $flags, $expire;
775 return $self->_do_command(::CMD_SET
, $key, $val, $extra_header, $cas);
778 sub _append_prepend
{
780 my ($cmd, $key, $val, $cas) = @_;
781 return $self->_do_command($cmd, $key, $val, '', $cas);
786 my ($key, $val, $flags, $expire) = @_;
787 my $extra_header = pack "NN", $flags, $expire;
789 return $self->_do_command(::CMD_REPLACE
, $key, $val, $extra_header, $cas);
795 return $self->_do_command(::CMD_DELETE
, $key, '');
800 my ($key, $amt, $init, $exp) = @_;
801 $amt = 1 unless defined $amt;
802 $init = 0 unless defined $init;
803 $exp = 0 unless defined $exp;
805 return $self->_incrdecr(::CMD_INCR
, $key, $amt, $init, $exp);
810 my ($key, $amt, $init, $exp) = @_;
811 $amt = 1 unless defined $amt;
812 $init = 0 unless defined $init;
813 $exp = 0 unless defined $exp;
815 return $self->_incrdecr_cas(::CMD_INCR
, $key, $amt, $init, $exp);
820 my ($key, $amt, $init, $exp) = @_;
821 $amt = 1 unless defined $amt;
822 $init = 0 unless defined $init;
823 $exp = 0 unless defined $exp;
825 return $self->_incrdecr(::CMD_DECR
, $key, $amt, $init, $exp);
830 return $self->_do_command(::CMD_NOOP
, '', '');
838 use constant ERR_UNKNOWN_CMD
=> 0x81;
839 use constant ERR_NOT_FOUND
=> 0x1;
840 use constant ERR_EXISTS
=> 0x2;
841 use constant ERR_TOO_BIG
=> 0x3;
842 use constant ERR_EINVAL
=> 0x4;
843 use constant ERR_NOT_STORED
=> 0x5;
844 use constant ERR_DELTA_BADVAL
=> 0x6;
846 use overload
'""' => sub {
848 return "Memcache Error ($self->[0]): $self->[1]";
854 my $self = bless $error, (ref $class || $class);
861 return $self->[0] == ERR_NOT_FOUND
;
866 return $self->[0] == ERR_EXISTS
;
871 return $self->[0] == ERR_TOO_BIG
;
876 return $self->[0] == ERR_DELTA_BADVAL
;
881 return $self->[0] == ERR_EINVAL
;