git.m6w6.name Git - awesomized/libmemcached/blob - memcached/t/binary.t

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