xref: /memcached-1.4.29/t/binary.t (revision f5e4d26d) 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5use Test::More 'no_plan';
6use FindBin qw($Bin);
7use lib "$Bin/lib";
8use MemcachedTest;
9
10my $server = new_memcached();
11
12ok($server, "started the server");
13
14# Based almost 100% off testClient.py which is Copyright (c) 2007  Dustin Sallings <[email protected]>
15
16# Command constants
17use constant CMD_GET     => 0;
18use constant CMD_SET     => 1;
19use constant CMD_ADD     => 2;
20use constant CMD_REPLACE => 3;
21use constant CMD_DELETE  => 4;
22use constant CMD_INCR    => 5;
23use constant CMD_DECR    => 6;
24use constant CMD_QUIT    => 7;
25use constant CMD_FLUSH   => 8;
26use constant CMD_GETQ    => 9;
27use constant CMD_NOOP    => 10;
28use constant CMD_VERSION => 11;
29
30# CAS, Flags, expiration
31use constant SET_PKT_FMT => "NNNN";
32
33# Flags, expiration, id
34use constant CAS_PKT_FMT => "NNNN";
35
36# How long until the deletion takes effect.
37use constant DEL_PKT_FMT => "N";
38
39# amount, initial value, expiration
40use constant INCRDECR_PKT_FMT => "NNNNN";
41
42use constant REQ_MAGIC_BYTE => 0x80;
43use constant RES_MAGIC_BYTE => 0x81;
44
45use constant PKT_FMT => "CCnCxxxNN";
46
47#min recv packet size
48use constant MIN_RECV_PACKET => length(pack(PKT_FMT));
49
50my $mc = MC::Client->new;
51my $check = sub {
52	my ($key, $orig_flags, $orig_value) = @_;
53	my ($flags, $value) = $mc->get($key);
54	is($flags, $orig_flags, "Flags is set properly");
55	is($value, $orig_value, "Value is set properly");
56};
57
58my $set = sub {
59	my ($key, $exp, $orig_flags, $orig_value) = @_;
60	$mc->set($key, $exp, $orig_flags, $orig_value);
61	$check->($key, $orig_flags, $orig_value);
62};
63
64my $empty = sub {
65	my $key = shift;
66	my $rv =()= eval { $mc->get($key) };
67	is($rv, 0, "Didn't get a result from get");
68	ok($@->not_found, "We got a not found error when we expected one");
69};
70
71my $delete = sub {
72	my ($key, $when) = @_;
73	$mc->delete($key, $when);
74	$empty->($key);
75};
76
77diag "Flushing...";
78$mc->flush;
79
80{
81	diag "Test Version";
82	my $v = $mc->version;
83	ok(defined $v && length($v), "Proper version: $v");
84}
85
86diag "Noop";
87$mc->noop;
88
89diag "Simple set/get";
90$set->('x', 5, 19, "somevalue");
91
92diag "Delete";
93$delete->('x');
94
95diag "Flush";
96$set->('x', 5, 19, "somevaluex");
97$set->('y', 5, 17, "somevaluey");
98$mc->flush;
99$empty->('x');
100$empty->('y');
101
102{
103	diag "Reservation delete";
104	$set->('y', 5, 19, "someothervalue");
105	$delete->('y', 1);
106	my $rv =()= eval { $mc->add('y', 5, 19, "yetanothervalue") };
107	is($rv, 0, "Add didn't return anything");
108	ok($@->exists, "We got an exists error like we expected");
109	sleep 2;
110	$mc->add('y', 5, 19, "wibblevalue");
111}
112
113{
114	diag "Add";
115	$empty->('i');
116        $mc->add('i', 5, 19, "ex");
117        $check->('i', 19, "ex");
118
119	my $rv =()= eval { $mc->add('i', 5, 19, "ex2") };
120	is($rv, 0, "Add didn't return anything");
121	ok($@->exists, "Expected exists error received");
122
123	$check->('i', 19, "ex");
124}
125
126{
127	diag "Replace";
128	$empty->('j');
129
130	my $rv =()= eval { $mc->replace('j', 5, 19, "ex") };
131	is($rv, 0, "Replace didn't return anything");
132	ok($@->not_found, "Expected not_found error received");
133
134	$empty->('j');
135
136	$mc->add('j', 5, 14, "ex2");
137	$check->('j', 14, "ex2");
138
139	$mc->replace('j', 5, 24, "ex3");
140	$check->('j', 24, "ex3");
141}
142
143{
144	diag "MultiGet";
145	$mc->add('xx', 5, 1, "ex");
146	$mc->add('wye', 5, 2, "why");
147	my $rv = $mc->getMulti(qw(xx wye zed));
148
149    # CAS is returned with all gets.
150    $rv->{xx}->[2]  = 0;
151    $rv->{wye}->[2] = 0;
152	is_deeply($rv->{xx}, [1, 'ex', 0], "X is correct");
153	is_deeply($rv->{wye}, [2, 'why', 0], "Y is correct");
154	is(keys(%$rv), 2, "Got only two answers like we expect");
155}
156
157diag "Test increment";
158$mc->flush;
159is($mc->incr("x"), 0, "First incr call is zero");
160is($mc->incr("x"), 1, "Second incr call is one");
161is($mc->incr("x", 211), 212, "Adding 211 gives you 212");
162is($mc->incr("x", 2**33), 8589934804, "Blast the 32bit border");
163
164diag "Test decrement";
165$mc->flush;
166is($mc->incr("x", undef, 5), 5, "Initial value");
167is($mc->decr("x"), 4, "Decrease by one");
168is($mc->decr("x", 211), 0, "Floor is zero");
169
170{
171	diag "CAS";
172	$mc->flush;
173
174	{
175		my $rv =()= eval { $mc->set("x", 5, 19, "bad value", 0x7FFFFFFFFF) };
176		is($rv, 0, "Empty return on expected failure");
177		ok($@->not_found, "Error was 'not found' as expected");
178	}
179
180	$mc->add("x", 5, 19, "original value");
181
182	my ($flags, $val, $i) = $mc->get("x");
183	is($val, "original value", "->gets returned proper value");
184
185    {
186		my $rv =()= eval { $mc->set("x", 5, 19, "broken value", $i+1) };
187		is($rv, 0, "Empty return on expected failure (1)");
188		ok($@->exists, "Expected error state of 'exists' (1)");
189	}
190
191	$mc->set("x", 5, 19, "new value", $i);
192
193	my ($newflags, $newval, $newi) = $mc->get("x");
194	is($newval, "new value", "CAS properly overwrote value");
195
196	{
197		my $rv =()= eval { $mc->set("x", 5, 19, "replay value", $i) };
198		is($rv, 0, "Empty return on expected failure (2)");
199		ok($@->exists, "Expected error state of 'exists' (2)");
200	}
201
202	(undef, my $newval2) = $mc->get("x");
203	is($newval2, "new value", "CAS replay didn't overwrite value");
204}
205
206$mc->flush;
207$mc->close;
208
209
210package MC::Client;
211
212use strict;
213use warnings;
214
215use fields qw(socket);
216
217use IO::Socket::INET;
218
219sub new {
220	my $self = shift;
221
222    my $sock = $server->sock;
223
224	$self = fields::new($self);
225
226	$self->{socket} = $sock;
227
228	return $self;
229}
230
231sub close {
232	my $self = shift;
233	return $self->{socket}->close(@_);
234}
235
236sub _sendCmd {
237	my $self = shift;
238	die "Not enough args to _sendCmd" unless @_ >= 4;
239	my ($cmd, $key, $val, $opaque, $extraHeader) = @_;
240
241	$extraHeader = '' unless defined $extraHeader;
242
243	my $keylen = length($key);
244	my $vallen = length($val);
245	my $extralen = length($extraHeader);
246
247	my $msg = pack(::PKT_FMT, ::REQ_MAGIC_BYTE, $cmd, $keylen, $extralen,
248                    $keylen + $vallen + $extralen, $opaque);
249	return $self->{socket}->send($msg . $extraHeader . $key . $val);
250}
251
252sub _handleSingleResponse {
253	my $self = shift;
254	my $myopaque = shift;
255
256	$self->{socket}->recv(my $response, ::MIN_RECV_PACKET);
257
258	Test::More::is(length($response), ::MIN_RECV_PACKET, "Expected read length");
259
260	my ($magic, $cmd, $errcode, $extralen, $remaining,
261        $opaque) = unpack(::PKT_FMT, $response);
262
263	Test::More::is($magic, ::RES_MAGIC_BYTE, "Got proper magic");
264
265	return ($opaque, "")
266		if $remaining == 0;
267
268	$self->{socket}->recv(my $rv, $remaining);
269
270	if (defined $myopaque) {
271		Test::More::is($opaque, $myopaque, "Expected opaque");
272	} else {
273		Test::More::pass("Implicit pass since myopaque is undefined");
274	}
275
276	if ($errcode) {
277		die MC::Error->new($errcode, $rv);
278	}
279
280	return ($opaque, $rv);
281}
282
283sub _doCmd {
284	my $self = shift;
285	die unless @_ >= 3;
286	my ($cmd, $key, $val, $extraHeader) = @_;
287
288	$extraHeader = '' unless defined $extraHeader;
289
290	my $opaque = int(rand(2**32));
291
292	$self->_sendCmd($cmd, $key, $val, $opaque, $extraHeader);
293	(undef, my $rv) = $self->_handleSingleResponse($opaque);
294	return $rv;
295}
296
297sub __parseGet {
298	my $self = shift;
299	my $rv = shift; # currently contains 4 bytes of 'flag' followed by value
300	my $header = substr $rv, 0, 12, '';
301	my ($ident_hi, $ident_lo, $flags) = unpack "NNN", $header;
302	my $ident = ($ident_hi * 2 ** 32) + $ident_lo;
303
304	return $flags, $rv, $ident;
305}
306
307sub get {
308	my $self = shift;
309	my $key = shift;
310	my $parts = $self->_doCmd(::CMD_GET, $key, '');
311	return $self->__parseGet($parts);
312}
313
314sub _mutate {
315	my $self = shift;
316	my ($cmd, $key, $exp, $flags, $val, $ident) = @_;
317
318    my $ident_hi = 0;
319    my $ident_lo = 0;
320    if ($ident) {
321        $ident_hi = int($ident / 2 ** 32);
322        $ident_lo = int($ident % 2 ** 32);
323    }
324
325	return $self->_doCmd($cmd, $key, $val, pack(::SET_PKT_FMT, $ident_hi, $ident_lo, $flags, $exp));
326}
327
328sub set {
329	my $self = shift;
330	my ($key, $exp, $flags, $val, $ident) = @_;
331
332	return $self->_mutate(::CMD_SET, $key, $exp, $flags, $val, $ident);
333}
334
335sub __incrdecr {
336	my $self = shift;
337	my ($cmd, $key, $amt, $init, $exp) = @_;
338
339	my $amt_hi = int($amt / 2 ** 32);
340	my $amt_lo = int($amt % 2 ** 32);
341
342	my $init_hi = int($init / 2 ** 32);
343	my $init_lo = int($init % 2 ** 32);
344
345	my $data = $self->_doCmd($cmd, $key, '', pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi, $init_lo, $exp));
346	my $header = substr $data, 0, 12, '';
347	my ($resp_hi, $resp_lo) = unpack "NN", $header;
348	my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
349    return $resp;
350}
351
352sub incr {
353	my $self = shift;
354	my ($key, $amt, $init, $exp) = @_;
355	$amt = 1 unless defined $amt;
356	$init = 0 unless defined $init;
357	$exp = 0 unless defined $exp;
358
359	return $self->__incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
360}
361
362sub decr {
363	my $self = shift;
364	my ($key, $amt, $init, $exp) = @_;
365	$amt = 1 unless defined $amt;
366	$init = 0 unless defined $init;
367	$exp = 0 unless defined $exp;
368
369	return $self->__incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
370}
371
372sub add {
373	my $self = shift;
374	my ($key, $exp, $flags, $val) = @_;
375	return $self->_mutate(::CMD_ADD, $key, $exp, $flags, $val);
376}
377sub replace {
378	my $self = shift;
379	my ($key, $exp, $flags, $val) = @_;
380	return $self->_mutate(::CMD_REPLACE, $key, $exp, $flags, $val);
381}
382
383sub getMulti {
384	my $self = shift;
385	my @keys = @_;
386
387	for (my $i = 0; $i < @keys; $i++) {
388		$self->_sendCmd(::CMD_GETQ, $keys[$i], '', $i);
389	}
390
391	my $terminal = @keys + 10;
392	$self->_sendCmd(::CMD_NOOP, '', '', $terminal);
393
394	my %return;
395
396	while (1) {
397		my ($opaque, $data) = $self->_handleSingleResponse;
398		last if $opaque == $terminal;
399
400		$return{$keys[$opaque]} = [$self->__parseGet($data)];
401	}
402	return %return if wantarray;
403	return \%return;
404}
405
406sub noop {
407	my $self = shift;
408	return $self->_doCmd(::CMD_NOOP, '', '');
409}
410
411sub delete {
412	my $self = shift;
413	my ($key, $when) = @_;
414	$when = 0 unless defined $when;
415
416	return $self->_doCmd(::CMD_DELETE, $key, '', pack(::DEL_PKT_FMT, $when));
417}
418
419sub version {
420	my $self = shift;
421	return $self->_doCmd(::CMD_VERSION, '', '');
422}
423
424sub flush {
425	my $self = shift;
426	return $self->_doCmd(::CMD_FLUSH, '', '');
427}
428
429package MC::Error;
430
431use strict;
432use warnings;
433
434use constant ERR_UNKNOWN_CMD => 0x81;
435use constant ERR_NOT_FOUND   => 0x1;
436use constant ERR_EXISTS      => 0x2;
437
438use overload '""' => sub {
439	my $self = shift;
440
441	return "Memcache Error ($self->[0]): $self->[1]";
442};
443
444sub new {
445	my $class = shift;
446	my $error = [@_];
447
448	my $self = bless $error, (ref $class || $class);
449
450	return $self;
451}
452
453sub not_found {
454	my $self = shift;
455
456	return $self->[0] == ERR_NOT_FOUND;
457}
458
459sub exists {
460	my $self = shift;
461
462	return $self->[0] == ERR_EXISTS;
463}
464
465# vim: filetype=perl
466