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