1#!/usr/bin/env perl23use strict;4use warnings;5use Test::More;6use FindBin qw($Bin);7use lib "$Bin/lib";8use MemcachedTest;9use Data::Dumper qw/Dumper/;1011my $server = new_memcached();12my $sock = $server->sock;1314# command syntax:15# mg [key] [flags]\r\n16# response:17# VA [size] [flags]\r\n18# data\r\n19# or:20# HD [flags]\r\n21# or:22# EN\r\n23# flags are single 'f' or 'f1234' or 'fTEXT'24#25# flags:26# - s: return item size27# - v: return item value28# - c: return item cas29# - t: return item TTL remaining (-1 for unlimited)30# - f: return client flags31# - l: return last access time32# - h: return whether item has been hit before33# - O(token): opaque to copy back.34# - k: return key35# - q: noreply semantics.36# - u: don't bump the item in LRU37# - C(token): if does not match, do never return value38# updaters:39# - N(token): vivify on miss, takes TTL as a argument40# - R(token): if token is less than item TTL win for recache41# - T(token): update remaining TTL42# FIXME: do I need a "if stale and no token sent, flip" explicit flag?43# extra response flags:44# - W: client has "won" the token45# - X: object is stale46# - Z: object has sent a winning token47#48# ms [key] [valuelen] [flags]\r\n49# value\r\n50# response:51# HD [flags]\r\n52# HD STORED, NS NOT_STORED, EX EXISTS, NF NOT_FOUND53#54# flags:55# - q: noreply56# - F(token): set client flags57# - C(token): compare CAS value58# - T(token): TTL59# - O(token): opaque to copy back.60# - k: return key61# - I: invalid. set-to-invalid if CAS is older than it should be.62# - M(token): mode switch.63#   - default to "set"64#   - E: add mode65#   - A: append mode66#   - P: prepend mode67#   - R: replace mode68#   - S: set mode - not necessary, but could be useful for clients.69#70# md [key] [flags]\r\n71# response:72# HD [flags]73# flags:74# - q: noreply75# - T(token): updates TTL76# - C(token): compare CAS value77# - I: invalidate. mark as stale, bumps CAS.78# - O(token): opaque to copy back.79# - k: return key80#81# ma [key] [flags]\r\n82# response:83# HD [flags]\r\n84# HD, NS NOT_STORED, EX EXISTS, NF NOT_FOUND85# or:86# VA [size] [flags]\r\n87# data\r\n88#89# flags:90# q: noreply91# N(token): autovivify with supplied TTL92# J(token): initial value to use if autovivified93# D(token): delta to apply. default 194# T(token): update TTL95# C(token): CAS must match96# M(token): mode switch.97#  - default to "incr"98#  - I: incr99#  - +: incr100#  - D: decr101#  - -: decr102# t: return TTL103# c: return current CAS104# v: return new value105#106# All commands:107# E(token): if supplied, set as CAS field on successful update operation108#109# mn\r\n110# response:111# MN\r\n112113# Test basic parser.114{115    print $sock " \n";116    is(scalar <$sock>, "CLIENT_ERROR bad command line format\r\n", "error from blank command");117}118119{120    print $sock "set foo 0 0 2\r\nhi\r\n";121    is(scalar <$sock>, "STORED\r\n", "stored test value");122123    print $sock "me none\r\n";124    is(scalar <$sock>, "EN\r\n", "raw mget miss");125126    print $sock "me foo\r\n";127    like(scalar <$sock>, qr/^ME foo /, "raw mget result");128}129130# mdelete had excess space before newline.131{132    print $sock "md deltest\r\n";133    is(scalar <$sock>, "NF\r\n", "delete status is correct");134    print $sock "md foo\r\n";135    is(scalar <$sock>, "HD\r\n", "delete status is correct");136}137138# mget with arguments139# - set some specific TTL and get it back (within reason)140# - get cas141# - autovivify and bit-win142143{144    print $sock "set foo2 0 90 2\r\nho\r\n";145    is(scalar <$sock>, "STORED\r\n", "stored test value");146147    mget_is({ sock => $sock,148              flags => 's v',149              eflags => 's2' },150            'foo2', 'ho', "retrieved test value");151152    # FIXME: figure out what I meant to do here.153    #my $res = mget($sock, 'foo2', 's t v');154}155156{157    note "ensure mset flag reflection doesn't bleed";158    # mset return flags are internally implemented by stashing the flags in159    # the write buffer then re-parsing them later (to preserve order...) so we160    # need to check extra that I'm not being a dingus and forgetting a break161    # statement.162    print $sock "ms a 1\r\n1\r\n";163    is(scalar <$sock>, "HD\r\n", "no flags");164165    print $sock "ms a 1 c\r\n1\r\n";166    like(scalar <$sock>, qr/^HD c\d+\r\n/, "c flag");167168    print $sock "ms a 1 Otest\r\n1\r\n";169    like(scalar <$sock>, qr/^HD Otest\r\n/, "O flag");170171    print $sock "ms a 1 s\r\n1\r\n";172    like(scalar <$sock>, qr/^HD s1\r\n/, "s flag");173174    print $sock "ms a 1 k\r\n1\r\n";175    like(scalar <$sock>, qr/^HD ka\r\n/, "k flag");176}177178{179    note "client flags";180    my @fset = (0, 123, 2**16-1, 2**31);181    my $stats = mem_stats($sock, "settings");182    if ($stats->{client_flags_size} == 8) {183        note "extra tests for large flags";184        push(@fset, 2**32);185        push(@fset, 2**48);186    }187    for my $flags (@fset) {188        print $sock "ms a 1 F$flags\r\n1\r\n";189        is(scalar <$sock>, "HD\r\n", "client flags $flags set");190        my $res = mget($sock, 'a', 'f');191        is(get_flag($res, 'f'), $flags, "client flags $flags returned");192    }193}194195{196    note "basic mset CAS";197    my $key = "msetcas";198    print $sock "ms $key 2\r\nbo\r\n";199    like(scalar <$sock>, qr/^HD/, "set test key");200201    my $res = mget($sock, $key, 'c');202    ok(get_flag($res, 'c'), "got a cas value back");203204    my $cas = get_flag($res, 'c');205    my $badcas = $cas + 10;206    print $sock "ms $key 2 c C$badcas\r\nio\r\n";207    like(scalar <$sock>, qr/^EX c0/, "zeroed out cas on return");208209    print $sock "ms $key 2 c C$cas\r\nio\r\n";210    like(scalar <$sock>, qr/^HD c\d+/, "success on correct cas");211}212213subtest 'mset with E CAS override' => sub {214    my $key = "msetE";215    my $cas = "973";216    print $sock "ms $key 2 E$cas\r\nji\r\n";217    like(scalar <$sock>, qr/^HD/, "set test key");218219    my $res = mget($sock, $key, 'c');220    is(get_flag($res, 'c'), $cas, "got correct cas back");221222    my $cas2 = "4000";223    print $sock "ms $key 2 c C$cas E$cas2\r\nlo\r\n";224    like(scalar <$sock>, qr/^HD c$cas2/, "overwrite test key with new CAS");225};226227subtest 'mget vivify with CAS override' => sub {228    my $k = "mgetE";229    my $cas = "9876";230    my $res = mget($sock, $k, "s c v N30 t E$cas");231    ok(find_flags($res, 'sctW'), "got expected flag results");232    is(get_flag($res, 'Z'), "", "no already sent token");233    is(get_flag($res, 'c'), $cas, "CAS was properly overridden");234235    # ensure we ignore the E when nothing was supposed to change236    $res = mget($sock, $k, "c E5");237    ok(find_flags($res, 'cZ'), "got expected flag results");238    is(get_flag($res, 'c'), $cas, "CAS was not overridden");239};240241subtest 'mdelete with CAS override' => sub {242    my $k = "mdelE";243    my $cas = "1234";244245    print $sock "ms $k 2 E$cas\r\nmE\r\n";246    like(scalar <$sock>, qr/^HD/, "set test key");247248    my $res = mget($sock, $k, 'c');249    is(get_flag($res, 'c'), $cas, "got cas value back");250251    my $ncas = "5678";252    # update the CAS and invalidate the delete253    print $sock "md $k C$cas E$ncas I\r\n";254    my $dres = scalar <$sock>;255    like($dres, qr/^HD/, "mdeleted key");256257    $res = mget($sock, $k, 'c');258    is(get_flag($res, 'c'), $ncas, "got cas value back");259};260261subtest 'marith with CAS override' => sub {262    my $k = "maE";263    my $cas = "4321";264265    # cas override during autoviv266    my $res = marith($sock, $k, "v N0 c E$cas J5");267    is($res->{val}, '5', "ma seeded");268    is(get_flag($res, 'c'), $cas, "CAS came back");269270    $res = marith($sock, $k, "C$cas c v");271    is($res->{val}, '6', "ma incremented");272    # We didn't specify what the new CAS should be, so when the number changed273    # it got a new internal CAS274    isnt(get_flag($res, 'c'), $cas, "CAS came back");275276    my $ncas = "8765";277    $res = marith($sock, $k, "c v E$ncas");278    is($res->{val}, '7', "ma incremented");279    is(get_flag($res, 'c'), $ncas, "CAS came back");280};281282{283    note "mdelete with cas";284    my $key = "mdeltest";285    print $sock "ms $key 2\r\nzo\r\n";286    like(scalar <$sock>, qr/^HD/, "set test key");287288    my $res = mget($sock, $key, 'c');289    ok(get_flag($res, 'c'), "got a cas value back");290291    my $cas = get_flag($res, 'c');292    my $badcas = $cas + 10;293    print $sock "md $key C$badcas\r\n";294    like(scalar <$sock>, qr/^EX/, "mdelete fails for wrong CAS");295    print $sock "md $key C$cas\r\n";296    like(scalar <$sock>, qr/^HD/, "mdeleted key");297}298299{300    note "encoded binary keys";301    # 44OG44K544OI is "tesuto" in katakana302    my $tesuto = "44OG44K544OI";303    print $sock "ms $tesuto 2 b\r\npo\r\n";304    like(scalar <$sock>, qr/^HD/, "set with encoded key");305306    my $res = mget($sock, $tesuto, 'v');307    ok(! exists $res->{val}, "encoded key doesn't exist");308    $res = mget($sock, $tesuto, 'b v k');309    ok(exists $res->{val}, "decoded key exists");310    ok(get_flag($res, 'k') eq $tesuto, "key returned encoded");311312    # TODO: test k is returned properly from ms.313    # validate the store data is smaller somehow?314}315316{317    note "marithmetic tests";318    print $sock "ma mo\r\n";319    like(scalar <$sock>, qr/^NF\r/, "incr miss");320321    print $sock "ma mo D1\r\n";322    like(scalar <$sock>, qr/^NF\r/, "incr miss with argument");323324    print $sock "set mo 0 0 1\r\n1\r\n";325    like(scalar <$sock>, qr/^STORED/, "stored with set");326327    print $sock "ma mo\r\n";328    like(scalar <$sock>, qr/^HD\r/, "incr'd a set value");329330    print $sock "set mo 0 0 1\r\nq\r\n";331    like(scalar <$sock>, qr/^STORED/, "stored with set");332333    print $sock "ma mo\r\n";334    like(scalar <$sock>, qr/^CLIENT_ERROR /, "cannot incr non-numeric value");335336    print $sock "ma mu N90\r\n";337    like(scalar <$sock>, qr/^HD\r/, "incr with seed");338    my $res = mget($sock, 'mu', 's t v Ofoo k');339    ok(keys %$res, "not a miss");340    ok(find_flags($res, 'st'), "got main flags back");341    is($res->{val}, '0', "seeded default value");342    my $ttl = get_flag($res, 't');343    ok($ttl > 10 && $ttl < 91, "TTL is within requested window: $ttl");344345    $res = marith($sock, 'mu', 'T300 v t');346    ok(keys %$res, "not a miss");347    is($res->{val}, '1', "incremented once");348    $ttl = get_flag($res, 't');349    ok($ttl > 150 && $ttl < 301, "TTL is within requested window: $ttl");350351    $res = marith($sock, 'mi', 'N0 J13 v t');352    ok(keys %$res, "not a miss");353    is($res->{val}, '13', 'seeded on a missed value');354    $res = marith($sock, 'mi', 'N0 J13 v t');355    is($res->{val}, '14', 'incremented from seed');356357    $res = marith($sock, 'mi', 'N0 J13 v t D30');358    is($res->{val}, '44', 'specific increment');359360    $res = marith($sock, 'mi', 'N0 J13 v t MD D22');361    is($res->{val}, '22', 'specific decrement');362363    $res = marith($sock, 'mi', 'N0 J13 v t MD D9000');364    is($res->{val}, '0', 'land at 0 for over-decrement');365366    print $sock "ma mi q D1\r\nmn\r\n";367    like(scalar <$sock>, qr/^MN\r/, "quiet increment");368369    # CAS routines.370    $res = marith($sock, 'mc', 'N0 c v');371    my $cas = get_flag($res, 'c');372    # invalid CAS.373    print $sock "ma mc N0 C99999 v\r\n";374    like(scalar <$sock>, qr/^EX/, 'CAS mismatch');375    # valid CAS376    $res = marith($sock, 'mc', "N0 C$cas c v");377    my $ncas = get_flag($res, 'c');378    is($res->{val}, '1', 'ticked after CAS increment');379    isnt($cas, $ncas, 'CAS increments during modification');380}381382# mset tests with mode switch flag (M)383384{385    note "mset mode switch";386    print $sock "ms modedefault 2 T120\r\naa\r\n";387    like(scalar <$sock>, qr/^HD/, "default set mode");388    mget_is({ sock => $sock,389              flags => 's v',390              eflags => 's2' },391            'modedefault', 'aa', "retrieved test value");392393    # Fail an add394    print $sock "ms modedefault 2 T120 ME\r\naa\r\n";395    like(scalar <$sock>, qr/^NS/, "add mode gets NOT_STORED");396    # Win an add397    print $sock "ms modetest 2 T120 ME\r\nbb\r\n";398    like(scalar <$sock>, qr/^HD/, "add mode");399    mget_is({ sock => $sock,400              flags => 's v',401              eflags => 's2' },402            'modetest', 'bb', "retrieved test value");403404    # append405    print $sock "ms modetest 2 T120 MA\r\ncc\r\n";406    like(scalar <$sock>, qr/^HD/, "append mode");407    mget_is({ sock => $sock,408              flags => 's v',409              eflags => 's4' },410            'modetest', 'bbcc', "retrieved test value");411    # prepend412    print $sock "ms modetest 2 T120 MP\r\naa\r\n";413    like(scalar <$sock>, qr/^HD/, "append mode");414    mget_is({ sock => $sock,415              flags => 's v',416              eflags => 's6' },417            'modetest', 'aabbcc', "retrieved test value");418419    # replace420    print $sock "ms modereplace 2 T120 MR\r\nzz\r\n";421    like(scalar <$sock>, qr/^NS/, "fail replace mode");422    print $sock "ms modetest 2 T120 MR\r\nxx\r\n";423    like(scalar <$sock>, qr/^HD/, "replace mode");424    mget_is({ sock => $sock,425              flags => 's v',426              eflags => 's2' },427            'modetest', 'xx', "retrieved test value");428429    # explicit set430    print $sock "ms modetest 2 T120 MS\r\nyy\r\n";431    like(scalar <$sock>, qr/^HD/, "force set mode");432433    # invalid mode434    print $sock "ms modetest 2 T120 MZ\r\ntt\r\n";435    like(scalar <$sock>, qr/^CLIENT_ERROR /, "invalid mode");436}437438# Append tests439{440    print $sock "ms appendcas 2 MA C5000 T30\r\nhi\r\n";441    is(scalar <$sock>, "NS\r\n", "ms append with bad cas");442    print $sock "ms appendcas 2 MA T30\r\nhi\r\n";443    is(scalar <$sock>, "NS\r\n", "ms append straight miss");444    print $sock "ms appendcas 2 T30 c\r\nho\r\n";445    my $res = <$sock>;446    my $r = parse_res($res);447    my $cas = get_flag($r, 'c');448    print $sock "ms appendcas 2 MA C$cas T30\r\nhi\r\n";449    is(scalar <$sock>, "HD\r\n", "ms append with good cas");450451    # Autovivify append.452    print $sock "ms appendviv 2 MA N30\r\nmo\r\n";453    is(scalar <$sock>, "HD\r\n", "ms append with autovivify");454    mget_is({ sock => $sock,455              flags => 's v',456              eflags => 's2' },457             'appendviv', 'mo', "retrieved autoviv append");458459    # Test full size on append.460    print $sock "ms appendviv 2 MA N30 s\r\nko\r\n";461    is(scalar <$sock>, "HD s4\r\n", "got appended length");462}463464# lease-test, use two sockets? one socket should be fine, actually.465# - get a win on autovivify466# - get a loss on the same command467# - have a set/cas fail468# - have a cas succeed469# - repeat for "triggered on TTL"470# - test just modifying the TTL (touch)471# - test fetching without value472{473    my $res = mget($sock, 'needwin', 's c v N30 t');474    like($res->{flags}, qr/[scvNt]+/, "got main flags back");475    like($res->{flags}, qr/W/, "got a win result");476    unlike($res->{flags}, qr/Z/, "no token already sent warning");477478    # asked for size and TTL. size should be 0, TTL should be > 0 and < 30479    is($res->{size}, 0, "got zero size: autovivified response");480    my $ttl = get_flag($res, 't');481    ok($ttl > 0 && $ttl <= 30, "auto TTL is within requested window: $ttl");482483    # try to fail this time.484    {485        my $res = mget($sock, 'needwin', 's t c v N30');486        ok(keys %$res, "got a non-empty response");487        unlike($res->{flags}, qr/W/, "not a win result");488        like($res->{flags}, qr/Z/, "object already sent win result");489    }490491    # set back with the wrong CAS492    print $sock "ms needwin 2 C5000 T120\r\nnu\r\n";493    like(scalar <$sock>, qr/^EX/, "failed to SET: CAS didn't match");494495    # again, but succeed.496    # TODO: the actual CAS command should work here too?497    my $cas = get_flag($res, 'c');498    print $sock "ms needwin 2 C$cas T120\r\nmu\r\n";499    like(scalar <$sock>, qr/^HD/, "SET: CAS matched");500501    # now we repeat the original mget, but the data should be different.502    $res = mget($sock, 'needwin', 's k t c v N30');503    ok(keys %$res, "not a miss");504    ok(find_flags($res, 'sktc'), "got main flags back");505    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");506    is(get_flag($res, 'k'), 'needwin', "key matches");507    $ttl = get_flag($res, 't');508    ok($ttl > 100 && $ttl <= 120, "TTL is within requested window: $ttl");509    is($res->{val}, "mu", "value matches");510511    # now we do the whole routine again, but for "triggered on TTL being low"512    # TTL was set to 120 just now, so anything lower than this should trigger.513    $res = mget($sock, 'needwin', 's t c v N30 R130');514    ok(find_flags($res, 'stc'), "got main flags back");515    like($res->{flags}, qr/W/, "got a win result");516    unlike($res->{flags}, qr/Z/, "no token already sent warning");517    is($res->{val}, "mu", "value matches");518519    # try to fail this time.520    {521        my $res = mget($sock, 'needwin', 's t c v N30 R130');522        ok(keys %$res, "got a non-empty response");523        unlike($res->{flags}, qr/W/, "not a win result");524        like($res->{flags}, qr/Z/, "object already sent win result");525        is($res->{val}, "mu", "value matches");526    }527528    # again, but succeed.529    $cas = get_flag($res, 'c');530    print $sock "ms needwin 4 C$cas T300\r\nzuuu\r\n";531    like(scalar <$sock>, qr/^HD/, "SET: CAS matched");532533    # now we repeat the original mget, but the data should be different.534    $res = mget($sock, 'needwin', 's t c v N30');535    ok(keys %$res, "not a miss");536    ok(find_flags($res, 'stc'), "got main flags back");537    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");538    $ttl = get_flag($res, 't');539    ok($ttl > 250 && $ttl <= 300, "TTL is within requested window");540    ok($res->{size} == 4, "Size returned correctly");541    is($res->{val}, "zuuu", "value matches: " . $res->{val});542543}544545# test get-and-touch mode546{547    # Set key with lower initial TTL.548    print $sock "ms gatkey 4 T100\r\nooom\r\n";549    like(scalar <$sock>, qr/^HD/, "set gatkey");550551    # Coolish side feature and/or bringer of bugs: 't' before 'T' gives TTL552    # before adjustment. 'T' before 't' gives TTL after adjustment.553    # Here we want 'T' before 't' to ensure we did adjust the value.554    my $res = mget($sock, 'gatkey', 's v T300 t');555    ok(keys %$res, "not a miss");556    unlike($res->{flags}, qr/[WZ]/, "not a win or token result");557    my $ttl = get_flag($res, 't');558    ok($ttl > 280 && $ttl <= 300, "TTL is within requested window: $ttl");559}560561# test no-value mode562{563    # Set key with lower initial TTL.564    print $sock "ms hidevalue 4 T100\r\nhide\r\n";565    like(scalar <$sock>, qr/^HD/, "set hidevalue");566567    my $res = mget($sock, 'hidevalue', 's t');568    ok(keys %$res, "not a miss");569    is($res->{val}, undef, "no value returned");570571    $res = mget($sock, 'hidevalue', 's t v');572    ok(keys %$res, "not a miss");573    is($res->{val}, 'hide', "real value returned");574}575576# test hit-before? flag577{578    print $sock "ms hitflag 3 T100\r\nhit\r\n";579    like(scalar <$sock>, qr/^HD/, "set hitflag");580581    my $res = mget($sock, 'hitflag', 's t h');582    ok(keys %$res, "not a miss");583    is(get_flag($res, 'h'), 0, "not been hit before");584585    $res = mget($sock, 'hitflag', 's t h');586    ok(keys %$res, "not a miss");587    is(get_flag($res, 'h'), 1, "been hit before");588}589590# test no-update flag591{592    print $sock "ms noupdate 3 T100\r\nhit\r\n";593    like(scalar <$sock>, qr/^HD/, "set noupdate");594595    my $res = mget($sock, 'noupdate', 's t u h');596    ok(keys %$res, "not a miss");597    is(get_flag($res, 'h'), 0, "not been hit before");598599    # _next_ request should show a hit.600    # gets modified here but returns previous state.601    $res = mget($sock, 'noupdate', 's t h');602    is(get_flag($res, 'h'), 0, "still not a hit");603604    $res = mget($sock, 'noupdate', 's t u h');605    is(get_flag($res, 'h'), 1, "finally a hit");606}607608# test last-access time609{610    print $sock "ms la_test 2 T100\r\nla\r\n";611    like(scalar <$sock>, qr/^HD/, "set la_test");612    sleep 2;613614    my $res = mget($sock, 'la_test', 's t l');615    ok(keys %$res, "not a miss");616    isnt(get_flag($res, 'l'), 0, "been over a second since most recently accessed");617}618619# CAS to mask value flag620{621    print $sock "ms va_set 2 c\r\nva\r\n";622    my $res = scalar <$sock>;623    like($res, qr/^HD c/, "set va_set");624    my $cas = 0;625    if ($res =~ m/c(\d+)/) {626        $cas = $1;627        print $sock "mg va_set C$cas v c\r\n";628        my $res = mget_res(scalar <$sock>);629        ok($res->{hd}, "mg returned HD because CAS matched");630    } else {631        fail("CAS missing from va_set response");632    }633634    mget_is({ sock => $sock, flags => 'C99999 v c', eflags => "c$cas" }, 'va_set', 'va',635            "got value from mismatched CAS");636}637638# high level tests:639# - mget + mset with serve-stale640# - set a value641# - mget it back. should be no XZW tokens642# - invalidate via mdelete and mget/revalidate with mset643#   - remember failure scenarios!644#     - TTL timed out?645#     - CAS too high?646#   - also test re-setting as stale (CAS is below requested)647#     - this should probably be conditional.648649{650    note "starting serve stale with mdelete";651    my ($ttl, $cas, $res);652    print $sock "set toinv 0 0 3\r\nmoo\r\n";653    is(scalar <$sock>, "STORED\r\n", "stored key 'toinv'");654655    $res = mget($sock, 'toinv', 's v');656    unlike($res->{flags}, qr/[XWZ]/, "no extra flags");657658    # Lets mark the sucker as invalid, and drop its TTL to 30s659    note "running mdelete";660    print $sock "md toinv I T30\r\n";661    like(scalar <$sock>, qr/^HD/, "mdelete'd key");662663    # TODO: decide on if we need an explicit flag for "if I fetched a stale664    # value, does winning matter?665    # I think it's probably fine. clients can always ignore the win, or we can666    # add an option later to "don't try to revalidate if stale", perhaps.667    $res = mget($sock, 'toinv', 's t c v');668    ok(keys %$res, "not a miss");669    ok(find_flags($res, 'stc'), "got main flags back");670    like($res->{flags}, qr/W/, "won the recache");671    like($res->{flags}, qr/X/, "item is marked stale");672    $ttl = get_flag($res, 't');673    ok($ttl > 0 && $ttl <= 30, "TTL is within requested window");674    ok($res->{size} == 3, "Size returned correctly");675    is($res->{val}, "moo", "value matches");676677    note "trying to fail then stale set via mset";678    print $sock "ms toinv 1 T90 C0\r\nf\r\n";679    like(scalar <$sock>, qr/^EX/, "failed to SET: low CAS didn't match");680681    print $sock "ms toinv 1 I T90 C1\r\nf\r\n";682    like(scalar <$sock>, qr/^HD/, "SET an invalid/stale item");683684    note "confirm item still stale, and TTL wasn't raised.";685    $res = mget($sock, 'toinv', 's t c v');686    like($res->{flags}, qr/X/, "item is marked stale");687    like($res->{flags}, qr/Z/, "win token already sent");688    unlike($res->{flags}, qr/W/, "didn't win: token already sent");689    $ttl = get_flag($res, 't');690    ok($ttl > 0 && $ttl <= 30, "TTL wasn't modified");691692    # TODO: CAS too high?693694    note "do valid mset";695    $cas = get_flag($res, 'c');696    print $sock "ms toinv 1 T90 C$cas\r\ng\r\n";697    like(scalar <$sock>, qr/^HD/, "SET over the stale item");698699    $res = mget($sock, 'toinv', 's t c v');700    ok(keys %$res, "not a miss");701    unlike($res->{flags}, qr/[WXZ]/, "no stale, win, or tokens");702703    $ttl = get_flag($res, 't');704    ok($ttl > 30 && $ttl <= 90, "TTL was modified");705    ok($cas != get_flag($res, 'c'), "CAS was updated");706    is($res->{size}, 1, "size updated");707    is($res->{val}, "g", "value was updated");708}709710# Quiet flag suppresses most output. Badly invalid commands will still711# generate something. Not weird to parse like 'noreply' token was...712# mget's with hits should return real data.713{714    note "testing quiet flag";715    print $sock "ms quiet 2 q\r\nmo\r\n";716    print $sock "md quiet q\r\n";717    print $sock "mg quiet s v q\r\n";718    note "now purposefully cause an error\r\n";719    print $sock "ms quiet\r\n";720    like(scalar <$sock>, qr/^CLIENT_ERROR/, "resp not HD, or EN");721722    # Now try a pipelined get. Throw an mnop at the end723    print $sock "ms quiet 2 q\r\nbo\r\n";724    print $sock "mg quiet v q\r\nmg quiet v q\r\nmg quietmiss v q\r\nmn\r\n";725    # Should get back VA/data/VA/data/EN726    like(scalar <$sock>, qr/^VA 2/, "get response");727    like(scalar <$sock>, qr/^bo/, "get value");728    like(scalar <$sock>, qr/^VA 2/, "get response");729    like(scalar <$sock>, qr/^bo/, "get value");730    like(scalar <$sock>, qr/^MN/, "end token");731732    # "quiet" won't do anything with autoviv, since the only case (miss)733    # should return data anyway.734    print $sock "mg quietautov s N30 t q\r\n";735    like(scalar <$sock>, qr/^HD s0/, "quiet doesn't override autovivication");736}737738{739    my $k = 'otest';740    note "testing mget opaque";741    print $sock "ms $k 2 T100\r\nra\r\n";742    like(scalar <$sock>, qr/^HD/, "set $k");743744    my $res = mget($sock, $k, 't v Oopaque');745    is(get_flag($res, 'O'), 'opaque', "O flag returned opaque");746}747748{749    note "flag and token count errors";750    print $sock "mg foo m o o o o o o o o o\r\n";751    like(scalar <$sock>, qr/^CLIENT_ERROR invalid flag/, "gone silly with flags");752}753754{755    note "pipeline test";756    my $sock = $server->new_sock;757    print $sock "ms foo 2 T100\r\nna\r\n";758    like(scalar <$sock>, qr/^HD/, "set foo");759    print $sock "mg foo s\r\nmg foo s\r\nquit\r\nmg foo s\r\n";760    like(scalar <$sock>, qr/^HD /, "got resp");761    like(scalar <$sock>, qr/^HD /, "got resp");762    is(scalar <$sock>, undef, "final get didn't run");763}764765subtest 'md x and I flags' => sub {766    my $k = 'mdx';767    print $sock "ms $k 2 T50\r\nmx\r\n";768    like(scalar <$sock>, qr/^HD/, "set $k");769770    my $res = mget($sock, $k, 't v');771    is($res->{val}, 'mx', 'seed value as expected');772773    print $sock "md $k x\r\n";774    like(scalar <$sock>, qr/^HD/, "mdelete with x");775776    $res = mget($sock, $k, 't v');777    is($res->{val}, '', 'value zeroed out');778779    # re-set for x + I780    print $sock "ms $k 2 T50\r\nmz\r\n";781    like(scalar <$sock>, qr/^HD/, "set $k");782783    $res = mget($sock, $k, 't v');784    is($res->{val}, 'mz', 'seed value as expected');785786    print $sock "md $k x I\r\n";787    like(scalar <$sock>, qr/^HD/, "mdelete with x and I");788    $res = mget($sock, $k, 't v');789    is($res->{val}, '', 'value zeroed out');790    ok(find_flags($res, 'XW'), "got win and stale flags back");791};792793# TODO: move wait_for_ext into Memcached.pm794sub wait_for_ext {795    my $sock = shift;796    my $target = shift || 0;797    my $sum = $target + 1;798    while ($sum > $target) {799        my $s = mem_stats($sock, "items");800        $sum = 0;801        for my $key (keys %$s) {802            if ($key =~ m/items:(\d+):number/) {803                # Ignore classes which can contain extstore items804                next if $1 < 3;805                $sum += $s->{$key};806            }807        }808        sleep 1 if $sum > $target;809    }810}811812my $ext_path;813# Do a basic extstore test if enabled.814if (supports_extstore()) {815    note "mget + extstore tests";816    $ext_path = "/tmp/extstore.$$";817    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");818    my $sock = $server->sock;819820    my $value;821    {822        my @chars = ("C".."Z");823        for (1 .. 20000) {824            $value .= $chars[rand @chars];825        }826    }827828    my $keycount = 10;829    for (1 .. $keycount) {830        print $sock "set nfoo$_ 0 0 20000 noreply\r\n$value\r\n";831    }832833    wait_for_ext($sock);834    mget_is({ sock => $sock,835              flags => 's v',836              eflags => 's20000' },837            'nfoo1', $value, "retrieved test value");838    my $stats = mem_stats($sock);839    cmp_ok($stats->{get_extstore}, '>', 0, 'one object was fetched');840841    my $ovalue = $value;842    for (1 .. 4) {843        $value .= $ovalue;844    }845    # Fill to eviction.846    $keycount = 1000;847    for (1 .. $keycount) {848        print $sock "set mfoo$_ 0 0 100000 noreply\r\n$value\r\n";849        # wait to avoid memory evictions850        wait_for_ext($sock, 1) if ($_ % 250 == 0);851    }852853    print $sock "mg mfoo1 s v\r\n";854    is(scalar <$sock>, "EN\r\n");855    print $sock "mg mfoo1 s v q\r\nmn\r\n";856    is(scalar <$sock>, "MN\r\n");857    $stats = mem_stats($sock);858    cmp_ok($stats->{miss_from_extstore}, '>', 0, 'at least one miss');859}860861###862863# takes hash:864# - sock865# - args (metaget flags)866# - array of tokens867# - array of expected response tokens868869# returns hash:870# - win (if won a condition)871# - array of tokens872# - value, etc?873# useful to chain together for further requests.874# works only with single line values. no newlines in value.875# FIXME: some workaround for super long values :|876# TODO: move this to lib/MemcachedTest.pm877sub mget_is {878    # single line values only879    my ($o, $key, $val, $msg) = @_;880881    my $dval = defined $val ? "'$val'" : "<undef>";882    $msg ||= "$key == $dval";883884    my $s = $o->{sock};885    my $flags = $o->{flags};886    my $eflags = $o->{eflags} || $flags;887888    print $s "mg $key $flags\r\n";889    if (! defined $val) {890        my $line = scalar <$s>;891        if ($line =~ /^VA/) {892            $line .= scalar(<$s>);893        }894        Test::More::is($line, "EN\r\n", $msg);895    } else {896        my $len = length($val);897        my $body = scalar(<$s>);898        my $expected = "VA $len $eflags\r\n$val\r\n";899        if (!$body || $body =~ /^EN/) {900            Test::More::is($body, $expected, $msg);901            return;902        }903        $body .= scalar(<$s>);904        Test::More::is($body, $expected, $msg);905        return mget_res($body);906    }907    return {};908}909910# only fetches values without newlines in it.911sub mget {912    my $s = shift;913    my $key = shift;914    my $flags = shift;915916    print $s "mg $key $flags\r\n";917    my $header = scalar(<$s>);918    my $val = "\r\n";919    if ($header =~ m/^VA/) {920        $val = scalar(<$s>);921    }922923    return mget_res($header . $val);924}925926# TODO: share with mget()?927sub marith {928    my $s = shift;929    my $key = shift;930    my $flags = shift;931932    print $s "ma $key $flags\r\n";933    my $header = scalar(<$s>);934    my $val = "\r\n";935    if ($header =~ m/^VA/) {936        $val = scalar(<$s>);937    }938939    return mget_res($header . $val);940}941942# parse out a response943sub mget_res {944    my $resp = shift;945    my %r = ();946947    if ($resp =~ m/^VA (\d+) ([^\r]+)\r\n(.*)\r\n/gm) {948        $r{size} = $1;949        $r{flags} = $2;950        $r{val} = $3;951    } elsif ($resp =~ m/^HD\s*([^\r]+)\r\n/gm) {952        $r{flags} = $1;953        $r{hd} = 1;954    } elsif ($resp =~ m/^EN/gm) {955        # do nothing?956    } else {957        die "Unable to parse mget response: $resp";958    }959960    return \%r;961}962963sub parse_res {964    my $resp = shift;965    my %r = ();966    if ($resp =~ m/^(\w\w)\s*([^\r]+)\r\n/gm) {967        $r{status} = $1;968        $r{flags} = $2;969    }970971    return \%r;972}973974sub get_flag {975    my $res = shift;976    my $flag = shift;977    my @flags = split(/ /, $res->{flags});978    for my $f (@flags) {979        if ($f =~ m/^$flag/) {980            return substr $f, 1;981        }982    }983}984985sub find_flags {986    my $res = shift;987    my $flags = shift;988    my @flags = split(//, $flags);989    for my $f (@flags) {990        return 0 unless defined get_flag($res, $f);991    }992    return 1;993}994995done_testing();996997END {998    unlink $ext_path if $ext_path;999}