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 => 3549;
   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     $mc->set("totouch", "toast3", 0, 1);
 277     $res = $mc->touch("totouch", 1);
 278     sleep 3;
 279     $empty->("totouch");
 280 }
 281
 282 # diag "Silent set.";
 283 $mc->silent_mutation(::CMD_SETQ, 'silentset', 'silentsetval');
 284
 285 # diag "Silent add.";
 286 $mc->silent_mutation(::CMD_ADDQ, 'silentadd', 'silentaddval');
 287
 288 # diag "Silent replace.";
 289 {
 290     my $key = "silentreplace";
 291     my $extra = pack "NN", 829, 0;
 292     $empty->($key);
 293     # $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
 294     # $empty->($key);
 295
 296     $mc->add($key, "xval", 831, 0);
 297     $check->($key, 831, 'xval');
 298
 299     $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
 300     $check->($key, 829, 'somevalue');
 301 }
 302
 303 # diag "Silent delete";
 304 {
 305     my $key = "silentdelete";
 306     $empty->($key);
 307     $mc->set($key, "some val", 19, 0);
 308     $mc->send_silent(::CMD_DELETEQ, $key, '', 772);
 309     $empty->($key);
 310 }
 311
 312 # diag "Silent increment";
 313 {
 314     my $key = "silentincr";
 315     my $opaque = 98428747;
 316     $empty->($key);
 317     $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 0, 0, 0);
 318     is($mc->incr($key, 0), 0, "First call is 0");
 319
 320     $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 8, 0, 0);
 321     is($mc->incr($key, 0), 8);
 322 }
 323
 324 # diag "Silent decrement";
 325 {
 326     my $key = "silentdecr";
 327     my $opaque = 98428147;
 328     $empty->($key);
 329     $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 0, 185, 0);
 330     is($mc->incr($key, 0), 185);
 331
 332     $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 8, 0, 0);
 333     is($mc->incr($key, 0), 177);
 334 }
 335
 336 # diag "Silent flush";
 337 {
 338     my %stats1 = $mc->stats('');
 339
 340     $set->('x', 5, 19, "somevaluex");
 341     $set->('y', 5, 17, "somevaluey");
 342     $mc->send_silent(::CMD_FLUSHQ, '', '', 2775256);
 343     $empty->('x');
 344     $empty->('y');
 345
 346     my %stats2 = $mc->stats('');
 347     is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
 348        "Stats not updated on a binary quiet flush");
 349 }
 350
 351 # diag "Append";
 352 {
 353     my $key = "appendkey";
 354     my $value = "some value";
 355     $set->($key, 8, 19, $value);
 356     $mc->_append_prepend(::CMD_APPEND, $key, " more");
 357     $check->($key, 19, $value . " more");
 358 }
 359
 360 # diag "Prepend";
 361 {
 362     my $key = "prependkey";
 363     my $value = "some value";
 364     $set->($key, 8, 19, $value);
 365     $mc->_append_prepend(::CMD_PREPEND, $key, "prefixed ");
 366     $check->($key, 19, "prefixed " . $value);
 367 }
 368
 369 # diag "Silent append";
 370 {
 371     my $key = "appendqkey";
 372     my $value = "some value";
 373     $set->($key, 8, 19, $value);
 374     $mc->send_silent(::CMD_APPENDQ, $key, " more", 7284492);
 375     $check->($key, 19, $value . " more");
 376 }
 377
 378 # diag "Silent prepend";
 379 {
 380     my $key = "prependqkey";
 381     my $value = "some value";
 382     $set->($key, 8, 19, $value);
 383     $mc->send_silent(::CMD_PREPENDQ, $key, "prefixed ", 7284492);
 384     $check->($key, 19, "prefixed " . $value);
 385 }
 386
 387 # diag "Leaky binary get test.";
 388 # # http://code.google.com/p/memcached/issues/detail?id=16
 389 {
 390     # Get a new socket so we can speak text to it.
 391     my $sock = $server->new_sock;
 392     my $max = 1024 * 1024;
 393     my $big = "a big value that's > .5M and < 1M. ";
 394     while (length($big) * 2 < $max) {
 395         $big = $big . $big;
 396     }
 397     my $biglen = length($big);
 398
 399     for(1..100) {
 400         my $key = "some_key_$_";
 401         # print STDERR "Key is $key\n";
 402         # print $sock "set $key 0 0 $vallen\r\n$value\r\n";
 403         print $sock "set $key 0 0 $biglen\r\n$big\r\n";
 404         is(scalar <$sock>, "STORED\r\n", "stored big");
 405         my ($f, $v, $c) = $mc->get($key);
 406     }
 407 }
 408
 409 # diag "Test stats settings."
 410 {
 411     my %stats = $mc->stats('settings');
 412
 413     is(1024, $stats{'maxconns'});
 414     is('NULL', $stats{'domain_socket'});
 415     is('on', $stats{'evictions'});
 416     is('yes', $stats{'cas_enabled'});
 417 }
 418
 419 # diag "Test quit commands.";
 420 {
 421     my $s2 = new_memcached();
 422     my $mc2 = MC::Client->new($s2);
 423     $mc2->send_command(CMD_QUITQ, '', '', 0, '', 0);
 424
 425     # Five seconds ought to be enough to get hung up on.
 426     my $oldalarmt = alarm(5);
 427
 428     # Verify we can't read anything.
 429     my $bytesread = -1;
 430     eval {
 431         local $SIG{'ALRM'} = sub { die "timeout" };
 432         my $data = "";
 433         $bytesread = sysread($mc2->{socket}, $data, 24),
 434     };
 435     is($bytesread, 0, "Read after quit.");
 436
 437     # Restore signal stuff.
 438     alarm($oldalarmt);
 439 }
 440
 441 # diag "Test protocol boundary overruns";
 442 {
 443     use List::Util qw[min];
 444     # Attempting some protocol overruns by toying around with the edge
 445     # of the data buffer at a few different sizes.  This assumes the
 446     # boundary is at or around 2048 bytes.
 447     for (my $i = 1900; $i < 2100; $i++) {
 448         my $k = "test_key_$i";
 449         my $v = 'x' x $i;
 450         # diag "Trying $i $k";
 451         my $extra = pack "NN", 82, 0;
 452         my $data = $mc->build_command(::CMD_SETQ, $k, $v, 0, $extra, 0);
 453         $data .= $mc->build_command(::CMD_SETQ, "alt_$k", "blah", 0, $extra, 0);
 454         if (length($data) > 2024) {
 455             for (my $j = 2024; $j < min(2096, length($data)); $j++) {
 456                 $mc->{socket}->send(substr($data, 0, $j));
 457                 $mc->flush_socket;
 458                 sleep(0.001);
 459                 $mc->{socket}->send(substr($data, $j));
 460                 $mc->flush_socket;
 461             }
 462         } else {
 463             $mc->{socket}->send($data);
 464         }
 465         $mc->flush_socket;
 466         $check->($k, 82, $v);
 467         $check->("alt_$k", 82, "blah");
 468     }
 469 }
 470
 471 # Along with the assertion added to the code to verify we're staying
 472 # within bounds when we do a stats detail dump (detail turned on at
 473 # the top).
 474 my %stats = $mc->stats('detail dump');
 475
 476 # This test causes a disconnection.
 477 {
 478     # diag "Key too large.";
 479     my $key = "x" x 365;
 480     eval {
 481         $mc->get($key, 'should die', 10, 10);
 482     };
 483     ok($@->einval, "Invalid key length");
 484 }
 485
 486 # ######################################################################
 487 # Test ends around here.
 488 # ######################################################################
 489
 490 package MC::Client;
 491
 492 use strict;
 493 use warnings;
 494 use fields qw(socket);
 495 use IO::Socket::INET;
 496
 497 sub new {
 498     my $self = shift;
 499     my ($s) = @_;
 500     $s = $server unless defined $s;
 501     my $sock = $s->sock;
 502     $self = fields::new($self);
 503     $self->{socket} = $sock;
 504     return $self;
 505 }
 506
 507 sub build_command {
 508     my $self = shift;
 509     die "Not enough args to send_command" unless @_ >= 4;
 510     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 511
 512     $extra_header = '' unless defined $extra_header;
 513     my $keylen    = length($key);
 514     my $vallen    = length($val);
 515     my $extralen  = length($extra_header);
 516     my $datatype  = 0;  # field for future use
 517     my $reserved  = 0;  # field for future use
 518     my $totallen  = $keylen + $vallen + $extralen;
 519     my $ident_hi  = 0;
 520     my $ident_lo  = 0;
 521
 522     if ($cas) {
 523         $ident_hi = int($cas / 2 ** 32);
 524         $ident_lo = int($cas % 2 ** 32);
 525     }
 526
 527     my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,
 528                    $datatype, $reserved, $totallen, $opaque, $ident_hi,
 529                    $ident_lo);
 530     my $full_msg = $msg . $extra_header . $key . $val;
 531     return $full_msg;
 532 }
 533
 534 sub send_command {
 535     my $self = shift;
 536     die "Not enough args to send_command" unless @_ >= 4;
 537     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 538
 539     my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 540
 541     my $sent = $self->{socket}->send($full_msg);
 542     die("Send failed:  $!") unless $sent;
 543     if($sent != length($full_msg)) {
 544         die("only sent $sent of " . length($full_msg) . " bytes");
 545     }
 546 }
 547
 548 sub flush_socket {
 549     my $self = shift;
 550     $self->{socket}->flush;
 551 }
 552
 553 # Send a silent command and ensure it doesn't respond.
 554 sub send_silent {
 555     my $self = shift;
 556     die "Not enough args to send_silent" unless @_ >= 4;
 557     my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
 558
 559     $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 560     $self->send_command(::CMD_NOOP, '', '', $opaque + 1);
 561
 562     my ($ropaque, $data) = $self->_handle_single_response;
 563     Test::More::is($ropaque, $opaque + 1);
 564 }
 565
 566 sub silent_mutation {
 567     my $self = shift;
 568     my ($cmd, $key, $value) = @_;
 569
 570     $empty->($key);
 571     my $extra = pack "NN", 82, 0;
 572     $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
 573     $check->($key, 82, $value);
 574 }
 575
 576 sub _handle_single_response {
 577     my $self = shift;
 578     my $myopaque = shift;
 579
 580     my $hdr = "";
 581     while(::MIN_RECV_BYTES - length($hdr) > 0) {
 582         $self->{socket}->recv(my $response, ::MIN_RECV_BYTES - length($hdr));
 583         $hdr .= $response;
 584     }
 585     Test::More::is(length($hdr), ::MIN_RECV_BYTES, "Expected read length");
 586
 587     my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
 588         $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $hdr);
 589     Test::More::is($magic, ::RES_MAGIC, "Got proper response magic");
 590
 591     my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
 592
 593     return ($opaque, '', $cas, 0) if($remaining == 0);
 594
 595     # fetch the value
 596     my $rv="";
 597     while($remaining - length($rv) > 0) {
 598         $self->{socket}->recv(my $buf, $remaining - length($rv));
 599         $rv .= $buf;
 600     }
 601     if(length($rv) != $remaining) {
 602         my $found = length($rv);
 603         die("Expected $remaining bytes, got $found");
 604     }
 605
 606     if (defined $myopaque) {
 607         Test::More::is($opaque, $myopaque, "Expected opaque");
 608     } else {
 609         Test::More::pass("Implicit pass since myopaque is undefined");
 610     }
 611
 612     if ($status) {
 613         die MC::Error->new($status, $rv);
 614     }
 615
 616     return ($opaque, $rv, $cas, $keylen);
 617 }
 618
 619 sub _do_command {
 620     my $self = shift;
 621     die unless @_ >= 3;
 622     my ($cmd, $key, $val, $extra_header, $cas) = @_;
 623
 624     $extra_header = '' unless defined $extra_header;
 625     my $opaque = int(rand(2**32));
 626     $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
 627     my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);
 628     return ($rv, $rcas);
 629 }
 630
 631 sub _incrdecr_header {
 632     my $self = shift;
 633     my ($amt, $init, $exp) = @_;
 634
 635     my $amt_hi = int($amt / 2 ** 32);
 636     my $amt_lo = int($amt % 2 ** 32);
 637
 638     my $init_hi = int($init / 2 ** 32);
 639     my $init_lo = int($init % 2 ** 32);
 640
 641     my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,
 642                             $init_lo, $exp);
 643
 644     return $extra_header;
 645 }
 646
 647 sub _incrdecr_cas {
 648     my $self = shift;
 649     my ($cmd, $key, $amt, $init, $exp) = @_;
 650
 651     my ($data, $rcas) = $self->_do_command($cmd, $key, '',
 652                                            $self->_incrdecr_header($amt, $init, $exp));
 653
 654     my $header = substr $data, 0, 8, '';
 655     my ($resp_hi, $resp_lo) = unpack "NN", $header;
 656     my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
 657
 658     return $resp, $rcas;
 659 }
 660
 661 sub _incrdecr {
 662     my $self = shift;
 663     my ($v, $c) = $self->_incrdecr_cas(@_);
 664     return $v
 665 }
 666
 667 sub silent_incrdecr {
 668     my $self = shift;
 669     my ($cmd, $key, $amt, $init, $exp) = @_;
 670     my $opaque = 8275753;
 671
 672     $mc->send_silent($cmd, $key, '', $opaque,
 673                      $mc->_incrdecr_header($amt, $init, $exp));
 674 }
 675
 676 sub stats {
 677     my $self = shift;
 678     my $key  = shift;
 679     my $cas = 0;
 680     my $opaque = int(rand(2**32));
 681     $self->send_command(::CMD_STAT, $key, '', $opaque, '', $cas);
 682
 683     my %rv = ();
 684     my $found_key = '';
 685     my $found_val = '';
 686     do {
 687         my ($op, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
 688         if($keylen > 0) {
 689             $found_key = substr($data, 0, $keylen);
 690             $found_val = substr($data, $keylen);
 691             $rv{$found_key} = $found_val;
 692         } else {
 693             $found_key = '';
 694         }
 695     } while($found_key ne '');
 696     return %rv;
 697 }
 698
 699 sub get {
 700     my $self = shift;
 701     my $key  = shift;
 702     my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');
 703
 704     my $header = substr $rv, 0, 4, '';
 705     my $flags  = unpack("N", $header);
 706
 707     return ($flags, $rv, $cas);
 708 }
 709
 710 sub get_multi {
 711     my $self = shift;
 712     my @keys = @_;
 713
 714     for (my $i = 0; $i < @keys; $i++) {
 715         $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);
 716     }
 717
 718     my $terminal = @keys + 10;
 719     $self->send_command(::CMD_NOOP, '', '', $terminal);
 720
 721     my %return;
 722     while (1) {
 723         my ($opaque, $data) = $self->_handle_single_response;
 724         last if $opaque == $terminal;
 725
 726         my $header = substr $data, 0, 4, '';
 727         my $flags  = unpack("N", $header);
 728
 729         $return{$keys[$opaque]} = [$flags, $data];
 730     }
 731
 732     return %return if wantarray;
 733     return \%return;
 734 }
 735
 736 sub touch {
 737     my $self = shift;
 738     my ($key, $expire) = @_;
 739     my $extra_header = pack "N", $expire;
 740     my $cas = 0;
 741     return $self->_do_command(::CMD_TOUCH, $key, '', $extra_header, $cas);
 742 }
 743
 744 sub gat {
 745     my $self   = shift;
 746     my $key    = shift;
 747     my $expire = shift;
 748     my $extra_header = pack "N", $expire;
 749     my ($rv, $cas) = $self->_do_command(::CMD_GAT, $key, '', $extra_header);
 750
 751     my $header = substr $rv, 0, 4, '';
 752     my $flags  = unpack("N", $header);
 753
 754     return ($flags, $rv, $cas);
 755 }
 756
 757 sub version {
 758     my $self = shift;
 759     return $self->_do_command(::CMD_VERSION, '', '');
 760 }
 761
 762 sub flush {
 763     my $self = shift;
 764     return $self->_do_command(::CMD_FLUSH, '', '');
 765 }
 766
 767 sub add {
 768     my $self = shift;
 769     my ($key, $val, $flags, $expire) = @_;
 770     my $extra_header = pack "NN", $flags, $expire;
 771     my $cas = 0;
 772     return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);
 773 }
 774
 775 sub set {
 776     my $self = shift;
 777     my ($key, $val, $flags, $expire, $cas) = @_;
 778     my $extra_header = pack "NN", $flags, $expire;
 779     return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);
 780 }
 781
 782 sub _append_prepend {
 783     my $self = shift;
 784     my ($cmd, $key, $val, $cas) = @_;
 785     return $self->_do_command($cmd, $key, $val, '', $cas);
 786 }
 787
 788 sub replace {
 789     my $self = shift;
 790     my ($key, $val, $flags, $expire) = @_;
 791     my $extra_header = pack "NN", $flags, $expire;
 792     my $cas = 0;
 793     return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);
 794 }
 795
 796 sub delete {
 797     my $self = shift;
 798     my ($key) = @_;
 799     return $self->_do_command(::CMD_DELETE, $key, '');
 800 }
 801
 802 sub incr {
 803     my $self = shift;
 804     my ($key, $amt, $init, $exp) = @_;
 805     $amt = 1 unless defined $amt;
 806     $init = 0 unless defined $init;
 807     $exp = 0 unless defined $exp;
 808
 809     return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
 810 }
 811
 812 sub incr_cas {
 813     my $self = shift;
 814     my ($key, $amt, $init, $exp) = @_;
 815     $amt = 1 unless defined $amt;
 816     $init = 0 unless defined $init;
 817     $exp = 0 unless defined $exp;
 818
 819     return $self->_incrdecr_cas(::CMD_INCR, $key, $amt, $init, $exp);
 820 }
 821
 822 sub decr {
 823     my $self = shift;
 824     my ($key, $amt, $init, $exp) = @_;
 825     $amt = 1 unless defined $amt;
 826     $init = 0 unless defined $init;
 827     $exp = 0 unless defined $exp;
 828
 829     return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
 830 }
 831
 832 sub noop {
 833     my $self = shift;
 834     return $self->_do_command(::CMD_NOOP, '', '');
 835 }
 836
 837 package MC::Error;
 838
 839 use strict;
 840 use warnings;
 841
 842 use constant ERR_UNKNOWN_CMD  => 0x81;
 843 use constant ERR_NOT_FOUND    => 0x1;
 844 use constant ERR_EXISTS       => 0x2;
 845 use constant ERR_TOO_BIG      => 0x3;
 846 use constant ERR_EINVAL       => 0x4;
 847 use constant ERR_NOT_STORED   => 0x5;
 848 use constant ERR_DELTA_BADVAL => 0x6;
 849
 850 use overload '""' => sub {
 851     my $self = shift;
 852     return "Memcache Error ($self->[0]): $self->[1]";
 853 };
 854
 855 sub new {
 856     my $class = shift;
 857     my $error = [@_];
 858     my $self = bless $error, (ref $class || $class);
 859
 860     return $self;
 861 }
 862
 863 sub not_found {
 864     my $self = shift;
 865     return $self->[0] == ERR_NOT_FOUND;
 866 }
 867
 868 sub exists {
 869     my $self = shift;
 870     return $self->[0] == ERR_EXISTS;
 871 }
 872
 873 sub too_big {
 874     my $self = shift;
 875     return $self->[0] == ERR_TOO_BIG;
 876 }
 877
 878 sub delta_badval {
 879     my $self = shift;
 880     return $self->[0] == ERR_DELTA_BADVAL;
 881 }
 882
 883 sub einval {
 884     my $self = shift;
 885     return $self->[0] == ERR_EINVAL;
 886 }
 887
 888 # vim: filetype=perl
 889