#!/usr/bin/perl

use strict;

use warnings;

use Test::More;

use FindBin qw($Bin);

use lib "$Bin/lib";

use MemcachedTest;

my $server = new_memcached("-o no_modern");

ok($server, "started the server");

# Based almost 100% off testClient.py which is:

# Copyright (c) 2007  Dustin Sallings <dustin@spy.net>

# Command constants

use constant CMD_GET        => 0x00;

use constant CMD_SET        => 0x01;

use constant CMD_ADD        => 0x02;

use constant CMD_REPLACE    => 0x03;

use constant CMD_DELETE     => 0x04;

use constant CMD_INCR       => 0x05;

use constant CMD_DECR       => 0x06;

use constant CMD_QUIT       => 0x07;

use constant CMD_FLUSH      => 0x08;

use constant CMD_GETQ       => 0x09;

use constant CMD_NOOP       => 0x0A;

use constant CMD_VERSION    => 0x0B;

use constant CMD_GETK       => 0x0C;

use constant CMD_GETKQ      => 0x0D;

use constant CMD_APPEND     => 0x0E;

use constant CMD_PREPEND    => 0x0F;

use constant CMD_STAT       => 0x10;

use constant CMD_SETQ       => 0x11;

use constant CMD_ADDQ       => 0x12;

use constant CMD_REPLACEQ   => 0x13;

use constant CMD_DELETEQ    => 0x14;

use constant CMD_INCREMENTQ => 0x15;

use constant CMD_DECREMENTQ => 0x16;

use constant CMD_QUITQ      => 0x17;

use constant CMD_FLUSHQ     => 0x18;

use constant CMD_APPENDQ    => 0x19;

use constant CMD_PREPENDQ   => 0x1A;

use constant CMD_TOUCH      => 0x1C;

use constant CMD_GAT        => 0x1D;

use constant CMD_GATQ       => 0x1E;

use constant CMD_GATK       => 0x23;

use constant CMD_GATKQ      => 0x24;

# REQ and RES formats are divided even though they currently share

# the same format, since they _could_ differ in the future.

use constant REQ_PKT_FMT      => "CCnCCnNNNN";

use constant RES_PKT_FMT      => "CCnCCnNNNN";

use constant INCRDECR_PKT_FMT => "NNNNN";

use constant MIN_RECV_BYTES   => length(pack(RES_PKT_FMT));

use constant REQ_MAGIC        => 0x80;

use constant RES_MAGIC        => 0x81;

my $mc = MC::Client->new;

# Let's turn on detail stats for all this stuff

$mc->stats('detail on');

my $check = sub {

    my ($key, $orig_flags, $orig_val) = @_;

    my ($flags, $val, $cas) = $mc->get($key);

    is($flags, $orig_flags, "Flags is set properly");

    ok($val eq $orig_val || $val == $orig_val, $val . " = " . $orig_val);

};

my $set = sub {

    my ($key, $exp, $orig_flags, $orig_value) = @_;

    $mc->set($key, $orig_value, $orig_flags, $exp);

    $check->($key, $orig_flags, $orig_value);

};

my $empty = sub {

    my $key = shift;

    my $rv =()= eval { $mc->get($key) };

    is($rv, 0, "Didn't get a result from get");

    ok($@->not_found, "We got a not found error when we expected one");

};

my $delete = sub {

    my ($key, $when) = @_;

    $mc->delete($key, $when);

    $empty->($key);

};

# diag "Test Version";

my $v = $mc->version;

ok(defined $v && length($v), "Proper version: $v");

# Bug 71

{

    my %stats1 = $mc->stats('');

    $mc->flush;

    my %stats2 = $mc->stats('');

    is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,

       "Stats not updated on a binary flush");

}

# diag "Flushing...";

$mc->flush;

# diag "Noop";

$mc->noop;

# diag "Simple set/get";

$set->('x', 5, 19, "somevalue");

# diag "Delete";

$delete->('x');

# diag "Flush";

$set->('x', 5, 19, "somevaluex");

$set->('y', 5, 17, "somevaluey");

$mc->flush;

$empty->('x');

$empty->('y');

{

    diag "Some chunked item tests";

    my $s2 = new_memcached('-o no_modern,slab_chunk_max=4096');

    ok($s2, "started the server");

    my $m2 = MC::Client->new($s2);

    # Specifically trying to cross the chunk boundary when internally

    # appending CLRF.

    for my $k (7900..8100) {

        my $val = 'd' x $k;

        $val .= '123';

        $m2->set('t', $val, 0, 0);

        # Ensure we get back the same value. Bugs can chop chars.

        my (undef, $gval, undef) = $m2->get('t');

        ok($gval eq $val, $gval . " = " . $val);

    }

    my $cval = ('d' x 8100) . '123';

    my $m3 = $s2->new_sock;

    mem_get_is($m3, 't', $cval, "large value set from bin fetched from ascii");

}

{

    # diag "Add";

    $empty->('i');

    $mc->add('i', 'ex', 5, 10);

    $check->('i', 5, "ex");

    my $rv =()= eval { $mc->add('i', "ex2", 10, 5) };

    is($rv, 0, "Add didn't return anything");

    ok($@->exists, "Expected exists error received");

    $check->('i', 5, "ex");

}

{

    # diag "Too big.";

    $empty->('toobig');

    $mc->set('toobig', 'not too big', 10, 10);

    eval {

        my $bigval = ("x" x (1024*1024)) . "x";

        $mc->set('toobig', $bigval, 10, 10);

    };

    ok($@->too_big, "Was too big");

    $empty->('toobig');

}

{

    # diag "Replace";

    $empty->('j');

    my $rv =()= eval { $mc->replace('j', "ex", 19, 5) };

    is($rv, 0, "Replace didn't return anything");

    ok($@->not_found, "Expected not_found error received");

    $empty->('j');

    $mc->add('j', "ex2", 14, 5);

    $check->('j', 14, "ex2");

    $mc->replace('j', "ex3", 24, 5);

    $check->('j', 24, "ex3");

}

{

    # diag "MultiGet";

    $mc->add('xx', "ex", 1, 5);

    $mc->add('wye', "why", 2, 5);

    my $rv = $mc->get_multi(qw(xx wye zed));

    # CAS is returned with all gets.

    $rv->{xx}->[2]  = 0;

    $rv->{wye}->[2] = 0;

    is_deeply($rv->{xx}, [1, 'ex', 0], "X is correct");

    is_deeply($rv->{wye}, [2, 'why', 0], "Y is correct");

    is(keys(%$rv), 2, "Got only two answers like we expect");

}

# diag "Test increment";

$mc->flush;

is($mc->incr("x"), 0, "First incr call is zero");

is($mc->incr("x"), 1, "Second incr call is one");

is($mc->incr("x", 211), 212, "Adding 211 gives you 212");

is($mc->incr("x", 2**33), 8589934804, "Blast the 32bit border");

# diag "Issue 48 - incrementing plain text.";

{

    $mc->set("issue48", "text", 0, 0);

    my $rv =()= eval { $mc->incr('issue48'); };

    ok($@ && $@->delta_badval, "Expected invalid value when incrementing text.");

    $check->('issue48', 0, "text");

    $rv =()= eval { $mc->decr('issue48'); };

    ok($@ && $@->delta_badval, "Expected invalid value when decrementing text.");

    $check->('issue48', 0, "text");

}

# diag "Issue 320 - incr/decr wrong length for initial value";

{

    $mc->flush;

    is($mc->incr("issue320", 1, 1, 0), 1, "incr initial value is 1");

    my (undef, $rv, undef) = $mc->get("issue320");

    is(length($rv), 1, "initial value length is 1");

    is($rv, "1", "initial value is 1");

}

# diag "Test decrement";

$mc->flush;

is($mc->incr("x", undef, 5), 5, "Initial value");

is($mc->decr("x"), 4, "Decrease by one");

is($mc->decr("x", 211), 0, "Floor is zero");

{

    # diag "bug220

    my ($rv, $cas) = $mc->set("bug220", "100", 0, 0);

    my ($irv, $icas) = $mc->incr_cas("bug220", 999);

    ok($icas != $cas);

    is($irv, 1099, "Incr amount failed");

    my ($flags, $val, $gcas) = $mc->get("bug220");

    is($gcas, $icas, "CAS didn't match after incr/gets");

    ($irv, $icas) = $mc->incr_cas("bug220", 999);

    ok($icas != $cas);

    is($irv, 2098, "Incr amount failed");

    ($flags, $val, $gcas) = $mc->get("bug220");

    is($gcas, $icas, "CAS didn't match after incr/gets");

}

{

    # diag "bug21";

    $mc->add("bug21", "9223372036854775807", 0, 0);

    is($mc->incr("bug21"), 9223372036854775808, "First incr for bug21.");

    is($mc->incr("bug21"), 9223372036854775809, "Second incr for bug21.");

    is($mc->decr("bug21"), 9223372036854775808, "Decr for bug21.");

}

{

    # diag "CAS";

    $mc->flush;

    {

        my $rv =()= eval { $mc->set("x", "bad value", 19, 5, 0x7FFFFFF) };

        is($rv, 0, "Empty return on expected failure");

        ok($@->not_found, "Error was 'not found' as expected");

    }

    my ($r, $rcas) = $mc->add("x", "original value", 5, 19);

    my ($flags, $val, $i) = $mc->get("x");

    is($val, "original value", "->gets returned proper value");

    is($rcas, $i, "Add CAS matched.");

    {

        my $rv =()= eval { $mc->set("x", "broken value", 19, 5, $i+1) };

        is($rv, 0, "Empty return on expected failure (1)");

        ok($@->exists, "Expected error state of 'exists' (1)");

    }

    ($r, $rcas) = $mc->set("x", "new value", 19, 5, $i);

    my ($newflags, $newval, $newi) = $mc->get("x");

    is($newval, "new value", "CAS properly overwrote value");

    is($rcas, $newi, "Get CAS matched.");

    {

        my $rv =()= eval { $mc->set("x", "replay value", 19, 5,  $i) };

        is($rv, 0, "Empty return on expected failure (2)");

        ok($@->exists, "Expected error state of 'exists' (2)");

    }

}

# diag "Touch commands";

{

    $mc->flush;

    $mc->set("totouch", "toast", 0, 1);

    my $res = $mc->touch("totouch", 10);

    sleep 2;

    $check->("totouch", 0, "toast");

    $mc->set("totouch", "toast2", 0, 1);

    my ($flags, $val, $i) = $mc->gat("totouch", 10);

    is($val, "toast2", "GAT returned correct value");

    sleep 2;

    $check->("totouch", 0, "toast2");

    # Test miss as well

    $mc->set("totouch", "toast3", 0, 1);

    $res = $mc->touch("totouch", 1);

    sleep 3;

    $empty->("totouch");

}

# diag "Silent set.";

$mc->silent_mutation(::CMD_SETQ, 'silentset', 'silentsetval');

# diag "Silent add.";

$mc->silent_mutation(::CMD_ADDQ, 'silentadd', 'silentaddval');

# diag "Silent replace.";

{

    my $key = "silentreplace";

    my $extra = pack "NN", 829, 0;

    $empty->($key);

    # $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);

    # $empty->($key);

    $mc->add($key, "xval", 831, 0);

    $check->($key, 831, 'xval');

    $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);

    $check->($key, 829, 'somevalue');

}

# diag "Silent delete";

{

    my $key = "silentdelete";

    $empty->($key);

    $mc->set($key, "some val", 19, 0);

    $mc->send_silent(::CMD_DELETEQ, $key, '', 772);

    $empty->($key);

}

# diag "Silent increment";

{

    my $key = "silentincr";

    my $opaque = 98428747;

    $empty->($key);

    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 0, 0, 0);

    is($mc->incr($key, 0), 0, "First call is 0");

    $mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 8, 0, 0);

    is($mc->incr($key, 0), 8);

}

# diag "Silent decrement";

{

    my $key = "silentdecr";

    my $opaque = 98428147;

    $empty->($key);

    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 0, 185, 0);

    is($mc->incr($key, 0), 185);

    $mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 8, 0, 0);

    is($mc->incr($key, 0), 177);

}

# diag "Silent flush";

{

    my %stats1 = $mc->stats('');

    $set->('x', 5, 19, "somevaluex");

    $set->('y', 5, 17, "somevaluey");

    $mc->send_silent(::CMD_FLUSHQ, '', '', 2775256);

    $empty->('x');

    $empty->('y');

    my %stats2 = $mc->stats('');

    is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,

       "Stats not updated on a binary quiet flush");

}

# diag "Append";

{

    my $key = "appendkey";

    my $value = "some value";

    $set->($key, 8, 19, $value);

    $mc->_append_prepend(::CMD_APPEND, $key, " more");

    $check->($key, 19, $value . " more");

}

# diag "Prepend";

{

    my $key = "prependkey";

    my $value = "some value";

    $set->($key, 8, 19, $value);

    $mc->_append_prepend(::CMD_PREPEND, $key, "prefixed ");

    $check->($key, 19, "prefixed " . $value);

}

# diag "Silent append";

{

    my $key = "appendqkey";

    my $value = "some value";

    $set->($key, 8, 19, $value);

    $mc->send_silent(::CMD_APPENDQ, $key, " more", 7284492);

    $check->($key, 19, $value . " more");

}

# diag "Silent prepend";

{

    my $key = "prependqkey";

    my $value = "some value";

    $set->($key, 8, 19, $value);

    $mc->send_silent(::CMD_PREPENDQ, $key, "prefixed ", 7284492);

    $check->($key, 19, "prefixed " . $value);

}

# diag "Leaky binary get test.";

# # http://code.google.com/p/memcached/issues/detail?id=16

{

    # Get a new socket so we can speak text to it.

    my $sock = $server->new_sock;

    my $max = 1024 * 1024;

    my $big = "a big value that's > .5M and < 1M. ";

    while (length($big) * 2 < $max) {

        $big = $big . $big;

    }

    my $biglen = length($big);

    for(1..100) {

        my $key = "some_key_$_";

        # print STDERR "Key is $key\n";

        # print $sock "set $key 0 0 $vallen\r\n$value\r\n";

        print $sock "set $key 0 0 $biglen\r\n$big\r\n";

        is(scalar <$sock>, "STORED\r\n", "stored big");

        my ($f, $v, $c) = $mc->get($key);

    }

}

# diag "Test stats settings."

{

    my %stats = $mc->stats('settings');

    is(1024, $stats{'maxconns'});

    # we run SSL tests over TCP; hence the domain_socket

    # is expected to be NULL.

    if (enabled_tls_testing()) {

        is('NULL', $stats{'domain_socket'});

    } else {

        isnt('NULL', $stats{'domain_socket'});

    }

    is('on', $stats{'evictions'});

    is('yes', $stats{'cas_enabled'});

    is('yes', $stats{'flush_enabled'});

}

# diag "Test quit commands.";

{

    my $s2 = new_memcached();

    my $mc2 = MC::Client->new($s2);

    $mc2->send_command(CMD_QUITQ, '', '', 0, '', 0);

    # Five seconds ought to be enough to get hung up on.

    my $oldalarmt = alarm(5);

    # Verify we can't read anything.

    my $bytesread = -1;

    eval {

        local $SIG{'ALRM'} = sub { die "timeout" };

        my $data = "";

        $bytesread = sysread($mc2->{socket}, $data, 24),

    };

    is($bytesread, 0, "Read after quit.");

    # Restore signal stuff.

    alarm($oldalarmt);

}

# diag "Test protocol boundary overruns";

{

    use List::Util qw[min];

    # Attempting some protocol overruns by toying around with the edge

    # of the data buffer at a few different sizes.  This assumes the

    # boundary is at or around 2048 bytes.

    for (my $i = 1900; $i < 2100; $i++) {

        my $k = "test_key_$i";

        my $v = 'x' x $i;

        # diag "Trying $i $k";

        my $extra = pack "NN", 82, 0;

        my $data = $mc->build_command(::CMD_SETQ, $k, $v, 0, $extra, 0);

        $data .= $mc->build_command(::CMD_SETQ, "alt_$k", "blah", 0, $extra, 0);

        if (length($data) > 2024) {

            for (my $j = 2024; $j < min(2096, length($data)); $j++) {

                $mc->{socket}->syswrite(substr($data, 0, $j));

                $mc->flush_socket;

                sleep(0.001);

                $mc->{socket}->syswrite(substr($data, $j));

                $mc->flush_socket;

            }

        } else {

            $mc->{socket}->syswrite($data);

        }

        $mc->flush_socket;

        $check->($k, 82, $v);

        $check->("alt_$k", 82, "blah");

    }

}

# Along with the assertion added to the code to verify we're staying

# within bounds when we do a stats detail dump (detail turned on at

# the top).

my %stats = $mc->stats('detail dump');

# This test causes a disconnection.

{

    # diag "Key too large.";

    my $key = "x" x 365;

    eval {

        $mc->get($key, 'should die', 10, 10);

    };

    ok($@->einval, "Invalid key length");

}

done_testing();

# ######################################################################

# Test ends around here.

# ######################################################################

package MC::Client;

use strict;

use warnings;

use fields qw(socket);

use IO::Socket::INET;

sub new {

    my $self = shift;

    my ($s) = @_;

    $s = $server unless defined $s;

    my $sock = $s->sock;

    $self = fields::new($self);

    $self->{socket} = $sock;

    return $self;

}

sub build_command {

    my $self = shift;

    die "Not enough args to send_command" unless @_ >= 4;

    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;

    $extra_header = '' unless defined $extra_header;

    my $keylen    = length($key);

    my $vallen    = length($val);

    my $extralen  = length($extra_header);

    my $datatype  = 0;  # field for future use

    my $reserved  = 0;  # field for future use

    my $totallen  = $keylen + $vallen + $extralen;

    my $ident_hi  = 0;

    my $ident_lo  = 0;

    if ($cas) {

        $ident_hi = int($cas / 2 ** 32);

        $ident_lo = int($cas % 2 ** 32);

    }

    my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,

                   $datatype, $reserved, $totallen, $opaque, $ident_hi,

                   $ident_lo);

    my $full_msg = $msg . $extra_header . $key . $val;

    return $full_msg;

}

sub send_command {

    my $self = shift;

    die "Not enough args to send_command" unless @_ >= 4;

    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;

    my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);

    my $sent = 0;

    my $data_len =  length($full_msg);

    while ($sent < $data_len) {

        my $sent_bytes = $self->{socket}->syswrite($full_msg,

                                    $data_len - $sent > MemcachedTest::MAX_READ_WRITE_SIZE ?

                                        MemcachedTest::MAX_READ_WRITE_SIZE : ($data_len - $sent),

                                    $sent);

        last if ($sent_bytes <= 0);

        $sent += $sent_bytes;

    }

    die("Send failed:  $!") unless $data_len;

    if($sent != $data_len) {

        die("only sent $sent of " . length($full_msg) . " bytes");

    }

}

sub flush_socket {

    my $self = shift;

    $self->{socket}->flush;

}

# Send a silent command and ensure it doesn't respond.

sub send_silent {

    my $self = shift;

    die "Not enough args to send_silent" unless @_ >= 4;

    my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;

    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);

    $self->send_command(::CMD_NOOP, '', '', $opaque + 1);

    my ($ropaque, $data) = $self->_handle_single_response;

    Test::More::is($ropaque, $opaque + 1);

}

sub silent_mutation {

    my $self = shift;

    my ($cmd, $key, $value) = @_;

    $empty->($key);

    my $extra = pack "NN", 82, 0;

    $mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);

    $check->($key, 82, $value);

}

sub _handle_single_response {

    my $self = shift;

    my $myopaque = shift;

    my $hdr = "";

    while(::MIN_RECV_BYTES - length($hdr) > 0) {

        $self->{socket}->sysread(my $response, ::MIN_RECV_BYTES - length($hdr));

        $hdr .= $response;

    }

    Test::More::is(length($hdr), ::MIN_RECV_BYTES, "Expected read length");

    my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,

        $opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $hdr);

    Test::More::is($magic, ::RES_MAGIC, "Got proper response magic");

    my $cas = ($ident_hi * 2 ** 32) + $ident_lo;

    return ($opaque, '', $cas, 0) if($remaining == 0);

    # fetch the value

    my $rv="";

    while($remaining - length($rv) > 0) {

        $self->{socket}->sysread(my $buf, $remaining - length($rv));

        $rv .= $buf;

    }

    if(length($rv) != $remaining) {

        my $found = length($rv);

        die("Expected $remaining bytes, got $found");

    }

    if (defined $myopaque) {

        Test::More::is($opaque, $myopaque, "Expected opaque");

    } else {

        Test::More::pass("Implicit pass since myopaque is undefined");

    }

    if ($status) {

        die MC::Error->new($status, $rv);

    }

    return ($opaque, $rv, $cas, $keylen);

}

sub _do_command {

    my $self = shift;

    die unless @_ >= 3;

    my ($cmd, $key, $val, $extra_header, $cas) = @_;

    $extra_header = '' unless defined $extra_header;

    my $opaque = int(rand(2**32));

    $self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);

    my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);

    return ($rv, $rcas);

}

sub _incrdecr_header {

    my $self = shift;

    my ($amt, $init, $exp) = @_;

    my $amt_hi = int($amt / 2 ** 32);

    my $amt_lo = int($amt % 2 ** 32);

    my $init_hi = int($init / 2 ** 32);

    my $init_lo = int($init % 2 ** 32);

    my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,

                            $init_lo, $exp);

    return $extra_header;

}

sub _incrdecr_cas {

    my $self = shift;

    my ($cmd, $key, $amt, $init, $exp) = @_;

    my ($data, $rcas) = $self->_do_command($cmd, $key, '',

                                           $self->_incrdecr_header($amt, $init, $exp));

    my $header = substr $data, 0, 8, '';

    my ($resp_hi, $resp_lo) = unpack "NN", $header;

    my $resp = ($resp_hi * 2 ** 32) + $resp_lo;

    return $resp, $rcas;

}

sub _incrdecr {

    my $self = shift;

    my ($v, $c) = $self->_incrdecr_cas(@_);

    return $v

}

sub silent_incrdecr {

    my $self = shift;

    my ($cmd, $key, $amt, $init, $exp) = @_;

    my $opaque = 8275753;

    $mc->send_silent($cmd, $key, '', $opaque,

                     $mc->_incrdecr_header($amt, $init, $exp));

}

sub stats {

    my $self = shift;

    my $key  = shift;

    my $cas = 0;

    my $opaque = int(rand(2**32));

    $self->send_command(::CMD_STAT, $key, '', $opaque, '', $cas);

    my %rv = ();

    my $found_key = '';

    my $found_val = '';

    do {

        my ($op, $data, $cas, $keylen) = $self->_handle_single_response($opaque);

        if($keylen > 0) {

            $found_key = substr($data, 0, $keylen);

            $found_val = substr($data, $keylen);

            $rv{$found_key} = $found_val;

        } else {

            $found_key = '';

        }

    } while($found_key ne '');

    return %rv;

}

sub get {

    my $self = shift;

    my $key  = shift;

    my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');

    my $header = substr $rv, 0, 4, '';

    my $flags  = unpack("N", $header);

    return ($flags, $rv, $cas);

}

sub get_multi {

    my $self = shift;

    my @keys = @_;

    for (my $i = 0; $i < @keys; $i++) {

        $self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);

    }

    my $terminal = @keys + 10;

    $self->send_command(::CMD_NOOP, '', '', $terminal);

    my %return;

    while (1) {

        my ($opaque, $data) = $self->_handle_single_response;

        last if $opaque == $terminal;

        my $header = substr $data, 0, 4, '';

        my $flags  = unpack("N", $header);

        $return{$keys[$opaque]} = [$flags, $data];

    }

    return %return if wantarray;

    return \%return;

}

sub touch {

    my $self = shift;

    my ($key, $expire) = @_;

    my $extra_header = pack "N", $expire;

    my $cas = 0;

    return $self->_do_command(::CMD_TOUCH, $key, '', $extra_header, $cas);

}

sub gat {

    my $self   = shift;

    my $key    = shift;

    my $expire = shift;

    my $extra_header = pack "N", $expire;

    my ($rv, $cas) = $self->_do_command(::CMD_GAT, $key, '', $extra_header);

    my $header = substr $rv, 0, 4, '';

    my $flags  = unpack("N", $header);

    return ($flags, $rv, $cas);

}

sub version {

    my $self = shift;

    return $self->_do_command(::CMD_VERSION, '', '');

}

sub flush {

    my $self = shift;

    return $self->_do_command(::CMD_FLUSH, '', '');

}

sub add {

    my $self = shift;

    my ($key, $val, $flags, $expire) = @_;

    my $extra_header = pack "NN", $flags, $expire;

    my $cas = 0;

    return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);

}

sub set {

    my $self = shift;

    my ($key, $val, $flags, $expire, $cas) = @_;

    my $extra_header = pack "NN", $flags, $expire;

    return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);

}

sub _append_prepend {

    my $self = shift;

    my ($cmd, $key, $val, $cas) = @_;

    return $self->_do_command($cmd, $key, $val, '', $cas);

}

sub replace {

    my $self = shift;

    my ($key, $val, $flags, $expire) = @_;

    my $extra_header = pack "NN", $flags, $expire;

    my $cas = 0;

    return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);

}

sub delete {

    my $self = shift;

    my ($key) = @_;

    return $self->_do_command(::CMD_DELETE, $key, '');

}

sub incr {

    my $self = shift;

    my ($key, $amt, $init, $exp) = @_;

    $amt = 1 unless defined $amt;

    $init = 0 unless defined $init;

    $exp = 0 unless defined $exp;

    return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);

}

sub incr_cas {

    my $self = shift;

    my ($key, $amt, $init, $exp) = @_;

    $amt = 1 unless defined $amt;

    $init = 0 unless defined $init;

    $exp = 0 unless defined $exp;

    return $self->_incrdecr_cas(::CMD_INCR, $key, $amt, $init, $exp);

}

sub decr {

    my $self = shift;

    my ($key, $amt, $init, $exp) = @_;

    $amt = 1 unless defined $amt;

    $init = 0 unless defined $init;

    $exp = 0 unless defined $exp;

    return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);

}

sub noop {