"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