xref: /memcached-1.4.29/t/binary.t (revision fe2629fd) 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5use Test::More tests => 3615;
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;
44use constant CMD_TOUCH      => 0x1C;
45use constant CMD_GAT        => 0x1D;
46use constant CMD_GATQ       => 0x1E;
47use constant CMD_GATK       => 0x23;
48use constant CMD_GATKQ      => 0x24;
49
50# REQ and RES formats are divided even though they currently share
51# the same format, since they _could_ differ in the future.
52use constant REQ_PKT_FMT      => "CCnCCnNNNN";
53use constant RES_PKT_FMT      => "CCnCCnNNNN";
54use constant INCRDECR_PKT_FMT => "NNNNN";
55use constant MIN_RECV_BYTES   => length(pack(RES_PKT_FMT));
56use constant REQ_MAGIC        => 0x80;
57use constant RES_MAGIC        => 0x81;
58
59my $mc = MC::Client->new;
60
61# Let's turn on detail stats for all this stuff
62
63$mc->stats('detail on');
64
65my $check = sub {
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);
70};
71
72my $set = sub {
73    my ($key, $exp, $orig_flags, $orig_value) = @_;
74    $mc->set($key, $orig_value, $orig_flags, $exp);
75    $check->($key, $orig_flags, $orig_value);
76};
77
78my $empty = sub {
79    my $key = shift;
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");
83};
84
85my $delete = sub {
86    my ($key, $when) = @_;
87    $mc->delete($key, $when);
88    $empty->($key);
89};
90
91# diag "Test Version";
92my $v = $mc->version;
93ok(defined $v && length($v), "Proper version: $v");
94
95# Bug 71
96{
97    my %stats1 = $mc->stats('');
98    $mc->flush;
99    my %stats2 = $mc->stats('');
100
101    is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
102       "Stats not updated on a binary flush");
103}
104
105# diag "Flushing...";
106$mc->flush;
107
108# diag "Noop";
109$mc->noop;
110
111# diag "Simple set/get";
112$set->('x', 5, 19, "somevalue");
113
114# diag "Delete";
115$delete->('x');
116
117# diag "Flush";
118$set->('x', 5, 19, "somevaluex");
119$set->('y', 5, 17, "somevaluey");
120$mc->flush;
121$empty->('x');
122$empty->('y');
123
124{
125    # diag "Add";
126    $empty->('i');
127    $mc->add('i', 'ex', 5, 10);
128    $check->('i', 5, "ex");
129
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");
134}
135
136{
137    # diag "Too big.";
138    $empty->('toobig');
139    $mc->set('toobig', 'not too big', 10, 10);
140    eval {
141        my $bigval = ("x" x (1024*1024)) . "x";
142        $mc->set('toobig', $bigval, 10, 10);
143    };
144    ok($@->too_big, "Was too big");
145    $empty->('toobig');
146}
147
148{
149    # diag "Replace";
150    $empty->('j');
151
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");
155    $empty->('j');
156    $mc->add('j', "ex2", 14, 5);
157    $check->('j', 14, "ex2");
158    $mc->replace('j', "ex3", 24, 5);
159    $check->('j', 24, "ex3");
160}
161
162{
163    # diag "MultiGet";
164    $mc->add('xx', "ex", 1, 5);
165    $mc->add('wye', "why", 2, 5);
166    my $rv = $mc->get_multi(qw(xx wye zed));
167
168    # CAS is returned with all gets.
169    $rv->{xx}->[2]  = 0;
170    $rv->{wye}->[2] = 0;
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");
174}
175
176# diag "Test increment";
177$mc->flush;
178is($mc->incr("x"), 0, "First incr call is zero");
179is($mc->incr("x"), 1, "Second incr call is one");
180is($mc->incr("x", 211), 212, "Adding 211 gives you 212");
181is($mc->incr("x", 2**33), 8589934804, "Blast the 32bit border");
182
183# diag "Issue 48 - incrementing plain text.";
184{
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");
189
190    $rv =()= eval { $mc->decr('issue48'); };
191    ok($@ && $@->delta_badval, "Expected invalid value when decrementing text.");
192    $check->('issue48', 0, "text");
193}
194
195# diag "Issue 320 - incr/decr wrong length for initial value";
196{
197    $mc->flush;
198    is($mc->incr("issue320", 1, 1, 0), 1, "incr initial value is 1");
199    my (undef, $rv, undef) = $mc->get("issue320");
200    is(length($rv), 1, "initial value length is 1");
201    is($rv, "1", "initial value is 1");
202}
203
204
205# diag "Test decrement";
206$mc->flush;
207is($mc->incr("x", undef, 5), 5, "Initial value");
208is($mc->decr("x"), 4, "Decrease by one");
209is($mc->decr("x", 211), 0, "Floor is zero");
210
211{
212    # diag "bug220
213    my ($rv, $cas) = $mc->set("bug220", "100", 0, 0);
214    my ($irv, $icas) = $mc->incr_cas("bug220", 999);
215    ok($icas != $cas);
216    is($irv, 1099, "Incr amount failed");
217    my ($flags, $val, $gcas) = $mc->get("bug220");
218    is($gcas, $icas, "CAS didn't match after incr/gets");
219
220    ($irv, $icas) = $mc->incr_cas("bug220", 999);
221    ok($icas != $cas);
222    is($irv, 2098, "Incr amount failed");
223    ($flags, $val, $gcas) = $mc->get("bug220");
224    is($gcas, $icas, "CAS didn't match after incr/gets");
225}
226
227{
228    # diag "bug21";
229    $mc->add("bug21", "9223372036854775807", 0, 0);
230    is($mc->incr("bug21"), 9223372036854775808, "First incr for bug21.");
231    is($mc->incr("bug21"), 9223372036854775809, "Second incr for bug21.");
232    is($mc->decr("bug21"), 9223372036854775808, "Decr for bug21.");
233}
234
235{
236    # diag "CAS";
237    $mc->flush;
238
239    {
240        my $rv =()= eval { $mc->set("x", "bad value", 19, 5, 0x7FFFFFF) };
241        is($rv, 0, "Empty return on expected failure");
242        ok($@->not_found, "Error was 'not found' as expected");
243    }
244
245    my ($r, $rcas) = $mc->add("x", "original value", 5, 19);
246
247    my ($flags, $val, $i) = $mc->get("x");
248    is($val, "original value", "->gets returned proper value");
249    is($rcas, $i, "Add CAS matched.");
250
251    {
252        my $rv =()= eval { $mc->set("x", "broken value", 19, 5, $i+1) };
253        is($rv, 0, "Empty return on expected failure (1)");
254        ok($@->exists, "Expected error state of 'exists' (1)");
255    }
256
257    ($r, $rcas) = $mc->set("x", "new value", 19, 5, $i);
258
259    my ($newflags, $newval, $newi) = $mc->get("x");
260    is($newval, "new value", "CAS properly overwrote value");
261    is($rcas, $newi, "Get CAS matched.");
262
263    {
264        my $rv =()= eval { $mc->set("x", "replay value", 19, 5,  $i) };
265        is($rv, 0, "Empty return on expected failure (2)");
266        ok($@->exists, "Expected error state of 'exists' (2)");
267    }
268}
269
270# diag "Touch commands";
271{
272    $mc->flush;
273    $mc->set("totouch", "toast", 0, 1);
274    my $res = $mc->touch("totouch", 10);
275    sleep 2;
276    $check->("totouch", 0, "toast");
277
278    $mc->set("totouch", "toast2", 0, 1);
279    my ($flags, $val, $i) = $mc->gat("totouch", 10);
280    is($val, "toast2", "GAT returned correct value");
281    sleep 2;
282    $check->("totouch", 0, "toast2");
283
284    # Test miss as well
285    $mc->set("totouch", "toast3", 0, 1);
286    $res = $mc->touch("totouch", 1);
287    sleep 3;
288    $empty->("totouch");
289}
290
291# diag "Silent set.";
292$mc->silent_mutation(::CMD_SETQ, 'silentset', 'silentsetval');
293
294# diag "Silent add.";
295$mc->silent_mutation(::CMD_ADDQ, 'silentadd', 'silentaddval');
296
297# diag "Silent replace.";
298{
299    my $key = "silentreplace";
300    my $extra = pack "NN", 829, 0;
301    $empty->($key);
302    # $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
303    # $empty->($key);
304
305    $mc->add($key, "xval", 831, 0);
306    $check->($key, 831, 'xval');
307
308    $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
309    $check->($key, 829, 'somevalue');
310}
311
312# diag "Silent delete";
313{
314    my $key = "silentdelete";
315    $empty->($key);
316    $mc->set($key, "some val", 19, 0);
317    $mc->send_silent(::CMD_DELETEQ, $key, '', 772);
318    $empty->($key);
319}
320
321# diag "Silent increment";
322{
323    my $key = "silentincr";
324    my $opaque = 98428747;
325    $empty->($key);
326    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 0, 0, 0);
327    is($mc->incr($key, 0), 0, "First call is 0");
328
329    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 8, 0, 0);
330    is($mc->incr($key, 0), 8);
331}
332
333# diag "Silent decrement";
334{
335    my $key = "silentdecr";
336    my $opaque = 98428147;
337    $empty->($key);
338    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 0, 185, 0);
339    is($mc->incr($key, 0), 185);
340
341    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 8, 0, 0);
342    is($mc->incr($key, 0), 177);
343}
344
345# diag "Silent flush";
346{
347    my %stats1 = $mc->stats('');
348
349    $set->('x', 5, 19, "somevaluex");
350    $set->('y', 5, 17, "somevaluey");
351    $mc->send_silent(::CMD_FLUSHQ, '', '', 2775256);
352    $empty->('x');
353    $empty->('y');
354
355    my %stats2 = $mc->stats('');
356    is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
357       "Stats not updated on a binary quiet flush");
358}
359
360# diag "Append";
361{
362    my $key = "appendkey";
363    my $value = "some value";
364    $set->($key, 8, 19, $value);
365    $mc->_append_prepend(::CMD_APPEND, $key, " more");
366    $check->($key, 19, $value . " more");
367}
368
369# diag "Prepend";
370{
371    my $key = "prependkey";
372    my $value = "some value";
373    $set->($key, 8, 19, $value);
374    $mc->_append_prepend(::CMD_PREPEND, $key, "prefixed ");
375    $check->($key, 19, "prefixed " . $value);
376}
377
378# diag "Silent append";
379{
380    my $key = "appendqkey";
381    my $value = "some value";
382    $set->($key, 8, 19, $value);
383    $mc->send_silent(::CMD_APPENDQ, $key, " more", 7284492);
384    $check->($key, 19, $value . " more");
385}
386
387# diag "Silent prepend";
388{
389    my $key = "prependqkey";
390    my $value = "some value";
391    $set->($key, 8, 19, $value);
392    $mc->send_silent(::CMD_PREPENDQ, $key, "prefixed ", 7284492);
393    $check->($key, 19, "prefixed " . $value);
394}
395
396# diag "Leaky binary get test.";
397# # http://code.google.com/p/memcached/issues/detail?id=16
398{
399    # Get a new socket so we can speak text to it.
400    my $sock = $server->new_sock;
401    my $max = 1024 * 1024;
402    my $big = "a big value that's > .5M and < 1M. ";
403    while (length($big) * 2 < $max) {
404        $big = $big . $big;
405    }
406    my $biglen = length($big);
407
408    for(1..100) {
409        my $key = "some_key_$_";
410        # print STDERR "Key is $key\n";
411        # print $sock "set $key 0 0 $vallen\r\n$value\r\n";
412        print $sock "set $key 0 0 $biglen\r\n$big\r\n";
413        is(scalar <$sock>, "STORED\r\n", "stored big");
414        my ($f, $v, $c) = $mc->get($key);
415    }
416}
417
418# diag "Test stats settings."
419{
420    my %stats = $mc->stats('settings');
421
422    is(1024, $stats{'maxconns'});
423    is('NULL', $stats{'domain_socket'});
424    is('on', $stats{'evictions'});
425    is('yes', $stats{'cas_enabled'});
426    is('yes', $stats{'flush_enabled'});
427}
428
429# diag "Test quit commands.";
430{
431    my $s2 = new_memcached();
432    my $mc2 = MC::Client->new($s2);
433    $mc2->send_command(CMD_QUITQ, '', '', 0, '', 0);
434
435    # Five seconds ought to be enough to get hung up on.
436    my $oldalarmt = alarm(5);
437
438    # Verify we can't read anything.
439    my $bytesread = -1;
440    eval {
441        local $SIG{'ALRM'} = sub { die "timeout" };
442        my $data = "";
443        $bytesread = sysread($mc2->{socket}, $data, 24),
444    };
445    is($bytesread, 0, "Read after quit.");
446
447    # Restore signal stuff.
448    alarm($oldalarmt);
449}
450
451# diag "Test protocol boundary overruns";
452{
453    use List::Util qw[min];
454    # Attempting some protocol overruns by toying around with the edge
455    # of the data buffer at a few different sizes.  This assumes the
456    # boundary is at or around 2048 bytes.
457    for (my $i = 1900; $i < 2100; $i++) {
458        my $k = "test_key_$i";
459        my $v = 'x' x $i;
460        # diag "Trying $i $k";
461        my $extra = pack "NN", 82, 0;
462        my $data = $mc->build_command(::CMD_SETQ, $k, $v, 0, $extra, 0);
463        $data .= $mc->build_command(::CMD_SETQ, "alt_$k", "blah", 0, $extra, 0);
464        if (length($data) > 2024) {
465            for (my $j = 2024; $j < min(2096, length($data)); $j++) {
466                $mc->{socket}->send(substr($data, 0, $j));
467                $mc->flush_socket;
468                sleep(0.001);
469                $mc->{socket}->send(substr($data, $j));
470                $mc->flush_socket;
471            }
472        } else {
473            $mc->{socket}->send($data);
474        }
475        $mc->flush_socket;
476        $check->($k, 82, $v);
477        $check->("alt_$k", 82, "blah");
478    }
479}
480
481# Along with the assertion added to the code to verify we're staying
482# within bounds when we do a stats detail dump (detail turned on at
483# the top).
484my %stats = $mc->stats('detail dump');
485
486# This test causes a disconnection.
487{
488    # diag "Key too large.";
489    my $key = "x" x 365;
490    eval {
491        $mc->get($key, 'should die', 10, 10);
492    };
493    ok($@->einval, "Invalid key length");
494}
495
496# ######################################################################
497# Test ends around here.
498# ######################################################################
499
500package MC::Client;
501
502use strict;
503use warnings;
504use fields qw(socket);
505use IO::Socket::INET;
506
507sub new {
508    my $self = shift;
509    my ($s) = @_;
510    $s = $server unless defined $s;
511    my $sock = $s->sock;
512    $self = fields::new($self);
513    $self->{socket} = $sock;
514    return $self;
515}
516
517sub build_command {
518    my $self = shift;
519    die "Not enough args to send_command" unless @_ >= 4;
520    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
521
522    $extra_header = '' unless defined $extra_header;
523    my $keylen    = length($key);
524    my $vallen    = length($val);
525    my $extralen  = length($extra_header);
526    my $datatype  = 0;  # field for future use
527    my $reserved  = 0;  # field for future use
528    my $totallen  = $keylen + $vallen + $extralen;
529    my $ident_hi  = 0;
530    my $ident_lo  = 0;
531
532    if ($cas) {
533        $ident_hi = int($cas / 2 ** 32);
534        $ident_lo = int($cas % 2 ** 32);
535    }
536
537    my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,
538                   $datatype, $reserved, $totallen, $opaque, $ident_hi,
539                   $ident_lo);
540    my $full_msg = $msg . $extra_header . $key . $val;
541    return $full_msg;
542}
543
544sub send_command {
545    my $self = shift;
546    die "Not enough args to send_command" unless @_ >= 4;
547    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
548
549    my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
550
551    my $sent = $self->{socket}->send($full_msg);
552    die("Send failed:  $!") unless $sent;
553    if($sent != length($full_msg)) {
554        die("only sent $sent of " . length($full_msg) . " bytes");
555    }
556}
557
558sub flush_socket {
559    my $self = shift;
560    $self->{socket}->flush;
561}
562
563# Send a silent command and ensure it doesn't respond.
564sub send_silent {
565    my $self = shift;
566    die "Not enough args to send_silent" unless @_ >= 4;
567    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
568
569    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
570    $self->send_command(::CMD_NOOP, '', '', $opaque + 1);
571
572    my ($ropaque, $data) = $self->_handle_single_response;
573    Test::More::is($ropaque, $opaque + 1);
574}
575
576sub silent_mutation {
577    my $self = shift;
578    my ($cmd, $key, $value) = @_;
579
580    $empty->($key);
581    my $extra = pack "NN", 82, 0;
582    $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
583    $check->($key, 82, $value);
584}
585
586sub _handle_single_response {
587    my $self = shift;
588    my $myopaque = shift;
589
590    my $hdr = "";
591    while(::MIN_RECV_BYTES - length($hdr) > 0) {
592        $self->{socket}->recv(my $response, ::MIN_RECV_BYTES - length($hdr));
593        $hdr .= $response;
594    }
595    Test::More::is(length($hdr), ::MIN_RECV_BYTES, "Expected read length");
596
597    my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
598        $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $hdr);
599    Test::More::is($magic, ::RES_MAGIC, "Got proper response magic");
600
601    my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
602
603    return ($opaque, '', $cas, 0) if($remaining == 0);
604
605    # fetch the value
606    my $rv="";
607    while($remaining - length($rv) > 0) {
608        $self->{socket}->recv(my $buf, $remaining - length($rv));
609        $rv .= $buf;
610    }
611    if(length($rv) != $remaining) {
612        my $found = length($rv);
613        die("Expected $remaining bytes, got $found");
614    }
615
616    if (defined $myopaque) {
617        Test::More::is($opaque, $myopaque, "Expected opaque");
618    } else {
619        Test::More::pass("Implicit pass since myopaque is undefined");
620    }
621
622    if ($status) {
623        die MC::Error->new($status, $rv);
624    }
625
626    return ($opaque, $rv, $cas, $keylen);
627}
628
629sub _do_command {
630    my $self = shift;
631    die unless @_ >= 3;
632    my ($cmd, $key, $val, $extra_header, $cas) = @_;
633
634    $extra_header = '' unless defined $extra_header;
635    my $opaque = int(rand(2**32));
636    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
637    my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);
638    return ($rv, $rcas);
639}
640
641sub _incrdecr_header {
642    my $self = shift;
643    my ($amt, $init, $exp) = @_;
644
645    my $amt_hi = int($amt / 2 ** 32);
646    my $amt_lo = int($amt % 2 ** 32);
647
648    my $init_hi = int($init / 2 ** 32);
649    my $init_lo = int($init % 2 ** 32);
650
651    my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,
652                            $init_lo, $exp);
653
654    return $extra_header;
655}
656
657sub _incrdecr_cas {
658    my $self = shift;
659    my ($cmd, $key, $amt, $init, $exp) = @_;
660
661    my ($data, $rcas) = $self->_do_command($cmd, $key, '',
662                                           $self->_incrdecr_header($amt, $init, $exp));
663
664    my $header = substr $data, 0, 8, '';
665    my ($resp_hi, $resp_lo) = unpack "NN", $header;
666    my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
667
668    return $resp, $rcas;
669}
670
671sub _incrdecr {
672    my $self = shift;
673    my ($v, $c) = $self->_incrdecr_cas(@_);
674    return $v
675}
676
677sub silent_incrdecr {
678    my $self = shift;
679    my ($cmd, $key, $amt, $init, $exp) = @_;
680    my $opaque = 8275753;
681
682    $mc->send_silent($cmd, $key, '', $opaque,
683                     $mc->_incrdecr_header($amt, $init, $exp));
684}
685
686sub stats {
687    my $self = shift;
688    my $key  = shift;
689    my $cas = 0;
690    my $opaque = int(rand(2**32));
691    $self->send_command(::CMD_STAT, $key, '', $opaque, '', $cas);
692
693    my %rv = ();
694    my $found_key = '';
695    my $found_val = '';
696    do {
697        my ($op, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
698        if($keylen > 0) {
699            $found_key = substr($data, 0, $keylen);
700            $found_val = substr($data, $keylen);
701            $rv{$found_key} = $found_val;
702        } else {
703            $found_key = '';
704        }
705    } while($found_key ne '');
706    return %rv;
707}
708
709sub get {
710    my $self = shift;
711    my $key  = shift;
712    my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');
713
714    my $header = substr $rv, 0, 4, '';
715    my $flags  = unpack("N", $header);
716
717    return ($flags, $rv, $cas);
718}
719
720sub get_multi {
721    my $self = shift;
722    my @keys = @_;
723
724    for (my $i = 0; $i < @keys; $i++) {
725        $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);
726    }
727
728    my $terminal = @keys + 10;
729    $self->send_command(::CMD_NOOP, '', '', $terminal);
730
731    my %return;
732    while (1) {
733        my ($opaque, $data) = $self->_handle_single_response;
734        last if $opaque == $terminal;
735
736        my $header = substr $data, 0, 4, '';
737        my $flags  = unpack("N", $header);
738
739        $return{$keys[$opaque]} = [$flags, $data];
740    }
741
742    return %return if wantarray;
743    return \%return;
744}
745
746sub touch {
747    my $self = shift;
748    my ($key, $expire) = @_;
749    my $extra_header = pack "N", $expire;
750    my $cas = 0;
751    return $self->_do_command(::CMD_TOUCH, $key, '', $extra_header, $cas);
752}
753
754sub gat {
755    my $self   = shift;
756    my $key    = shift;
757    my $expire = shift;
758    my $extra_header = pack "N", $expire;
759    my ($rv, $cas) = $self->_do_command(::CMD_GAT, $key, '', $extra_header);
760
761    my $header = substr $rv, 0, 4, '';
762    my $flags  = unpack("N", $header);
763
764    return ($flags, $rv, $cas);
765}
766
767sub version {
768    my $self = shift;
769    return $self->_do_command(::CMD_VERSION, '', '');
770}
771
772sub flush {
773    my $self = shift;
774    return $self->_do_command(::CMD_FLUSH, '', '');
775}
776
777sub add {
778    my $self = shift;
779    my ($key, $val, $flags, $expire) = @_;
780    my $extra_header = pack "NN", $flags, $expire;
781    my $cas = 0;
782    return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);
783}
784
785sub set {
786    my $self = shift;
787    my ($key, $val, $flags, $expire, $cas) = @_;
788    my $extra_header = pack "NN", $flags, $expire;
789    return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);
790}
791
792sub _append_prepend {
793    my $self = shift;
794    my ($cmd, $key, $val, $cas) = @_;
795    return $self->_do_command($cmd, $key, $val, '', $cas);
796}
797
798sub replace {
799    my $self = shift;
800    my ($key, $val, $flags, $expire) = @_;
801    my $extra_header = pack "NN", $flags, $expire;
802    my $cas = 0;
803    return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);
804}
805
806sub delete {
807    my $self = shift;
808    my ($key) = @_;
809    return $self->_do_command(::CMD_DELETE, $key, '');
810}
811
812sub incr {
813    my $self = shift;
814    my ($key, $amt, $init, $exp) = @_;
815    $amt = 1 unless defined $amt;
816    $init = 0 unless defined $init;
817    $exp = 0 unless defined $exp;
818
819    return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
820}
821
822sub incr_cas {
823    my $self = shift;
824    my ($key, $amt, $init, $exp) = @_;
825    $amt = 1 unless defined $amt;
826    $init = 0 unless defined $init;
827    $exp = 0 unless defined $exp;
828
829    return $self->_incrdecr_cas(::CMD_INCR, $key, $amt, $init, $exp);
830}
831
832sub decr {
833    my $self = shift;
834    my ($key, $amt, $init, $exp) = @_;
835    $amt = 1 unless defined $amt;
836    $init = 0 unless defined $init;
837    $exp = 0 unless defined $exp;
838
839    return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
840}
841
842sub noop {
843    my $self = shift;
844    return $self->_do_command(::CMD_NOOP, '', '');
845}
846
847package MC::Error;
848
849use strict;
850use warnings;
851
852use constant ERR_UNKNOWN_CMD  => 0x81;
853use constant ERR_NOT_FOUND    => 0x1;
854use constant ERR_EXISTS       => 0x2;
855use constant ERR_TOO_BIG      => 0x3;
856use constant ERR_EINVAL       => 0x4;
857use constant ERR_NOT_STORED   => 0x5;
858use constant ERR_DELTA_BADVAL => 0x6;
859
860use overload '""' => sub {
861    my $self = shift;
862    return "Memcache Error ($self->[0]): $self->[1]";
863};
864
865sub new {
866    my $class = shift;
867    my $error = [@_];
868    my $self = bless $error, (ref $class || $class);
869
870    return $self;
871}
872
873sub not_found {
874    my $self = shift;
875    return $self->[0] == ERR_NOT_FOUND;
876}
877
878sub exists {
879    my $self = shift;
880    return $self->[0] == ERR_EXISTS;
881}
882
883sub too_big {
884    my $self = shift;
885    return $self->[0] == ERR_TOO_BIG;
886}
887
888sub delta_badval {
889    my $self = shift;
890    return $self->[0] == ERR_DELTA_BADVAL;
891}
892
893sub einval {
894    my $self = shift;
895    return $self->[0] == ERR_EINVAL;
896}
897
898# vim: filetype=perl
899
900