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