#!/usr/bin/perl

use strict;

use warnings;

use Test::More;

use FindBin qw($Bin);

use lib "$Bin/lib";

use MemcachedTest;

my $server = new_memcached();

my $sock = $server->sock;

# command syntax:

# mg [key] [flags] [tokens]\r\n

# response:

# VA [flags] [tokens]\r\n

# data\r\n

# EN\r\n

#

# flags:

# - s: item size

# - v: return item value

# - c: return item cas

# - t: return item TTL remaining (-1 for unlimited)

# - f: client flags

# - l: last access time

# - h: whether item has been hit before

# - O: opaque to copy back.

# - k: return key

# - q: noreply semantics.

# - u: don't bump the item

# updaters:

# - N (token): vivify on miss, takes TTL as a argument

# - R (token): if token is less than item TTL win for recache

# - T (token): update remaining TTL

# FIXME: do I need a "if stale and no token sent, flip" explicit flag?

# extra response flags:

# - W: client has "won" the token

# - X: object is stale

# - Z: object has sent a winning token

#

# ms [key] [flags] [tokens]\r\n

# value\r\n

# response:

# ST [flags] [tokens]\r\n

# ST STORED, NS NOT_STORED, EX EXISTS, NF NOT_FOUND

#

# flags:

# - q: noreply

# - F (token): set client flags

# - C (token): compare CAS value

# - S (token): item size

# - T (token): TTL

# - O: opaque to copy back.

# - k: return key

# - I: invalid. set-to-invalid if CAS is older than it should be.

# Not implemented:

# - E: add if not exists (influences other options)

# - A: append (exclusive)

# - P: prepend (exclusive)

# - L: replace (exclusive)

# - incr/decr? pushing it, I guess.

#

# md [key] [flags] [tokens]\r\n

# response:

# DE [flags] [tokens]

# flags:

# - q: noreply

# - T (token): updates TTL

# - C (token): compare CAS value

# - I: invalidate. mark as stale, bumps CAS.

# - O: opaque to copy back.

# - k: return key

#

# mn\r\n

# response:

# EN

# metaget tests

# basic test

# - raw mget

# - raw mget miss

# - raw mget bad key

{

    print $sock "set foo 0 0 2\r\nhi\r\n";

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

    print $sock "me none\r\n";

    is(scalar <$sock>, "EN\r\n", "raw mget miss");

    print $sock "me foo\r\n";

    like(scalar <$sock>, qr/^ME foo /, "raw mget result");

    # bleed the EN off the socket.

    my $dud = scalar <$sock>;

}

# mget with arguments

# - set some specific TTL and get it back (within reason)

# - get cas

# - autovivify and bit-win

{

    print $sock "set foo2 0 90 2\r\nho\r\n";

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

    mget_is({ sock => $sock,

              flags => 'sv',

              etokens => [2] },

            'foo2', 'ho', "retrieved test value");

    my $res = mget($sock, 'foo2', 'stv');

}

# lease-test, use two sockets? one socket should be fine, actually.

# - get a win on autovivify

# - get a loss on the same command

# - have a set/cas fail

# - have a cas succeed

# - repeat for "triggered on TTL"

# - test just modifying the TTL (touch)

# - test fetching without value

{

    my $res = mget($sock, 'needwin', 'scvNt 30');

    like($res->{flags}, qr/scvNt/, "got main flags back");

    like($res->{flags}, qr/W/, "got a win result");

    unlike($res->{flags}, qr/Z/, "no token already sent warning");

    # asked for size and TTL. size should be 0, TTL should be > 0 and < 30

    is($res->{tokens}->[0], 0, "got zero size: autovivified response");

    my $ttl = $res->{tokens}->[1];

    ok($ttl > 0 && $ttl <= 30, "auto TTL is within requested window");

    # try to fail this time.

    {

        my $res = mget($sock, 'needwin', 'stcvN 30');

        ok(keys %$res, "got a non-empty response");

        unlike($res->{flags}, qr/W/, "not a win result");

        like($res->{flags}, qr/Z/, "object already sent win result");

    }

    # set back with the wrong CAS

    print $sock "ms needwin CST 5000 2 120\r\nnu\r\n";

    like(scalar <$sock>, qr/^EX /, "failed to SET: CAS didn't match");

    # again, but succeed.

    # TODO: the actual CAS command should work here too?

    my $cas = $res->{tokens}->[1];

    print $sock "ms needwin CST $cas 2 120\r\nmu\r\n";

    like(scalar <$sock>, qr/^ST /, "SET: CAS matched");

    # now we repeat the original mget, but the data should be different.

    $res = mget($sock, 'needwin', 'sktcvN 30');

    ok(keys %$res, "not a miss");

    like($res->{flags}, qr/sktcvN/, "got main flags back");

    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");

    is($res->{tokens}->[1], 'needwin', "key matches");

    $ttl = $res->{tokens}->[2];

    ok($ttl > 100 && $ttl <= 120, "TTL is within requested window: $ttl");

    is($res->{val}, "mu", "value matches");

    # now we do the whole routine again, but for "triggered on TTL being low"

    # TTL was set to 120 just now, so anything lower than this should trigger.

    $res = mget($sock, 'needwin', 'stcvNR 30 130');

    like($res->{flags}, qr/stcvNR/, "got main flags back");

    like($res->{flags}, qr/W/, "got a win result");

    unlike($res->{flags}, qr/Z/, "no token already sent warning");

    is($res->{val}, "mu", "value matches");

    # try to fail this time.

    {

        my $res = mget($sock, 'needwin', 'stcvNR 30 130');

        ok(keys %$res, "got a non-empty response");

        unlike($res->{flags}, qr/W/, "not a win result");

        like($res->{flags}, qr/Z/, "object already sent win result");

        is($res->{val}, "mu", "value matches");

    }

    # again, but succeed.

    $cas = $res->{tokens}->[2];

    print $sock "ms needwin CST $cas 4 300\r\nzuuu\r\n";

    like(scalar <$sock>, qr/^ST /, "SET: CAS matched");

    # now we repeat the original mget, but the data should be different.

    $res = mget($sock, 'needwin', 'stcvN 30');

    ok(keys %$res, "not a miss");

    like($res->{flags}, qr/stcvN/, "got main flags back");

    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");

    $ttl = $res->{tokens}->[1];

    ok($ttl > 250 && $ttl <= 300, "TTL is within requested window");

    ok($res->{tokens}->[0] == 4, "Size returned correctly");

    is($res->{val}, "zuuu", "value matches: " . $res->{val});

}

# test get-and-touch mode

{

    # Set key with lower initial TTL.

    print $sock "ms gatkey ST 4 100\r\nooom\r\n";

    like(scalar <$sock>, qr/^ST /, "set gatkey");

    # Coolish side feature and/or bringer of bugs: 't' before 'T' gives TTL

    # before adjustment. 'T' before 't' gives TTL after adjustment.

    # Here we want 'T' before 't' to ensure we did adjust the value.

    my $res = mget($sock, 'gatkey', 'svTt 300');

    ok(keys %$res, "not a miss");

    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");

    my $ttl = $res->{tokens}->[1];

    ok($ttl > 280 && $ttl <= 300, "TTL is within requested window: $ttl");

}

# test no-value mode

{

    # Set key with lower initial TTL.

    print $sock "ms hidevalue ST 4 100\r\nhide\r\n";

    like(scalar <$sock>, qr/^ST /, "set hidevalue");

    my $res = mget($sock, 'hidevalue', 'st');

    ok(keys %$res, "not a miss");

    is($res->{val}, '', "no value returned");

    $res = mget($sock, 'hidevalue', 'stv');

    ok(keys %$res, "not a miss");

    is($res->{val}, 'hide', "real value returned");

}

# test hit-before? flag

{

    print $sock "ms hitflag ST 3 100\r\nhit\r\n";

    like(scalar <$sock>, qr/^ST /, "set hitflag");

    my $res = mget($sock, 'hitflag', 'sth');

    ok(keys %$res, "not a miss");

    is($res->{tokens}->[2], 0, "not been hit before");

    $res = mget($sock, 'hitflag', 'sth');

    ok(keys %$res, "not a miss");

    is($res->{tokens}->[2], 1, "been hit before");

}

# test no-update flag

{

    print $sock "ms noupdate ST 3 100\r\nhit\r\n";

    like(scalar <$sock>, qr/^ST /, "set noupdate");

    my $res = mget($sock, 'noupdate', 'stuh');

    ok(keys %$res, "not a miss");

    is($res->{tokens}->[2], 0, "not been hit before");

    # _next_ request should show a hit.

    # gets modified here but returns previous state.

    $res = mget($sock, 'noupdate', 'sth');

    is($res->{tokens}->[2], 0, "still not a hit");

    $res = mget($sock, 'noupdate', 'stuh');

    is($res->{tokens}->[2], 1, "finally a hit");

}

# test last-access time

{

    print $sock "ms la_test ST 2 100\r\nla\r\n";

    like(scalar <$sock>, qr/^ST /, "set la_test");

    sleep 2;

    my $res = mget($sock, 'la_test', 'stl');

    ok(keys %$res, "not a miss");

    print STDERR "Last access is: ", $res->{tokens}->[2], "\n";

    isnt($res->{tokens}->[2], 0, "been over a second since most recently accessed");

    # TODO: Can't test re-accessing since it requires a long wait right now.

    # I want to adjust the LA time accuracy in a deliberate change.

}

# high level tests:

# - mget + mset with serve-stale

# - set a value

# - mget it back. should be no XZW tokens

# - invalidate via mdelete and mget/revalidate with mset

#   - remember failure scenarios!

#     - TTL timed out?

#     - CAS too high?

#   - also test re-setting as stale (CAS is below requested)

#     - this should probably be conditional.

{

    diag "starting serve stale with mdelete";

    my ($ttl, $cas, $res);

    print $sock "set toinv 0 0 3\r\nmoo\r\n";

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

    $res = mget($sock, 'toinv', 'sv');

    unlike($res->{flags}, qr/[XWZ]/, "no extra flags");

    # Lets mark the sucker as invalid, and drop its TTL to 30s

    diag "running mdelete";

    print $sock "md toinv IT 30\r\n";

    like(scalar <$sock>, qr/^DE /, "mdelete'd key");

    # TODO: decide on if we need an explicit flag for "if I fetched a stale

    # value, does winning matter?

    # I think it's probably fine. clients can always ignore the win, or we can

    # add an option later to "don't try to revalidate if stale", perhaps.

    $res = mget($sock, 'toinv', 'stcv');

    ok(keys %$res, "not a miss");

    like($res->{flags}, qr/stcv/, "got main flags back");

    like($res->{flags}, qr/W/, "won the recache");

    like($res->{flags}, qr/X/, "item is marked stale");

    $ttl = $res->{tokens}->[1];

    ok($ttl > 0 && $ttl <= 30, "TTL is within requested window");

    ok($res->{tokens}->[0] == 3, "Size returned correctly");

    is($res->{val}, "moo", "value matches");

    diag "trying to fail then stale set via mset";

    print $sock "ms toinv STC 1 90 0\r\nf\r\n";

    like(scalar <$sock>, qr/^EX /, "failed to SET: low CAS didn't match");

    print $sock "ms toinv SITC 1 90 0\r\nf\r\n";

    like(scalar <$sock>, qr/^ST /, "SET an invalid/stale item");

    diag "confirm item still stale, and TTL wasn't raised.";

    $res = mget($sock, 'toinv', 'stcv');

    like($res->{flags}, qr/X/, "item is marked stale");

    like($res->{flags}, qr/Z/, "win token already sent");

    unlike($res->{flags}, qr/W/, "didn't win: token already sent");

    $ttl = $res->{tokens}->[1];

    ok($ttl > 0 && $ttl <= 30, "TTL wasn't modified");

    # TODO: CAS too high?

    diag "do valid mset";

    $cas = $res->{tokens}->[2];

    print $sock "ms toinv STC 1 90 $cas\r\ng\r\n";

    like(scalar <$sock>, qr/^ST /, "SET over the stale item");

    $res = mget($sock, 'toinv', 'stcv');

    ok(keys %$res, "not a miss");

    unlike($res->{flags}, qr/[WXZ]/, "no stale, win, or tokens");

    $ttl = $res->{tokens}->[1];

    ok($ttl > 30 && $ttl <= 90, "TTL was modified");

    ok($cas != $res->{tokens}->[2], "CAS was updated");

    is($res->{tokens}->[0], 1, "size updated");

    is($res->{val}, "g", "value was updated");

}

# Quiet flag suppresses most output. Badly invalid commands will still

# generate something. Not weird to parse like 'noreply' token was...

# mget's with hits should return real data.

{

    diag "testing quiet flag";

    print $sock "ms quiet Sq 2\r\nmo\r\n";

    print $sock "md quiet q\r\n";

    print $sock "mg quiet svq\r\n";

    diag "now purposefully cause an error\r\n";

    print $sock "ms quiet S\r\n";

    like(scalar <$sock>, qr/^CLIENT_ERROR/, "resp not ST, DE, or EN");

    # Now try a pipelined get. Throw an mnop at the end

    print $sock "ms quiet Sq 2\r\nbo\r\n";

    print $sock "mg quiet svq\r\nmg quiet svq\r\nmg quietmiss svq\r\nmn\r\n";

    # Should get back VA/data/VA/data/EN

    like(scalar <$sock>, qr/^VA svq 2/, "get response");

    like(scalar <$sock>, qr/^bo/, "get value");

    like(scalar <$sock>, qr/^VA svq 2/, "get response");

    like(scalar <$sock>, qr/^bo/, "get value");

    like(scalar <$sock>, qr/^EN/, "end token");

}

{

    my $k = 'otest';

    diag "testing mget opaque";

    print $sock "ms $k ST 2 100\r\nra\r\n";

    like(scalar <$sock>, qr/^ST /, "set $k");

    my $res = mget($sock, $k, 'stvO opaque');

    is($res->{tokens}->[2], 'opaque', "O flag returned opaque");

}

{

    diag "flag and token count errors";

    print $sock "mg foo sv extratoken\r\n";

    like(scalar <$sock>, qr/^CLIENT_ERROR incorrect number of tokens/, "too many tokens");

    print $sock "mg foo svN\r\n";

    like(scalar <$sock>, qr/^CLIENT_ERROR incorrect number of tokens/, "too few tokens");

    print $sock "mg foo mooooo\r\n";

    like(scalar <$sock>, qr/^CLIENT_ERROR invalid or duplicate flag/, "gone silly with flags");

}

# TODO: move wait_for_ext into Memcached.pm

sub wait_for_ext {

    my $sock = shift;

    my $target = shift || 0;

    my $sum = $target + 1;

    while ($sum > $target) {

        my $s = mem_stats($sock, "items");

        $sum = 0;

        for my $key (keys %$s) {

            if ($key =~ m/items:(\d+):number/) {

                # Ignore classes which can contain extstore items

                next if $1 < 3;

                $sum += $s->{$key};

            }

        }

        sleep 1 if $sum > $target;

    }

}

my $ext_path;

# Do a basic extstore test if enabled.

if (supports_extstore()) {

    diag "mget + extstore tests";

    $ext_path = "/tmp/extstore.$$";

    my $server = new_memcached("-m 64 -U 0 -o ext_page_size=8,ext_wbuf_size=2,ext_threads=1,ext_io_depth=2,ext_item_size=512,ext_item_age=2,ext_recache_rate=10000,ext_max_frag=0.9,ext_path=$ext_path:64m,slab_automove=0,ext_compact_under=1,no_lru_crawler");

    my $sock = $server->sock;

    my $value;

    {

        my @chars = ("C".."Z");

        for (1 .. 20000) {

            $value .= $chars[rand @chars];

        }

    }

    my $keycount = 10;

    for (1 .. $keycount) {

        print $sock "set nfoo$_ 0 0 20000 noreply\r\n$value\r\n";

    }

    wait_for_ext($sock);

    mget_is({ sock => $sock,

              flags => 'sv',

              etokens => [20000] },

            'nfoo1', $value, "retrieved test value");

    my $stats = mem_stats($sock);

    cmp_ok($stats->{get_extstore}, '>', 0, 'one object was fetched');

    my $ovalue = $value;

    for (1 .. 4) {

        $value .= $ovalue;

    }

    # Fill to eviction.

    $keycount = 1000;

    for (1 .. $keycount) {

        print $sock "set mfoo$_ 0 0 100000 noreply\r\n$value\r\n";

        # wait to avoid memory evictions

        wait_for_ext($sock, 1) if ($_ % 250 == 0);

    }

    print $sock "mg mfoo1 sv\r\n";

    is(scalar <$sock>, "EN\r\n");

    print $sock "mg mfoo1 svq\r\nmn\r\n";

    is(scalar <$sock>, "EN\r\n");

    $stats = mem_stats($sock);

    cmp_ok($stats->{miss_from_extstore}, '>', 0, 'at least one miss');

}

###

# takes hash:

# - sock

# - args (metaget flags)

# - array of tokens

# - array of expected response tokens

# returns hash:

# - win (if won a condition)

# - array of tokens

# - value, etc?

# useful to chain together for further requests.

# works only with single line values. no newlines in value.

# FIXME: some workaround for super long values :|

# TODO: move this to lib/MemcachedTest.pm

sub mget_is {

    # single line values only

    my ($o, $key, $val, $msg) = @_;

    my $dval = defined $val ? "'$val'" : "<undef>";

    $msg ||= "$key == $dval";

    my $s = $o->{sock};

    my $flags = $o->{flags};

    # sometimes response flags can differ from request flags.

    my $eflags = $o->{eflags} || $flags;

    my $tokens = exists $o->{tokens} ? join(' ', @{$o->{tokens}}) : '';

    my $etokens = exists $o->{etokens} ? join(' ', @{$o->{etokens}}) : '';

    print $s "mg $key $flags $tokens\r\n";

    if (! defined $val) {

        my $line = scalar <$s>;

        if ($line =~ /^VA/) {

            $line .= scalar(<$s>) . scalar(<$s>);

        }

        Test::More::is($line, "EN\r\n", $msg);

    } else {

        my $len = length($val);

        my $body = scalar(<$s>);

        my $expected = "VA $eflags $etokens\r\n$val\r\nEN\r\n";

        if (!$body || $body =~ /^EN/) {

            Test::More::is($body, $expected, $msg);

            return;

        }

        $body .= scalar(<$s>) . scalar(<$s>);

        Test::More::is($body, $expected, $msg);

        return mget_res($body);

    }

    return {};

}

sub mget {

    my $s = shift;

    my $key = shift;

    my $flags = shift;

    my $tokens = join(' ', @_);

    print $s "mg $key $flags ", $tokens, "\r\n";

    my $header = scalar(<$s>);

    my $val = "\r\n";

    if ($flags =~ m/v/) {

        $val = scalar(<$s>);

    }

    my $end = scalar(<$s>);

    return mget_res($header . $val);

}

# parse out a response

sub mget_res {

    my $resp = shift;

    my %r = ();

    if ($resp =~ m/^VA ([^\s]+) ([^\r]+)\r\n(.*)\r\n/gm) {

        $r{flags} = $1;

        $r{val} = $3;

        $r{tokens} = [split(/ /, $2)];

    }

    return \%r;

}

done_testing();

END {

    unlink $ext_path if $ext_path;

}