xref: /memcached-1.4.29/t/binary.t (revision 0d560476) 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5use Test::More tests => 376;
6use FindBin qw($Bin);
7use lib "$Bin/lib";
8use MemcachedTest;
9
10my $server = new_memcached();
11ok($server, "started the server");
12
13# Based almost 100% off testClient.py which is:
14# Copyright (c) 2007  Dustin Sallings <[email protected]>
15
16# Command constants
17use constant CMD_GET        => 0x00;
18use constant CMD_SET        => 0x01;
19use constant CMD_ADD        => 0x02;
20use constant CMD_REPLACE    => 0x03;
21use constant CMD_DELETE     => 0x04;
22use constant CMD_INCR       => 0x05;
23use constant CMD_DECR       => 0x06;
24use constant CMD_QUIT       => 0x07;
25use constant CMD_FLUSH      => 0x08;
26use constant CMD_GETQ       => 0x09;
27use constant CMD_NOOP       => 0x0A;
28use constant CMD_VERSION    => 0x0B;
29use constant CMD_GETK       => 0x0C;
30use constant CMD_GETKQ      => 0x0D;
31use constant CMD_APPEND     => 0x0E;
32use constant CMD_PREPEND    => 0x0F;
33use constant CMD_STAT       => 0x10;
34use constant CMD_SETQ       => 0x11;
35use constant CMD_ADDQ       => 0x12;
36use constant CMD_REPLACEQ   => 0x13;
37use constant CMD_DELETEQ    => 0x14;
38use constant CMD_INCREMENTQ => 0x15;
39use constant CMD_DECREMENTQ => 0x16;
40use constant CMD_QUITQ      => 0x17;
41use constant CMD_FLUSHQ     => 0x18;
42use constant CMD_APPENDQ    => 0x19;
43use constant CMD_PREPENDQ   => 0x1A;
44
45# REQ and RES formats are divided even though they currently share
46# the same format, since they _could_ differ in the future.
47use constant REQ_PKT_FMT      => "CCnCCnNNNN";
48use constant RES_PKT_FMT      => "CCnCCnNNNN";
49use constant INCRDECR_PKT_FMT => "NNNNN";
50use constant MIN_RECV_BYTES   => length(pack(RES_PKT_FMT));
51use constant REQ_MAGIC        => 0x80;
52use constant RES_MAGIC        => 0x81;
53
54my $mc = MC::Client->new;
55
56my $check = sub {
57    my ($key, $orig_flags, $orig_val) = @_;
58    my ($flags, $val, $cas) = $mc->get($key);
59    is($flags, $orig_flags, "Flags is set properly");
60    ok($val eq $orig_val || $val == $orig_val, $val . " = " . $orig_val);
61};
62
63my $set = sub {
64    my ($key, $exp, $orig_flags, $orig_value) = @_;
65    $mc->set($key, $orig_value, $orig_flags, $exp);
66    $check->($key, $orig_flags, $orig_value);
67};
68
69my $empty = sub {
70    my $key = shift;
71    my $rv =()= eval { $mc->get($key) };
72    is($rv, 0, "Didn't get a result from get");
73    ok($@->not_found, "We got a not found error when we expected one");
74};
75
76my $delete = sub {
77    my ($key, $when) = @_;
78    $mc->delete($key, $when);
79    $empty->($key);
80};
81
82# diag "Test Version";
83my $v = $mc->version;
84ok(defined $v && length($v), "Proper version: $v");
85
86# diag "Flushing...";
87$mc->flush;
88
89# diag "Noop";
90$mc->noop;
91
92# diag "Simple set/get";
93$set->('x', 5, 19, "somevalue");
94
95# diag "Delete";
96$delete->('x');
97
98# diag "Flush";
99$set->('x', 5, 19, "somevaluex");
100$set->('y', 5, 17, "somevaluey");
101$mc->flush;
102$empty->('x');
103$empty->('y');
104
105{
106    # diag "Add";
107    $empty->('i');
108    $mc->add('i', 'ex', 5, 10);
109    $check->('i', 5, "ex");
110
111    my $rv =()= eval { $mc->add('i', "ex2", 10, 5) };
112    is($rv, 0, "Add didn't return anything");
113    ok($@->exists, "Expected exists error received");
114    $check->('i', 5, "ex");
115}
116
117{
118    # diag "Too big.";
119    $empty->('toobig');
120    $mc->set('toobig', 'not too big', 10, 10);
121    eval {
122        my $bigval = ("x" x (1024*1024)) . "x";
123        $mc->set('toobig', $bigval, 10, 10);
124    };
125    ok($@->too_big, "Was too big");
126    $empty->('toobig');
127}
128
129{
130    # diag "Replace";
131    $empty->('j');
132
133    my $rv =()= eval { $mc->replace('j', "ex", 19, 5) };
134    is($rv, 0, "Replace didn't return anything");
135    ok($@->not_found, "Expected not_found error received");
136    $empty->('j');
137    $mc->add('j', "ex2", 14, 5);
138    $check->('j', 14, "ex2");
139    $mc->replace('j', "ex3", 24, 5);
140    $check->('j', 24, "ex3");
141}
142
143{
144    # diag "MultiGet";
145    $mc->add('xx', "ex", 1, 5);
146    $mc->add('wye', "why", 2, 5);
147    my $rv = $mc->get_multi(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
157# diag "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
164# diag "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", "bad value", 19, 5, 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", "original value", 5, 19);
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", "broken value", 19, 5, $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", "new value", 19, 5, $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", "replay value", 19, 5,  $i) };
198        is($rv, 0, "Empty return on expected failure (2)");
199        ok($@->exists, "Expected error state of 'exists' (2)");
200    }
201}
202
203# diag "Silent set.";
204$mc->silent_mutation(::CMD_SETQ, 'silentset', 'silentsetval');
205
206# diag "Silent add.";
207$mc->silent_mutation(::CMD_ADDQ, 'silentadd', 'silentaddval');
208
209# diag "Silent replace.";
210{
211    my $key = "silentreplace";
212    my $extra = pack "NN", 829, 0;
213    $empty->($key);
214    # $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
215    # $empty->($key);
216
217    $mc->add($key, "xval", 831, 0);
218    $check->($key, 831, 'xval');
219
220    $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
221    $check->($key, 829, 'somevalue');
222}
223
224# diag "Silent delete";
225{
226    my $key = "silentdelete";
227    $empty->($key);
228    $mc->set($key, "some val", 19, 0);
229    $mc->send_silent(::CMD_DELETEQ, $key, '', 772);
230    $empty->($key);
231}
232
233# diag "Silent increment";
234{
235    my $key = "silentincr";
236    my $opaque = 98428747;
237    $empty->($key);
238    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 0, 0, 0);
239    is($mc->incr($key, 0), 0, "First call is 0");
240
241    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 8, 0, 0);
242    is($mc->incr($key, 0), 8);
243}
244
245# diag "Silent decrement";
246{
247    my $key = "silentdecr";
248    my $opaque = 98428147;
249    $empty->($key);
250    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 0, 185, 0);
251    is($mc->incr($key, 0), 185);
252
253    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 8, 0, 0);
254    is($mc->incr($key, 0), 177);
255}
256
257# diag "Silent flush";
258{
259    $set->('x', 5, 19, "somevaluex");
260    $set->('y', 5, 17, "somevaluey");
261    $mc->send_silent(::CMD_FLUSHQ, '', '', 2775256);
262    $empty->('x');
263    $empty->('y');
264}
265
266# diag "Append";
267{
268    my $key = "appendkey";
269    my $value = "some value";
270    $set->($key, 8, 19, $value);
271    $mc->_append_prepend(::CMD_APPEND, $key, " more");
272    $check->($key, 19, $value . " more");
273}
274
275# diag "Prepend";
276{
277    my $key = "prependkey";
278    my $value = "some value";
279    $set->($key, 8, 19, $value);
280    $mc->_append_prepend(::CMD_PREPEND, $key, "prefixed ");
281    $check->($key, 19, "prefixed " . $value);
282}
283
284# diag "Silent append";
285{
286    my $key = "appendqkey";
287    my $value = "some value";
288    $set->($key, 8, 19, $value);
289    $mc->send_silent(::CMD_APPENDQ, $key, " more", 7284492);
290    $check->($key, 19, $value . " more");
291}
292
293# diag "Silent prepend";
294{
295    my $key = "prependqkey";
296    my $value = "some value";
297    $set->($key, 8, 19, $value);
298    $mc->send_silent(::CMD_PREPENDQ, $key, "prefixed ", 7284492);
299    $check->($key, 19, "prefixed " . $value);
300}
301
302package MC::Client;
303
304use strict;
305use warnings;
306use fields qw(socket);
307use IO::Socket::INET;
308
309sub new {
310    my $self = shift;
311    my $sock = $server->sock;
312    $self = fields::new($self);
313    $self->{socket} = $sock;
314    return $self;
315}
316
317sub send_command {
318    my $self = shift;
319    die "Not enough args to send_command" unless @_ >= 4;
320    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
321
322    $extra_header = '' unless defined $extra_header;
323    my $keylen    = length($key);
324    my $vallen    = length($val);
325    my $extralen  = length($extra_header);
326    my $datatype  = 0;  # field for future use
327    my $reserved  = 0;  # field for future use
328    my $totallen  = $keylen + $vallen + $extralen;
329    my $ident_hi  = 0;
330    my $ident_lo  = 0;
331
332    if ($cas) {
333        $ident_hi = int($cas / 2 ** 32);
334        $ident_lo = int($cas % 2 ** 32);
335    }
336
337    my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,
338                   $datatype, $reserved, $totallen, $opaque, $ident_hi,
339                   $ident_lo);
340
341    return $self->{socket}->send($msg . $extra_header . $key . $val);
342}
343
344# Send a silent command and ensure it doesn't respond.
345sub send_silent {
346    my $self = shift;
347    die "Not enough args to send_silent" unless @_ >= 4;
348    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
349
350    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
351    $self->send_command(::CMD_NOOP, '', '', $opaque + 1);
352
353    my ($ropaque, $data) = $self->_handle_single_response;
354    Test::More::is($ropaque, $opaque + 1);
355}
356
357sub silent_mutation {
358    my $self = shift;
359    my ($cmd, $key, $value) = @_;
360
361    $empty->($key);
362    my $extra = pack "NN", 82, 0;
363    $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
364    $check->($key, 82, $value);
365}
366
367sub _handle_single_response {
368    my $self = shift;
369    my $myopaque = shift;
370
371    $self->{socket}->recv(my $response, ::MIN_RECV_BYTES);
372    Test::More::is(length($response), ::MIN_RECV_BYTES, "Expected read length");
373
374    my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
375        $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $response);
376    Test::More::is($magic, ::RES_MAGIC, "Got proper response magic");
377
378    return ($opaque, '') if($remaining == 0);
379
380    # fetch the value
381    $self->{socket}->recv(my $rv, $remaining);
382
383    if (defined $myopaque) {
384        Test::More::is($opaque, $myopaque, "Expected opaque");
385    } else {
386        Test::More::pass("Implicit pass since myopaque is undefined");
387    }
388
389    my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
390
391    if ($status) {
392        die MC::Error->new($status, $rv);
393    }
394
395    return ($opaque, $rv, $cas);
396}
397
398sub _do_command {
399    my $self = shift;
400    die unless @_ >= 3;
401    my ($cmd, $key, $val, $extra_header, $cas) = @_;
402
403    $extra_header = '' unless defined $extra_header;
404    my $opaque = int(rand(2**32));
405    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
406    my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);
407    return ($rv, $rcas);
408}
409
410sub _incrdecr_header {
411    my $self = shift;
412    my ($amt, $init, $exp) = @_;
413
414    my $amt_hi = int($amt / 2 ** 32);
415    my $amt_lo = int($amt % 2 ** 32);
416
417    my $init_hi = int($init / 2 ** 32);
418    my $init_lo = int($init % 2 ** 32);
419
420    my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,
421                            $init_lo, $exp);
422
423    return $extra_header;
424}
425
426sub _incrdecr {
427    my $self = shift;
428    my ($cmd, $key, $amt, $init, $exp) = @_;
429
430    my ($data, undef) = $self->_do_command($cmd, $key, '',
431                                           $self->_incrdecr_header($amt, $init, $exp));
432
433    my $header = substr $data, 0, 8, '';
434    my ($resp_hi, $resp_lo) = unpack "NN", $header;
435    my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
436
437    return $resp;
438}
439
440sub silent_incrdecr {
441    my $self = shift;
442    my ($cmd, $key, $amt, $init, $exp) = @_;
443    my $opaque = 8275753;
444
445    $mc->send_silent($cmd, $key, '', $opaque,
446                     $mc->_incrdecr_header($amt, $init, $exp));
447}
448
449sub get {
450    my $self = shift;
451    my $key  = shift;
452    my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');
453
454    my $header = substr $rv, 0, 4, '';
455    my $flags  = unpack("N", $header);
456
457    return ($flags, $rv, $cas);
458}
459
460sub get_multi {
461    my $self = shift;
462    my @keys = @_;
463
464    for (my $i = 0; $i < @keys; $i++) {
465        $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);
466    }
467
468    my $terminal = @keys + 10;
469    $self->send_command(::CMD_NOOP, '', '', $terminal);
470
471    my %return;
472    while (1) {
473        my ($opaque, $data) = $self->_handle_single_response;
474        last if $opaque == $terminal;
475
476        my $header = substr $data, 0, 4, '';
477        my $flags  = unpack("N", $header);
478
479        $return{$keys[$opaque]} = [$flags, $data];
480    }
481
482    return %return if wantarray;
483    return \%return;
484}
485
486sub version {
487    my $self = shift;
488    return $self->_do_command(::CMD_VERSION, '', '');
489}
490
491sub flush {
492    my $self = shift;
493    return $self->_do_command(::CMD_FLUSH, '', '');
494}
495
496sub add {
497    my $self = shift;
498    my ($key, $val, $flags, $expire) = @_;
499    my $extra_header = pack "NN", $flags, $expire;
500    my $cas = 0;
501    return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);
502}
503
504sub set {
505    my $self = shift;
506    my ($key, $val, $flags, $expire, $cas) = @_;
507    my $extra_header = pack "NN", $flags, $expire;
508    return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);
509}
510
511sub _append_prepend {
512    my $self = shift;
513    my ($cmd, $key, $val, $cas) = @_;
514    return $self->_do_command($cmd, $key, $val, '', $cas);
515}
516
517sub replace {
518    my $self = shift;
519    my ($key, $val, $flags, $expire) = @_;
520    my $extra_header = pack "NN", $flags, $expire;
521    my $cas = 0;
522    return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);
523}
524
525sub delete {
526    my $self = shift;
527    my ($key) = @_;
528    return $self->_do_command(::CMD_DELETE, $key, '');
529}
530
531sub incr {
532    my $self = shift;
533    my ($key, $amt, $init, $exp) = @_;
534    $amt = 1 unless defined $amt;
535    $init = 0 unless defined $init;
536    $exp = 0 unless defined $exp;
537
538    return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
539}
540
541sub decr {
542    my $self = shift;
543    my ($key, $amt, $init, $exp) = @_;
544    $amt = 1 unless defined $amt;
545    $init = 0 unless defined $init;
546    $exp = 0 unless defined $exp;
547
548    return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
549}
550
551sub noop {
552    my $self = shift;
553    return $self->_do_command(::CMD_NOOP, '', '');
554}
555
556
557package MC::Error;
558
559use strict;
560use warnings;
561
562use constant ERR_UNKNOWN_CMD => 0x81;
563use constant ERR_NOT_FOUND   => 0x1;
564use constant ERR_EXISTS      => 0x2;
565use constant ERR_TOO_BIG     => 0x3;
566
567use overload '""' => sub {
568    my $self = shift;
569    return "Memcache Error ($self->[0]): $self->[1]";
570};
571
572sub new {
573    my $class = shift;
574    my $error = [@_];
575    my $self = bless $error, (ref $class || $class);
576
577    return $self;
578}
579
580sub not_found {
581    my $self = shift;
582    return $self->[0] == ERR_NOT_FOUND;
583}
584
585sub exists {
586    my $self = shift;
587    return $self->[0] == ERR_EXISTS;
588}
589
590sub too_big {
591    my $self = shift;
592    return $self->[0] == ERR_TOO_BIG;
593}
594
595# vim: filetype=perl
596
597