"Fossies" - the Fresh Open Source Software Archive 
Member "memcached-1.6.15/t/binary.t" (21 Feb 2022, 25312 Bytes) of package /linux/www/memcached-1.6.15.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5 use Test::More;
6 use FindBin qw($Bin);
7 use lib "$Bin/lib";
8 use MemcachedTest;
9
10 my $server = new_memcached("-o no_modern");
11 ok($server, "started the server");
12
13 # Based almost 100% off testClient.py which is:
14 # Copyright (c) 2007 Dustin Sallings <dustin@spy.net>
15
16 # Command constants
17 use constant CMD_GET => 0x00;
18 use constant CMD_SET => 0x01;
19 use constant CMD_ADD => 0x02;
20 use constant CMD_REPLACE => 0x03;
21 use constant CMD_DELETE => 0x04;
22 use constant CMD_INCR => 0x05;
23 use constant CMD_DECR => 0x06;
24 use constant CMD_QUIT => 0x07;
25 use constant CMD_FLUSH => 0x08;
26 use constant CMD_GETQ => 0x09;
27 use constant CMD_NOOP => 0x0A;
28 use constant CMD_VERSION => 0x0B;
29 use constant CMD_GETK => 0x0C;
30 use constant CMD_GETKQ => 0x0D;
31 use constant CMD_APPEND => 0x0E;
32 use constant CMD_PREPEND => 0x0F;
33 use constant CMD_STAT => 0x10;
34 use constant CMD_SETQ => 0x11;
35 use constant CMD_ADDQ => 0x12;
36 use constant CMD_REPLACEQ => 0x13;
37 use constant CMD_DELETEQ => 0x14;
38 use constant CMD_INCREMENTQ => 0x15;
39 use constant CMD_DECREMENTQ => 0x16;
40 use constant CMD_QUITQ => 0x17;
41 use constant CMD_FLUSHQ => 0x18;
42 use constant CMD_APPENDQ => 0x19;
43 use constant CMD_PREPENDQ => 0x1A;
44 use constant CMD_TOUCH => 0x1C;
45 use constant CMD_GAT => 0x1D;
46 use constant CMD_GATQ => 0x1E;
47 use constant CMD_GATK => 0x23;
48 use 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.
52 use constant REQ_PKT_FMT => "CCnCCnNNNN";
53 use constant RES_PKT_FMT => "CCnCCnNNNN";
54 use constant INCRDECR_PKT_FMT => "NNNNN";
55 use constant MIN_RECV_BYTES => length(pack(RES_PKT_FMT));
56 use constant REQ_MAGIC => 0x80;
57 use constant RES_MAGIC => 0x81;
58
59 my $mc = MC::Client->new;
60
61 # Let's turn on detail stats for all this stuff
62
63 $mc->stats('detail on');
64 my $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
71 my $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
77 my $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
84 my $delete = sub {
85 my ($key, $when) = @_;
86 $mc->delete($key, $when);
87 $empty->($key);
88 };
89
90 # diag "Test Version";
91 my $v = $mc->version;
92 ok(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=4096');
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;
199 is($mc->incr("x"), 0, "First incr call is zero");
200 is($mc->incr("x"), 1, "Second incr call is one");
201 is($mc->incr("x", 211), 212, "Adding 211 gives you 212");
202 is($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;
228 is($mc->incr("x", undef, 5), 5, "Initial value");
229 is($mc->decr("x"), 4, "Decrease by one");
230 is($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).
512 my %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
524 done_testing();
525
526 # ######################################################################
527 # Test ends around here.
528 # ######################################################################
529
530 package MC::Client;
531
532 use strict;
533 use warnings;
534 use fields qw(socket);
535 use IO::Socket::INET;
536
537 sub 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
547 sub 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
574 sub 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
597 sub flush_socket {
598 my $self = shift;
599 $self->{socket}->flush;
600 }
601
602 # Send a silent command and ensure it doesn't respond.
603 sub 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
615 sub 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
625 sub _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
667 sub _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
679 sub _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
695 sub _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
709 sub _incrdecr {
710 my $self = shift;
711 my ($v, $c) = $self->_incrdecr_cas(@_);
712 return $v
713 }
714
715 sub 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
724 sub 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
747 sub 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
758 sub 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
784 sub 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
792 sub 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
805 sub version {
806 my $self = shift;
807 return $self->_do_command(::CMD_VERSION, '', '');
808 }
809
810 sub flush {
811 my $self = shift;
812 return $self->_do_command(::CMD_FLUSH, '', '');
813 }
814
815 sub 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
823 sub 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
830 sub _append_prepend {
831 my $self = shift;
832 my ($cmd, $key, $val, $cas) = @_;
833 return $self->_do_command($cmd, $key, $val, '', $cas);
834 }
835
836 sub 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
844 sub delete {
845 my $self = shift;
846 my ($key) = @_;
847 return $self->_do_command(::CMD_DELETE, $key, '');
848 }
849
850 sub 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
860 sub 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
870 sub 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
880 sub noop {
881 my $self = shift;
882 return $self->_do_command(::CMD_NOOP, '', '');
883 }
884
885 package MC::Error;
886
887 use strict;
888 use warnings;
889
890 use constant ERR_UNKNOWN_CMD => 0x81;
891 use constant ERR_NOT_FOUND => 0x1;
892 use constant ERR_EXISTS => 0x2;
893 use constant ERR_TOO_BIG => 0x3;
894 use constant ERR_EINVAL => 0x4;
895 use constant ERR_NOT_STORED => 0x5;
896 use constant ERR_DELTA_BADVAL => 0x6;
897
898 use overload '""' => sub {
899 my $self = shift;
900 return "Memcache Error ($self->[0]): $self->[1]";
901 };
902
903 sub new {
904 my $class = shift;
905 my $error = [@_];
906 my $self = bless $error, (ref $class || $class);
907
908 return $self;
909 }
910
911 sub not_found {
912 my $self = shift;
913 return $self->[0] == ERR_NOT_FOUND;
914 }
915
916 sub exists {
917 my $self = shift;
918 return $self->[0] == ERR_EXISTS;
919 }
920
921 sub too_big {
922 my $self = shift;
923 return $self->[0] == ERR_TOO_BIG;
924 }
925
926 sub delta_badval {
927 my $self = shift;
928 return $self->[0] == ERR_DELTA_BADVAL;
929 }
930
931 sub einval {
932 my $self = shift;
933 return $self->[0] == ERR_EINVAL;
934 }
935
936 # vim: filetype=perl
937