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