@@ -7,84 +7,73 @@ use FindBin qw($Bin); use lib "$Bin/lib"; use MemcachedTest; -ok("foo", "foo"); -=temporarily_disable my $server = new_memcached(); - ok($server, "started the server"); -# Based almost 100% off testClient.py which is Copyright (c) 2007 Dustin Sallings <dustin@spy.net> +# Based almost 100% off testClient.py which is: +# Copyright (c) 2007 Dustin Sallings <dustin@spy.net> # Command constants -use constant CMD_GET => 0; -use constant CMD_SET => 1; -use constant CMD_ADD => 2; -use constant CMD_REPLACE => 3; -use constant CMD_DELETE => 4; -use constant CMD_INCR => 5; -use constant CMD_DECR => 6; -use constant CMD_QUIT => 7; -use constant CMD_FLUSH => 8; -use constant CMD_GETQ => 9; -use constant CMD_NOOP => 10; -use constant CMD_VERSION => 11; - -# CAS, Flags, expiration -use constant SET_PKT_FMT => "NNNN"; - -# Flags, expiration, id -use constant CAS_PKT_FMT => "NNNN"; - -# How long until the deletion takes effect. -use constant DEL_PKT_FMT => "N"; - -# amount, initial value, expiration +use constant CMD_GET => 0x00; +use constant CMD_SET => 0x01; +use constant CMD_ADD => 0x02; +use constant CMD_REPLACE => 0x03; +use constant CMD_DELETE => 0x04; +use constant CMD_INCR => 0x05; +use constant CMD_DECR => 0x06; +use constant CMD_QUIT => 0x07; +use constant CMD_FLUSH => 0x08; +use constant CMD_GETQ => 0x09; +use constant CMD_NOOP => 0x0A; +use constant CMD_VERSION => 0x0B; +use constant CMD_GETK => 0x0C; +use constant CMD_GETKQ => 0x0D; +use constant CMD_APPEND => 0x0E; +use constant CMD_PREPEND => 0x0F; + +# REQ and RES formats are divided even though they currently share +# the same format, since they _could_ differ in the future. +use constant REQ_PKT_FMT => "CCnCCnNNNN"; +use constant RES_PKT_FMT => "CCnCCnNNNN"; use constant INCRDECR_PKT_FMT => "NNNNN"; - -use constant REQ_MAGIC_BYTE => 0x80; -use constant RES_MAGIC_BYTE => 0x81; - -use constant PKT_FMT => "CCnCxxxNN"; - -#min recv packet size -use constant MIN_RECV_PACKET => length(pack(PKT_FMT)); +use constant MIN_RECV_BYTES => length(pack(RES_PKT_FMT)); +use constant REQ_MAGIC => 0x80; +use constant RES_MAGIC => 0x81; my $mc = MC::Client->new; + my $check = sub { - my ($key, $orig_flags, $orig_value) = @_; - my ($flags, $value) = $mc->get($key); - is($flags, $orig_flags, "Flags is set properly"); - is($value, $orig_value, "Value is set properly"); + my ($key, $orig_flags, $orig_val) = @_; + my ($flags, $val, $cas) = $mc->get($key); + is($flags, $orig_flags, "Flags is set properly"); }; my $set = sub { - my ($key, $exp, $orig_flags, $orig_value) = @_; - $mc->set($key, $exp, $orig_flags, $orig_value); - $check->($key, $orig_flags, $orig_value); + my ($key, $exp, $orig_flags, $orig_value) = @_; + $mc->set($key, $orig_value, $orig_flags, $exp); + $check->($key, $orig_flags, $orig_value); }; my $empty = sub { - my $key = shift; - my $rv =()= eval { $mc->get($key) }; - is($rv, 0, "Didn't get a result from get"); - ok($@->not_found, "We got a not found error when we expected one"); + my $key = shift; + my $rv =()= eval { $mc->get($key) }; + is($rv, 0, "Didn't get a result from get"); + ok($@->not_found, "We got a not found error when we expected one"); }; my $delete = sub { - my ($key, $when) = @_; - $mc->delete($key, $when); - $empty->($key); + my ($key, $when) = @_; + $mc->delete($key, $when); + $empty->($key); }; +diag "Test Version"; +my $v = $mc->version; +ok(defined $v && length($v), "Proper version: $v"); + diag "Flushing..."; $mc->flush; -{ - diag "Test Version"; - my $v = $mc->version; - ok(defined $v && length($v), "Proper version: $v"); -} - diag "Noop"; $mc->noop; @@ -102,58 +91,43 @@ $empty->('x'); $empty->('y'); { - diag "Reservation delete"; - $set->('y', 5, 19, "someothervalue"); - $delete->('y', 1); - my $rv =()= eval { $mc->add('y', 5, 19, "yetanothervalue") }; - is($rv, 0, "Add didn't return anything"); - ok($@->exists, "We got an exists error like we expected"); - sleep 2; - $mc->add('y', 5, 19, "wibblevalue"); + diag "Add"; + $empty->('i'); + $mc->add('i', 'ex', 5, 10); + $check->('i', 5, "ex"); + + my $rv =()= eval { $mc->add('i', "ex2", 10, 5) }; + is($rv, 0, "Add didn't return anything"); + ok($@->exists, "Expected exists error received"); + $check->('i', 5, "ex"); } { - diag "Add"; - $empty->('i'); - $mc->add('i', 5, 19, "ex"); - $check->('i', 19, "ex"); - - my $rv =()= eval { $mc->add('i', 5, 19, "ex2") }; - is($rv, 0, "Add didn't return anything"); - ok($@->exists, "Expected exists error received"); - - $check->('i', 19, "ex"); + diag "Replace"; + $empty->('j'); + + my $rv =()= eval { $mc->replace('j', "ex", 19, 5) }; + is($rv, 0, "Replace didn't return anything"); + ok($@->not_found, "Expected not_found error received"); + $empty->('j'); + $mc->add('j', "ex2", 14, 5); + $check->('j', 14, "ex2"); + $mc->replace('j', "ex3", 24, 5); + $check->('j', 24, "ex3"); } { - diag "Replace"; - $empty->('j'); - - my $rv =()= eval { $mc->replace('j', 5, 19, "ex") }; - is($rv, 0, "Replace didn't return anything"); - ok($@->not_found, "Expected not_found error received"); - - $empty->('j'); - - $mc->add('j', 5, 14, "ex2"); - $check->('j', 14, "ex2"); - - $mc->replace('j', 5, 24, "ex3"); - $check->('j', 24, "ex3"); -} - -{ - diag "MultiGet"; - $mc->add('xx', 5, 1, "ex"); - $mc->add('wye', 5, 2, "why"); - my $rv = $mc->getMulti(qw(xx wye zed)); + diag "MultiGet"; + $mc->add('xx', "ex", 1, 5); + $mc->add('wye', "why", 2, 5); + my $rv = $mc->get_multi(qw(xx wye zed)); # CAS is returned with all gets. $rv->{xx}->[2] = 0; $rv->{wye}->[2] = 0; - is_deeply($rv->{xx}, [1, 'ex', 0], "X is correct"); - is_deeply($rv->{wye}, [2, 'why', 0], "Y is correct"); - is(keys(%$rv), 2, "Got only two answers like we expect"); + is_deeply($rv->{xx}, [1, 'ex', 0], "X is correct"); + is_deeply($rv->{wye}, [2, 'why', 0], "Y is correct"); + is(keys(%$rv), 2, "Got only two answers like we expect"); } diag "Test increment"; @@ -170,264 +144,247 @@ is($mc->decr("x"), 4, "Decrease by one"); is($mc->decr("x", 211), 0, "Floor is zero"); { - diag "CAS"; - $mc->flush; + diag "CAS"; + $mc->flush; - { - my $rv =()= eval { $mc->set("x", 5, 19, "bad value", 0x7FFFFFFFFF) }; - is($rv, 0, "Empty return on expected failure"); - ok($@->not_found, "Error was 'not found' as expected"); - } + { + my $rv =()= eval { $mc->set("x", "bad value", 19, 5, 0x7FFFFFFFFF) }; + is($rv, 0, "Empty return on expected failure"); + ok($@->not_found, "Error was 'not found' as expected"); + } - $mc->add("x", 5, 19, "original value"); + $mc->add("x", "original value", 5, 19); - my ($flags, $val, $i) = $mc->get("x"); - is($val, "original value", "->gets returned proper value"); + my ($flags, $val, $i) = $mc->get("x"); + is($val, "original value", "->gets returned proper value"); { - my $rv =()= eval { $mc->set("x", 5, 19, "broken value", $i+1) }; - is($rv, 0, "Empty return on expected failure (1)"); - ok($@->exists, "Expected error state of 'exists' (1)"); - } - - $mc->set("x", 5, 19, "new value", $i); + my $rv =()= eval { $mc->set("x", "broken value", 19, 5, $i+1) }; + is($rv, 0, "Empty return on expected failure (1)"); + ok($@->exists, "Expected error state of 'exists' (1)"); + } - my ($newflags, $newval, $newi) = $mc->get("x"); - is($newval, "new value", "CAS properly overwrote value"); + $mc->set("x", "new value", 19, 5, $i); - { - my $rv =()= eval { $mc->set("x", 5, 19, "replay value", $i) }; - is($rv, 0, "Empty return on expected failure (2)"); - ok($@->exists, "Expected error state of 'exists' (2)"); - } + my ($newflags, $newval, $newi) = $mc->get("x"); + is($newval, "new value", "CAS properly overwrote value"); - (undef, my $newval2) = $mc->get("x"); - is($newval2, "new value", "CAS replay didn't overwrite value"); + { + my $rv =()= eval { $mc->set("x", "replay value", 19, 5, $i) }; + is($rv, 0, "Empty return on expected failure (2)"); + ok($@->exists, "Expected error state of 'exists' (2)"); + } } -$mc->flush; -$mc->close; - - package MC::Client; use strict; use warnings; - use fields qw(socket); - use IO::Socket::INET; sub new { - my $self = shift; - + my $self = shift; my $sock = $server->sock; + $self = fields::new($self); + $self->{socket} = $sock; + return $self; +} - $self = fields::new($self); - - $self->{socket} = $sock; +sub send_command { + my $self = shift; + die "Not enough args to send_command" unless @_ >= 4; + my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_; + + $extra_header = '' unless defined $extra_header; + my $keylen = length($key); + my $vallen = length($val); + my $extralen = length($extra_header); + my $datatype = 0; # field for future use + my $reserved = 0; # field for future use + my $totallen = $keylen + $vallen + $extralen; + my $ident_hi = 0; + my $ident_lo = 0; + + if ($cas) { + $ident_hi = int($cas / 2 ** 32); + $ident_lo = int($cas % 2 ** 32); + } - return $self; -} + my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen, + $datatype, $reserved, $totallen, $opaque, $ident_hi, + $ident_lo); -sub close { - my $self = shift; - return $self->{socket}->close(@_); + return $self->{socket}->send($msg . $extra_header . $key . $val); } -sub _sendCmd { - my $self = shift; - die "Not enough args to _sendCmd" unless @_ >= 4; - my ($cmd, $key, $val, $opaque, $extraHeader) = @_; +sub _handle_single_response { + my $self = shift; + my $myopaque = shift; - $extraHeader = '' unless defined $extraHeader; + $self->{socket}->recv(my $response, ::MIN_RECV_BYTES); + Test::More::is(length($response), ::MIN_RECV_BYTES, "Expected read length"); - my $keylen = length($key); - my $vallen = length($val); - my $extralen = length($extraHeader); + my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining, + $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $response); + Test::More::is($magic, ::RES_MAGIC, "Got proper response magic"); - my $msg = pack(::PKT_FMT, ::REQ_MAGIC_BYTE, $cmd, $keylen, $extralen, - $keylen + $vallen + $extralen, $opaque); - return $self->{socket}->send($msg . $extraHeader . $key . $val); -} + return ($opaque, '') if($remaining == 0); -sub _handleSingleResponse { - my $self = shift; - my $myopaque = shift; + # fetch the value + $self->{socket}->recv(my $rv, $remaining); - $self->{socket}->recv(my $response, ::MIN_RECV_PACKET); + if (defined $myopaque) { + Test::More::is($opaque, $myopaque, "Expected opaque"); + } else { + Test::More::pass("Implicit pass since myopaque is undefined"); + } - Test::More::is(length($response), ::MIN_RECV_PACKET, "Expected read length"); + my $cas = ($ident_hi * 2 ** 32) + $ident_lo; - my ($magic, $cmd, $errcode, $extralen, $remaining, - $opaque) = unpack(::PKT_FMT, $response); + if ($status) { + die MC::Error->new($status, $rv); + } - Test::More::is($magic, ::RES_MAGIC_BYTE, "Got proper magic"); + return ($opaque, $rv, $cas); +} - return ($opaque, "") - if $remaining == 0; +sub _do_command { + my $self = shift; + die unless @_ >= 3; + my ($cmd, $key, $val, $extra_header, $cas) = @_; - $self->{socket}->recv(my $rv, $remaining); + $extra_header = '' unless defined $extra_header; + my $opaque = int(rand(2**32)); + $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas); + (undef, my $rv, my $rcas) = $self->_handle_single_response($opaque); + return ($rv, $rcas); +} - if (defined $myopaque) { - Test::More::is($opaque, $myopaque, "Expected opaque"); - } else { - Test::More::pass("Implicit pass since myopaque is undefined"); - } +sub _incrdecr { + my $self = shift; + my ($cmd, $key, $amt, $init, $exp) = @_; - if ($errcode) { - die MC::Error->new($errcode, $rv); - } + my $amt_hi = int($amt / 2 ** 32); + my $amt_lo = int($amt % 2 ** 32); - return ($opaque, $rv); -} + my $init_hi = int($init / 2 ** 32); + my $init_lo = int($init % 2 ** 32); -sub _doCmd { - my $self = shift; - die unless @_ >= 3; - my ($cmd, $key, $val, $extraHeader) = @_; + my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi, + $init_lo, $exp); - $extraHeader = '' unless defined $extraHeader; + my ($data, undef) = $self->_do_command($cmd, $key, '', $extra_header); - my $opaque = int(rand(2**32)); + my $header = substr $data, 0, 8, ''; + my ($resp_hi, $resp_lo) = unpack "NN", $header; + my $resp = ($resp_hi * 2 ** 32) + $resp_lo; - $self->_sendCmd($cmd, $key, $val, $opaque, $extraHeader); - (undef, my $rv) = $self->_handleSingleResponse($opaque); - return $rv; + return $resp; } -sub __parseGet { - my $self = shift; - my $rv = shift; # currently contains 4 bytes of 'flag' followed by value - my $header = substr $rv, 0, 12, ''; - my ($ident_hi, $ident_lo, $flags) = unpack "NNN", $header; - my $ident = ($ident_hi * 2 ** 32) + $ident_lo; +sub get { + my $self = shift; + my $key = shift; + my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', ''); - return $flags, $rv, $ident; -} + my $header = substr $rv, 0, 4, ''; + my $flags = unpack("N", $header); -sub get { - my $self = shift; - my $key = shift; - my $parts = $self->_doCmd(::CMD_GET, $key, ''); - return $self->__parseGet($parts); + return ($flags, $rv, $cas); } -sub _mutate { - my $self = shift; - my ($cmd, $key, $exp, $flags, $val, $ident) = @_; +sub get_multi { + my $self = shift; + my @keys = @_; - my $ident_hi = 0; - my $ident_lo = 0; - if ($ident) { - $ident_hi = int($ident / 2 ** 32); - $ident_lo = int($ident % 2 ** 32); + for (my $i = 0; $i < @keys; $i++) { + $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0); } - return $self->_doCmd($cmd, $key, $val, pack(::SET_PKT_FMT, $ident_hi, $ident_lo, $flags, $exp)); -} - -sub set { - my $self = shift; - my ($key, $exp, $flags, $val, $ident) = @_; - - return $self->_mutate(::CMD_SET, $key, $exp, $flags, $val, $ident); -} + my $terminal = @keys + 10; + $self->send_command(::CMD_NOOP, '', '', $terminal); -sub __incrdecr { - my $self = shift; - my ($cmd, $key, $amt, $init, $exp) = @_; + my %return; + while (1) { + my ($opaque, $data) = $self->_handle_single_response; + last if $opaque == $terminal; - my $amt_hi = int($amt / 2 ** 32); - my $amt_lo = int($amt % 2 ** 32); + my $header = substr $data, 0, 4, ''; + my $flags = unpack("N", $header); - my $init_hi = int($init / 2 ** 32); - my $init_lo = int($init % 2 ** 32); + $return{$keys[$opaque]} = [$flags, $data]; + } - my $data = $self->_doCmd($cmd, $key, '', pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi, $init_lo, $exp)); - my $header = substr $data, 0, 12, ''; - my ($resp_hi, $resp_lo) = unpack "NN", $header; - my $resp = ($resp_hi * 2 ** 32) + $resp_lo; - return $resp; + return %return if wantarray; + return \%return; } -sub incr { - my $self = shift; - my ($key, $amt, $init, $exp) = @_; - $amt = 1 unless defined $amt; - $init = 0 unless defined $init; - $exp = 0 unless defined $exp; - - return $self->__incrdecr(::CMD_INCR, $key, $amt, $init, $exp); +sub version { + my $self = shift; + return $self->_do_command(::CMD_VERSION, '', ''); } -sub decr { - my $self = shift; - my ($key, $amt, $init, $exp) = @_; - $amt = 1 unless defined $amt; - $init = 0 unless defined $init; - $exp = 0 unless defined $exp; - - return $self->__incrdecr(::CMD_DECR, $key, $amt, $init, $exp); +sub flush { + my $self = shift; + return $self->_do_command(::CMD_FLUSH, '', ''); } sub add { - my $self = shift; - my ($key, $exp, $flags, $val) = @_; - return $self->_mutate(::CMD_ADD, $key, $exp, $flags, $val); -} -sub replace { - my $self = shift; - my ($key, $exp, $flags, $val) = @_; - return $self->_mutate(::CMD_REPLACE, $key, $exp, $flags, $val); + my $self = shift; + my ($key, $val, $flags, $expire) = @_; + my $extra_header = pack "NN", $flags, $expire; + my $cas = 0; + return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas); } -sub getMulti { - my $self = shift; - my @keys = @_; - - for (my $i = 0; $i < @keys; $i++) { - $self->_sendCmd(::CMD_GETQ, $keys[$i], '', $i); - } - - my $terminal = @keys + 10; - $self->_sendCmd(::CMD_NOOP, '', '', $terminal); - - my %return; - - while (1) { - my ($opaque, $data) = $self->_handleSingleResponse; - last if $opaque == $terminal; - - $return{$keys[$opaque]} = [$self->__parseGet($data)]; - } - return %return if wantarray; - return \%return; +sub set { + my $self = shift; + my ($key, $val, $flags, $expire, $cas) = @_; + my $extra_header = pack "NN", $flags, $expire; + return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas); } -sub noop { - my $self = shift; - return $self->_doCmd(::CMD_NOOP, '', ''); +sub replace { + my $self = shift; + my ($key, $val, $flags, $expire) = @_; + my $extra_header = pack "NN", $flags, $expire; + my $cas = 0; + return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas); } sub delete { - my $self = shift; - my ($key, $when) = @_; - $when = 0 unless defined $when; + my $self = shift; + my ($key) = @_; + return $self->_do_command(::CMD_DELETE, $key, ''); +} - return $self->_doCmd(::CMD_DELETE, $key, '', pack(::DEL_PKT_FMT, $when)); +sub incr { + my $self = shift; + my ($key, $amt, $init, $exp) = @_; + $amt = 1 unless defined $amt; + $init = 0 unless defined $init; + $exp = 0 unless defined $exp; + + return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp); } -sub version { - my $self = shift; - return $self->_doCmd(::CMD_VERSION, '', ''); +sub decr { + my $self = shift; + my ($key, $amt, $init, $exp) = @_; + $amt = 1 unless defined $amt; + $init = 0 unless defined $init; + $exp = 0 unless defined $exp; + + return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp); } -sub flush { - my $self = shift; - return $self->_doCmd(::CMD_FLUSH, '', ''); +sub noop { + my $self = shift; + return $self->_do_command(::CMD_NOOP, '', ''); } + package MC::Error; use strict; @@ -438,31 +395,27 @@ use constant ERR_NOT_FOUND => 0x1; use constant ERR_EXISTS => 0x2; use overload '""' => sub { - my $self = shift; - - return "Memcache Error ($self->[0]): $self->[1]"; + my $self = shift; + return "Memcache Error ($self->[0]): $self->[1]"; }; sub new { - my $class = shift; - my $error = [@_]; - - my $self = bless $error, (ref $class || $class); + my $class = shift; + my $error = [@_]; + my $self = bless $error, (ref $class || $class); - return $self; + return $self; } sub not_found { - my $self = shift; - - return $self->[0] == ERR_NOT_FOUND; + my $self = shift; + return $self->[0] == ERR_NOT_FOUND; } sub exists { - my $self = shift; - - return $self->[0] == ERR_EXISTS; + my $self = shift; + return $self->[0] == ERR_EXISTS; } # vim: filetype=perl -=cut + t/binary.t cb8145061d7abe40bfafd4abd4661d31522ed670 Toru Maesaka dev@torum.net http://github.com/tmaesaka/memcached/commit/67b4da9eb855ebe7695a197320232b8d25692f84 67b4da9eb855ebe7695a197320232b8d25692f84 2008-08-14T23:57:09-07:00 2008-08-14T23:57:09-07:00 Binary protocol test now complies with the latest specification. f17d7afb763013877ae170d5bf29920e9361682d Toru Maesaka dev@torum.net