"Fossies" - the Fresh Open Source Software Archive

Member "memcached-1.6.15/t/metaget.t" (21 Feb 2022, 24242 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. See also the last Fossies "Diffs" side-by-side code changes report for "metaget.t": 1.6.12_vs_1.6.13.

A hint: This file contains one or more very long lines, so maybe it is better readable using the pure text view mode that shows the contents as wrapped lines within the browser window.

    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();
   11 my $sock = $server->sock;
   12 
   13 # command syntax:
   14 # mg [key] [flags]\r\n
   15 # response:
   16 # VA [size] [flags]\r\n
   17 # data\r\n
   18 # or:
   19 # HD [flags]\r\n
   20 # or:
   21 # EN\r\n
   22 # flags are single 'f' or 'f1234' or 'fTEXT'
   23 #
   24 # flags:
   25 # - s: return item size
   26 # - v: return item value
   27 # - c: return item cas
   28 # - t: return item TTL remaining (-1 for unlimited)
   29 # - f: return client flags
   30 # - l: return last access time
   31 # - h: return whether item has been hit before
   32 # - O(token): opaque to copy back.
   33 # - k: return key
   34 # - q: noreply semantics.
   35 # - u: don't bump the item in LRU
   36 # updaters:
   37 # - N(token): vivify on miss, takes TTL as a argument
   38 # - R(token): if token is less than item TTL win for recache
   39 # - T(token): update remaining TTL
   40 # FIXME: do I need a "if stale and no token sent, flip" explicit flag?
   41 # extra response flags:
   42 # - W: client has "won" the token
   43 # - X: object is stale
   44 # - Z: object has sent a winning token
   45 #
   46 # ms [key] [valuelen] [flags]\r\n
   47 # value\r\n
   48 # response:
   49 # HD [flags]\r\n
   50 # HD STORED, NS NOT_STORED, EX EXISTS, NF NOT_FOUND
   51 #
   52 # flags:
   53 # - q: noreply
   54 # - F(token): set client flags
   55 # - C(token): compare CAS value
   56 # - T(token): TTL
   57 # - O(token): opaque to copy back.
   58 # - k: return key
   59 # - I: invalid. set-to-invalid if CAS is older than it should be.
   60 # - M(token): mode switch.
   61 #   - default to "set"
   62 #   - E: add mode
   63 #   - A: append mode
   64 #   - P: prepend mode
   65 #   - R: replace mode
   66 #   - S: set mode - not necessary, but could be useful for clients.
   67 #
   68 # md [key] [flags]\r\n
   69 # response:
   70 # HD [flags]
   71 # flags:
   72 # - q: noreply
   73 # - T(token): updates TTL
   74 # - C(token): compare CAS value
   75 # - I: invalidate. mark as stale, bumps CAS.
   76 # - O(token): opaque to copy back.
   77 # - k: return key
   78 #
   79 # ma [key] [flags]\r\n
   80 # response:
   81 # HD [flags]\r\n
   82 # HD, NS NOT_STORED, EX EXISTS, NF NOT_FOUND
   83 # or:
   84 # VA [size] [flags]\r\n
   85 # data\r\n
   86 #
   87 # flags:
   88 # q: noreply
   89 # N(token): autovivify with supplied TTL
   90 # J(token): initial value to use if autovivified
   91 # D(token): delta to apply. default 1
   92 # T(token): update TTL
   93 # C(token): CAS must match
   94 # M(token): mode switch.
   95 #  - default to "incr"
   96 #  - I: incr
   97 #  - +: incr
   98 #  - D: decr
   99 #  - -: decr
  100 # t: return TTL
  101 # c: return current CAS
  102 # v: return new value
  103 #
  104 # mn\r\n
  105 # response:
  106 # MN\r\n
  107 
  108 # metaget tests
  109 
  110 # basic test
  111 # - raw mget
  112 # - raw mget miss
  113 # - raw mget bad key
  114 
  115 # Test basic parser.
  116 {
  117     print $sock " \n";
  118     is(scalar <$sock>, "ERROR\r\n", "error from blank command");
  119 }
  120 
  121 {
  122     print $sock "set foo 0 0 2\r\nhi\r\n";
  123     is(scalar <$sock>, "STORED\r\n", "stored test value");
  124 
  125     print $sock "me none\r\n";
  126     is(scalar <$sock>, "EN\r\n", "raw mget miss");
  127 
  128     print $sock "me foo\r\n";
  129     like(scalar <$sock>, qr/^ME foo /, "raw mget result");
  130 }
  131 
  132 # mget with arguments
  133 # - set some specific TTL and get it back (within reason)
  134 # - get cas
  135 # - autovivify and bit-win
  136 
  137 {
  138     print $sock "set foo2 0 90 2\r\nho\r\n";
  139     is(scalar <$sock>, "STORED\r\n", "stored test value");
  140 
  141     mget_is({ sock => $sock,
  142               flags => 's v',
  143               eflags => 's2' },
  144             'foo2', 'ho', "retrieved test value");
  145 
  146     # FIXME: figure out what I meant to do here.
  147     #my $res = mget($sock, 'foo2', 's t v');
  148 }
  149 
  150 {
  151     diag "basic mset CAS";
  152     my $key = "msetcas";
  153     print $sock "ms $key 2\r\nbo\r\n";
  154     like(scalar <$sock>, qr/^HD/, "set test key");
  155 
  156     my $res = mget($sock, $key, 'c');
  157     ok(get_flag($res, 'c'), "got a cas value back");
  158 
  159     my $cas = get_flag($res, 'c');
  160     my $badcas = $cas + 10;
  161     print $sock "ms $key 2 c C$badcas\r\nio\r\n";
  162     like(scalar <$sock>, qr/^EX c0/, "zeroed out cas on return");
  163 
  164     print $sock "ms $key 2 c C$cas\r\nio\r\n";
  165     like(scalar <$sock>, qr/^HD c\d+/, "success on correct cas");
  166 }
  167 
  168 {
  169     diag "mdelete with cas";
  170     my $key = "mdeltest";
  171     print $sock "ms $key 2\r\nzo\r\n";
  172     like(scalar <$sock>, qr/^HD/, "set test key");
  173 
  174     my $res = mget($sock, $key, 'c');
  175     ok(get_flag($res, 'c'), "got a cas value back");
  176 
  177     my $cas = get_flag($res, 'c');
  178     my $badcas = $cas + 10;
  179     print $sock "md $key C$badcas\r\n";
  180     like(scalar <$sock>, qr/^EX/, "mdelete fails for wrong CAS");
  181     print $sock "md $key C$cas\r\n";
  182     like(scalar <$sock>, qr/^HD/, "mdeleted key");
  183 }
  184 
  185 {
  186     diag "encoded binary keys";
  187     # 44OG44K544OI is "tesuto" in katakana
  188     my $tesuto = "44OG44K544OI";
  189     print $sock "ms $tesuto 2 b\r\npo\r\n";
  190     like(scalar <$sock>, qr/^HD/, "set with encoded key");
  191 
  192     my $res = mget($sock, $tesuto, 'v');
  193     ok(! exists $res->{val}, "encoded key doesn't exist");
  194     $res = mget($sock, $tesuto, 'b v k');
  195     ok(exists $res->{val}, "decoded key exists");
  196     ok(get_flag($res, 'k') eq $tesuto, "key returned encoded");
  197 
  198     # TODO: test k is returned properly from ms.
  199     # validate the store data is smaller somehow?
  200 }
  201 
  202 {
  203     diag "marithmetic tests";
  204     print $sock "ma mo\r\n";
  205     like(scalar <$sock>, qr/^NF/, "incr miss");
  206 
  207     print $sock "ma mo D1\r\n";
  208     like(scalar <$sock>, qr/^NF/, "incr miss with argument");
  209 
  210     print $sock "set mo 0 0 1\r\n1\r\n";
  211     like(scalar <$sock>, qr/^STORED/, "stored with set");
  212 
  213     print $sock "ma mo\r\n";
  214     like(scalar <$sock>, qr/^HD/, "incr'd a set value");
  215 
  216     print $sock "set mo 0 0 1\r\nq\r\n";
  217     like(scalar <$sock>, qr/^STORED/, "stored with set");
  218 
  219     print $sock "ma mo\r\n";
  220     like(scalar <$sock>, qr/^CLIENT_ERROR /, "cannot incr non-numeric value");
  221 
  222     print $sock "ma mu N90\r\n";
  223     like(scalar <$sock>, qr/^HD/, "incr with seed");
  224     my $res = mget($sock, 'mu', 's t v Ofoo k');
  225     ok(keys %$res, "not a miss");
  226     ok(find_flags($res, 'st'), "got main flags back");
  227     is($res->{val}, '0', "seeded default value");
  228     my $ttl = get_flag($res, 't');
  229     ok($ttl > 10 && $ttl < 91, "TTL is within requested window: $ttl");
  230 
  231     $res = marith($sock, 'mu', 'T300 v t');
  232     ok(keys %$res, "not a miss");
  233     is($res->{val}, '1', "incremented once");
  234     $ttl = get_flag($res, 't');
  235     ok($ttl > 150 && $ttl < 301, "TTL is within requested window: $ttl");
  236 
  237     $res = marith($sock, 'mi', 'N0 J13 v t');
  238     ok(keys %$res, "not a miss");
  239     is($res->{val}, '13', 'seeded on a missed value');
  240     $res = marith($sock, 'mi', 'N0 J13 v t');
  241     is($res->{val}, '14', 'incremented from seed');
  242 
  243     $res = marith($sock, 'mi', 'N0 J13 v t D30');
  244     is($res->{val}, '44', 'specific increment');
  245 
  246     $res = marith($sock, 'mi', 'N0 J13 v t MD D22');
  247     is($res->{val}, '22', 'specific decrement');
  248 
  249     $res = marith($sock, 'mi', 'N0 J13 v t MD D9000');
  250     is($res->{val}, '0', 'land at 0 for over-decrement');
  251 
  252     print $sock "ma mi q D1\r\nmn\r\n";
  253     like(scalar <$sock>, qr/^MN/, "quiet increment");
  254 
  255     # CAS routines.
  256     $res = marith($sock, 'mc', 'N0 c v');
  257     my $cas = get_flag($res, 'c');
  258     # invalid CAS.
  259     print $sock "ma mc N0 C99999 v\r\n";
  260     like(scalar <$sock>, qr/^EX/, 'CAS mismatch');
  261     # valid CAS
  262     $res = marith($sock, 'mc', "N0 C$cas c v");
  263     my $ncas = get_flag($res, 'c');
  264     is($res->{val}, '1', 'ticked after CAS increment');
  265     isnt($cas, $ncas, 'CAS increments during modification');
  266 }
  267 
  268 # mset tests with mode switch flag (M)
  269 
  270 {
  271     diag "mset mode switch";
  272     print $sock "ms modedefault 2 T120\r\naa\r\n";
  273     like(scalar <$sock>, qr/^HD/, "default set mode");
  274     mget_is({ sock => $sock,
  275               flags => 's v',
  276               eflags => 's2' },
  277             'modedefault', 'aa', "retrieved test value");
  278 
  279     # Fail an add
  280     print $sock "ms modedefault 2 T120 ME\r\naa\r\n";
  281     like(scalar <$sock>, qr/^NS/, "add mode gets NOT_STORED");
  282     # Win an add
  283     print $sock "ms modetest 2 T120 ME\r\nbb\r\n";
  284     like(scalar <$sock>, qr/^HD/, "add mode");
  285     mget_is({ sock => $sock,
  286               flags => 's v',
  287               eflags => 's2' },
  288             'modetest', 'bb', "retrieved test value");
  289 
  290     # append
  291     print $sock "ms modetest 2 T120 MA\r\ncc\r\n";
  292     like(scalar <$sock>, qr/^HD/, "append mode");
  293     mget_is({ sock => $sock,
  294               flags => 's v',
  295               eflags => 's4' },
  296             'modetest', 'bbcc', "retrieved test value");
  297     # prepend
  298     print $sock "ms modetest 2 T120 MP\r\naa\r\n";
  299     like(scalar <$sock>, qr/^HD/, "append mode");
  300     mget_is({ sock => $sock,
  301               flags => 's v',
  302               eflags => 's6' },
  303             'modetest', 'aabbcc', "retrieved test value");
  304 
  305     # replace
  306     print $sock "ms modereplace 2 T120 MR\r\nzz\r\n";
  307     like(scalar <$sock>, qr/^NS/, "fail replace mode");
  308     print $sock "ms modetest 2 T120 MR\r\nxx\r\n";
  309     like(scalar <$sock>, qr/^HD/, "replace mode");
  310     mget_is({ sock => $sock,
  311               flags => 's v',
  312               eflags => 's2' },
  313             'modetest', 'xx', "retrieved test value");
  314 
  315     # explicit set
  316     print $sock "ms modetest 2 T120 MS\r\nyy\r\n";
  317     like(scalar <$sock>, qr/^HD/, "force set mode");
  318 
  319     # invalid mode
  320     print $sock "ms modetest 2 T120 MZ\r\ntt\r\n";
  321     like(scalar <$sock>, qr/^CLIENT_ERROR /, "invalid mode");
  322 }
  323 
  324 # lease-test, use two sockets? one socket should be fine, actually.
  325 # - get a win on autovivify
  326 # - get a loss on the same command
  327 # - have a set/cas fail
  328 # - have a cas succeed
  329 # - repeat for "triggered on TTL"
  330 # - test just modifying the TTL (touch)
  331 # - test fetching without value
  332 {
  333     my $res = mget($sock, 'needwin', 's c v N30 t');
  334     like($res->{flags}, qr/[scvNt]+/, "got main flags back");
  335     like($res->{flags}, qr/W/, "got a win result");
  336     unlike($res->{flags}, qr/Z/, "no token already sent warning");
  337 
  338     # asked for size and TTL. size should be 0, TTL should be > 0 and < 30
  339     is($res->{size}, 0, "got zero size: autovivified response");
  340     my $ttl = get_flag($res, 't');
  341     ok($ttl > 0 && $ttl <= 30, "auto TTL is within requested window: $ttl");
  342 
  343     # try to fail this time.
  344     {
  345         my $res = mget($sock, 'needwin', 's t c v N30');
  346         ok(keys %$res, "got a non-empty response");
  347         unlike($res->{flags}, qr/W/, "not a win result");
  348         like($res->{flags}, qr/Z/, "object already sent win result");
  349     }
  350 
  351     # set back with the wrong CAS
  352     print $sock "ms needwin 2 C5000 T120\r\nnu\r\n";
  353     like(scalar <$sock>, qr/^EX/, "failed to SET: CAS didn't match");
  354 
  355     # again, but succeed.
  356     # TODO: the actual CAS command should work here too?
  357     my $cas = get_flag($res, 'c');
  358     print $sock "ms needwin 2 C$cas T120\r\nmu\r\n";
  359     like(scalar <$sock>, qr/^HD/, "SET: CAS matched");
  360 
  361     # now we repeat the original mget, but the data should be different.
  362     $res = mget($sock, 'needwin', 's k t c v N30');
  363     ok(keys %$res, "not a miss");
  364     ok(find_flags($res, 'sktc'), "got main flags back");
  365     unlike($res->{flags}, qr/[WZ]/, "not a win or token result");
  366     is(get_flag($res, 'k'), 'needwin', "key matches");
  367     $ttl = get_flag($res, 't');
  368     ok($ttl > 100 && $ttl <= 120, "TTL is within requested window: $ttl");
  369     is($res->{val}, "mu", "value matches");
  370 
  371     # now we do the whole routine again, but for "triggered on TTL being low"
  372     # TTL was set to 120 just now, so anything lower than this should trigger.
  373     $res = mget($sock, 'needwin', 's t c v N30 R130');
  374     ok(find_flags($res, 'stc'), "got main flags back");
  375     like($res->{flags}, qr/W/, "got a win result");
  376     unlike($res->{flags}, qr/Z/, "no token already sent warning");
  377     is($res->{val}, "mu", "value matches");
  378 
  379     # try to fail this time.
  380     {
  381         my $res = mget($sock, 'needwin', 's t c v N30 R130');
  382         ok(keys %$res, "got a non-empty response");
  383         unlike($res->{flags}, qr/W/, "not a win result");
  384         like($res->{flags}, qr/Z/, "object already sent win result");
  385         is($res->{val}, "mu", "value matches");
  386     }
  387 
  388     # again, but succeed.
  389     $cas = get_flag($res, 'c');
  390     print $sock "ms needwin 4 C$cas T300\r\nzuuu\r\n";
  391     like(scalar <$sock>, qr/^HD/, "SET: CAS matched");
  392 
  393     # now we repeat the original mget, but the data should be different.
  394     $res = mget($sock, 'needwin', 's t c v N30');
  395     ok(keys %$res, "not a miss");
  396     ok(find_flags($res, 'stc'), "got main flags back");
  397     unlike($res->{flags}, qr/[WZ]/, "not a win or token result");
  398     $ttl = get_flag($res, 't');
  399     ok($ttl > 250 && $ttl <= 300, "TTL is within requested window");
  400     ok($res->{size} == 4, "Size returned correctly");
  401     is($res->{val}, "zuuu", "value matches: " . $res->{val});
  402 
  403 }
  404 
  405 # test get-and-touch mode
  406 {
  407     # Set key with lower initial TTL.
  408     print $sock "ms gatkey 4 T100\r\nooom\r\n";
  409     like(scalar <$sock>, qr/^HD/, "set gatkey");
  410 
  411     # Coolish side feature and/or bringer of bugs: 't' before 'T' gives TTL
  412     # before adjustment. 'T' before 't' gives TTL after adjustment.
  413     # Here we want 'T' before 't' to ensure we did adjust the value.
  414     my $res = mget($sock, 'gatkey', 's v T300 t');
  415     ok(keys %$res, "not a miss");
  416     unlike($res->{flags}, qr/[WZ]/, "not a win or token result");
  417     my $ttl = get_flag($res, 't');
  418     ok($ttl > 280 && $ttl <= 300, "TTL is within requested window: $ttl");
  419 }
  420 
  421 # test no-value mode
  422 {
  423     # Set key with lower initial TTL.
  424     print $sock "ms hidevalue 4 T100\r\nhide\r\n";
  425     like(scalar <$sock>, qr/^HD/, "set hidevalue");
  426 
  427     my $res = mget($sock, 'hidevalue', 's t');
  428     ok(keys %$res, "not a miss");
  429     is($res->{val}, undef, "no value returned");
  430 
  431     $res = mget($sock, 'hidevalue', 's t v');
  432     ok(keys %$res, "not a miss");
  433     is($res->{val}, 'hide', "real value returned");
  434 }
  435 
  436 # test hit-before? flag
  437 {
  438     print $sock "ms hitflag 3 T100\r\nhit\r\n";
  439     like(scalar <$sock>, qr/^HD/, "set hitflag");
  440 
  441     my $res = mget($sock, 'hitflag', 's t h');
  442     ok(keys %$res, "not a miss");
  443     is(get_flag($res, 'h'), 0, "not been hit before");
  444 
  445     $res = mget($sock, 'hitflag', 's t h');
  446     ok(keys %$res, "not a miss");
  447     is(get_flag($res, 'h'), 1, "been hit before");
  448 }
  449 
  450 # test no-update flag
  451 {
  452     print $sock "ms noupdate 3 T100\r\nhit\r\n";
  453     like(scalar <$sock>, qr/^HD/, "set noupdate");
  454 
  455     my $res = mget($sock, 'noupdate', 's t u h');
  456     ok(keys %$res, "not a miss");
  457     is(get_flag($res, 'h'), 0, "not been hit before");
  458 
  459     # _next_ request should show a hit.
  460     # gets modified here but returns previous state.
  461     $res = mget($sock, 'noupdate', 's t h');
  462     is(get_flag($res, 'h'), 0, "still not a hit");
  463 
  464     $res = mget($sock, 'noupdate', 's t u h');
  465     is(get_flag($res, 'h'), 1, "finally a hit");
  466 }
  467 
  468 # test last-access time
  469 {
  470     print $sock "ms la_test 2 T100\r\nla\r\n";
  471     like(scalar <$sock>, qr/^HD/, "set la_test");
  472     sleep 2;
  473 
  474     my $res = mget($sock, 'la_test', 's t l');
  475     ok(keys %$res, "not a miss");
  476     isnt(get_flag($res, 'l'), 0, "been over a second since most recently accessed");
  477 }
  478 
  479 # high level tests:
  480 # - mget + mset with serve-stale
  481 # - set a value
  482 # - mget it back. should be no XZW tokens
  483 # - invalidate via mdelete and mget/revalidate with mset
  484 #   - remember failure scenarios!
  485 #     - TTL timed out?
  486 #     - CAS too high?
  487 #   - also test re-setting as stale (CAS is below requested)
  488 #     - this should probably be conditional.
  489 
  490 {
  491     diag "starting serve stale with mdelete";
  492     my ($ttl, $cas, $res);
  493     print $sock "set toinv 0 0 3\r\nmoo\r\n";
  494     is(scalar <$sock>, "STORED\r\n", "stored key 'toinv'");
  495 
  496     $res = mget($sock, 'toinv', 's v');
  497     unlike($res->{flags}, qr/[XWZ]/, "no extra flags");
  498 
  499     # Lets mark the sucker as invalid, and drop its TTL to 30s
  500     diag "running mdelete";
  501     print $sock "md toinv I T30\r\n";
  502     like(scalar <$sock>, qr/^HD /, "mdelete'd key");
  503 
  504     # TODO: decide on if we need an explicit flag for "if I fetched a stale
  505     # value, does winning matter?
  506     # I think it's probably fine. clients can always ignore the win, or we can
  507     # add an option later to "don't try to revalidate if stale", perhaps.
  508     $res = mget($sock, 'toinv', 's t c v');
  509     ok(keys %$res, "not a miss");
  510     ok(find_flags($res, 'stc'), "got main flags back");
  511     like($res->{flags}, qr/W/, "won the recache");
  512     like($res->{flags}, qr/X/, "item is marked stale");
  513     $ttl = get_flag($res, 't');
  514     ok($ttl > 0 && $ttl <= 30, "TTL is within requested window");
  515     ok($res->{size} == 3, "Size returned correctly");
  516     is($res->{val}, "moo", "value matches");
  517 
  518     diag "trying to fail then stale set via mset";
  519     print $sock "ms toinv 1 T90 C0\r\nf\r\n";
  520     like(scalar <$sock>, qr/^EX/, "failed to SET: low CAS didn't match");
  521 
  522     print $sock "ms toinv 1 I T90 C1\r\nf\r\n";
  523     like(scalar <$sock>, qr/^HD/, "SET an invalid/stale item");
  524 
  525     diag "confirm item still stale, and TTL wasn't raised.";
  526     $res = mget($sock, 'toinv', 's t c v');
  527     like($res->{flags}, qr/X/, "item is marked stale");
  528     like($res->{flags}, qr/Z/, "win token already sent");
  529     unlike($res->{flags}, qr/W/, "didn't win: token already sent");
  530     $ttl = get_flag($res, 't');
  531     ok($ttl > 0 && $ttl <= 30, "TTL wasn't modified");
  532 
  533     # TODO: CAS too high?
  534 
  535     diag "do valid mset";
  536     $cas = get_flag($res, 'c');
  537     print $sock "ms toinv 1 T90 C$cas\r\ng\r\n";
  538     like(scalar <$sock>, qr/^HD/, "SET over the stale item");
  539 
  540     $res = mget($sock, 'toinv', 's t c v');
  541     ok(keys %$res, "not a miss");
  542     unlike($res->{flags}, qr/[WXZ]/, "no stale, win, or tokens");
  543 
  544     $ttl = get_flag($res, 't');
  545     ok($ttl > 30 && $ttl <= 90, "TTL was modified");
  546     ok($cas != get_flag($res, 'c'), "CAS was updated");
  547     is($res->{size}, 1, "size updated");
  548     is($res->{val}, "g", "value was updated");
  549 }
  550 
  551 # Quiet flag suppresses most output. Badly invalid commands will still
  552 # generate something. Not weird to parse like 'noreply' token was...
  553 # mget's with hits should return real data.
  554 {
  555     diag "testing quiet flag";
  556     print $sock "ms quiet 2 q\r\nmo\r\n";
  557     print $sock "md quiet q\r\n";
  558     print $sock "mg quiet s v q\r\n";
  559     diag "now purposefully cause an error\r\n";
  560     print $sock "ms quiet\r\n";
  561     like(scalar <$sock>, qr/^CLIENT_ERROR/, "resp not HD, or EN");
  562 
  563     # Now try a pipelined get. Throw an mnop at the end
  564     print $sock "ms quiet 2 q\r\nbo\r\n";
  565     print $sock "mg quiet v q\r\nmg quiet v q\r\nmg quietmiss v q\r\nmn\r\n";
  566     # Should get back VA/data/VA/data/EN
  567     like(scalar <$sock>, qr/^VA 2/, "get response");
  568     like(scalar <$sock>, qr/^bo/, "get value");
  569     like(scalar <$sock>, qr/^VA 2/, "get response");
  570     like(scalar <$sock>, qr/^bo/, "get value");
  571     like(scalar <$sock>, qr/^MN/, "end token");
  572 
  573     # "quiet" won't do anything with autoviv, since the only case (miss)
  574     # should return data anyway.
  575     print $sock "mg quietautov s N30 t q\r\n";
  576     like(scalar <$sock>, qr/^HD s0/, "quiet doesn't override autovivication");
  577 }
  578 
  579 {
  580     my $k = 'otest';
  581     diag "testing mget opaque";
  582     print $sock "ms $k 2 T100\r\nra\r\n";
  583     like(scalar <$sock>, qr/^HD/, "set $k");
  584 
  585     my $res = mget($sock, $k, 't v Oopaque');
  586     is(get_flag($res, 'O'), 'opaque', "O flag returned opaque");
  587 }
  588 
  589 {
  590     diag "flag and token count errors";
  591     print $sock "mg foo m o o o o o o o o o\r\n";
  592     like(scalar <$sock>, qr/^CLIENT_ERROR invalid flag/, "gone silly with flags");
  593 }
  594 
  595 {
  596     diag "pipeline test";
  597     print $sock "ms foo 2 T100\r\nna\r\n";
  598     like(scalar <$sock>, qr/^HD/, "set foo");
  599     print $sock "mg foo s\r\nmg foo s\r\nquit\r\nmg foo s\r\n";
  600     like(scalar <$sock>, qr/^HD /, "got resp");
  601     like(scalar <$sock>, qr/^HD /, "got resp");
  602     is(scalar <$sock>, undef, "final get didn't run");
  603 }
  604 
  605 # TODO: move wait_for_ext into Memcached.pm
  606 sub wait_for_ext {
  607     my $sock = shift;
  608     my $target = shift || 0;
  609     my $sum = $target + 1;
  610     while ($sum > $target) {
  611         my $s = mem_stats($sock, "items");
  612         $sum = 0;
  613         for my $key (keys %$s) {
  614             if ($key =~ m/items:(\d+):number/) {
  615                 # Ignore classes which can contain extstore items
  616                 next if $1 < 3;
  617                 $sum += $s->{$key};
  618             }
  619         }
  620         sleep 1 if $sum > $target;
  621     }
  622 }
  623 
  624 my $ext_path;
  625 # Do a basic extstore test if enabled.
  626 if (supports_extstore()) {
  627     diag "mget + extstore tests";
  628     $ext_path = "/tmp/extstore.$$";
  629     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");
  630     my $sock = $server->sock;
  631 
  632     my $value;
  633     {
  634         my @chars = ("C".."Z");
  635         for (1 .. 20000) {
  636             $value .= $chars[rand @chars];
  637         }
  638     }
  639 
  640     my $keycount = 10;
  641     for (1 .. $keycount) {
  642         print $sock "set nfoo$_ 0 0 20000 noreply\r\n$value\r\n";
  643     }
  644 
  645     wait_for_ext($sock);
  646     mget_is({ sock => $sock,
  647               flags => 's v',
  648               eflags => 's20000' },
  649             'nfoo1', $value, "retrieved test value");
  650     my $stats = mem_stats($sock);
  651     cmp_ok($stats->{get_extstore}, '>', 0, 'one object was fetched');
  652 
  653     my $ovalue = $value;
  654     for (1 .. 4) {
  655         $value .= $ovalue;
  656     }
  657     # Fill to eviction.
  658     $keycount = 1000;
  659     for (1 .. $keycount) {
  660         print $sock "set mfoo$_ 0 0 100000 noreply\r\n$value\r\n";
  661         # wait to avoid memory evictions
  662         wait_for_ext($sock, 1) if ($_ % 250 == 0);
  663     }
  664 
  665     print $sock "mg mfoo1 s v\r\n";
  666     is(scalar <$sock>, "EN\r\n");
  667     print $sock "mg mfoo1 s v q\r\nmn\r\n";
  668     is(scalar <$sock>, "MN\r\n");
  669     $stats = mem_stats($sock);
  670     cmp_ok($stats->{miss_from_extstore}, '>', 0, 'at least one miss');
  671 }
  672 
  673 ###
  674 
  675 # takes hash:
  676 # - sock
  677 # - args (metaget flags)
  678 # - array of tokens
  679 # - array of expected response tokens
  680 
  681 # returns hash:
  682 # - win (if won a condition)
  683 # - array of tokens
  684 # - value, etc?
  685 # useful to chain together for further requests.
  686 # works only with single line values. no newlines in value.
  687 # FIXME: some workaround for super long values :|
  688 # TODO: move this to lib/MemcachedTest.pm
  689 sub mget_is {
  690     # single line values only
  691     my ($o, $key, $val, $msg) = @_;
  692 
  693     my $dval = defined $val ? "'$val'" : "<undef>";
  694     $msg ||= "$key == $dval";
  695 
  696     my $s = $o->{sock};
  697     my $flags = $o->{flags};
  698     my $eflags = $o->{eflags} || $flags;
  699 
  700     print $s "mg $key $flags\r\n";
  701     if (! defined $val) {
  702         my $line = scalar <$s>;
  703         if ($line =~ /^VA/) {
  704             $line .= scalar(<$s>);
  705         }
  706         Test::More::is($line, "EN\r\n", $msg);
  707     } else {
  708         my $len = length($val);
  709         my $body = scalar(<$s>);
  710         my $expected = "VA $len $eflags\r\n$val\r\n";
  711         if (!$body || $body =~ /^EN/) {
  712             Test::More::is($body, $expected, $msg);
  713             return;
  714         }
  715         $body .= scalar(<$s>);
  716         Test::More::is($body, $expected, $msg);
  717         return mget_res($body);
  718     }
  719     return {};
  720 }
  721 
  722 # only fetches values without newlines in it.
  723 sub mget {
  724     my $s = shift;
  725     my $key = shift;
  726     my $flags = shift;
  727 
  728     print $s "mg $key $flags\r\n";
  729     my $header = scalar(<$s>);
  730     my $val = "\r\n";
  731     if ($header =~ m/^VA/) {
  732         $val = scalar(<$s>);
  733     }
  734 
  735     return mget_res($header . $val);
  736 }
  737 
  738 # TODO: share with mget()?
  739 sub marith {
  740     my $s = shift;
  741     my $key = shift;
  742     my $flags = shift;
  743 
  744     print $s "ma $key $flags\r\n";
  745     my $header = scalar(<$s>);
  746     my $val = "\r\n";
  747     if ($header =~ m/^VA/) {
  748         $val = scalar(<$s>);
  749     }
  750 
  751     return mget_res($header . $val);
  752 }
  753 
  754 # parse out a response
  755 sub mget_res {
  756     my $resp = shift;
  757     my %r = ();
  758 
  759     if ($resp =~ m/^VA (\d+) ([^\r]+)\r\n(.*)\r\n/gm) {
  760         $r{size} = $1;
  761         $r{flags} = $2;
  762         $r{val} = $3;
  763     } elsif ($resp =~ m/^HD ([^\r]+)\r\n/gm) {
  764         $r{flags} = $1;
  765         $r{hd} = 1;
  766     }
  767 
  768     return \%r;
  769 }
  770 
  771 sub get_flag {
  772     my $res = shift;
  773     my $flag = shift;
  774     #print STDERR "FLAGS: $res->{flags}\n";
  775     my @flags = split(/ /, $res->{flags});
  776     for my $f (@flags) {
  777         if ($f =~ m/^$flag/) {
  778             return substr $f, 1;
  779         }
  780     }
  781 }
  782 
  783 sub find_flags {
  784     my $res = shift;
  785     my $flags = shift;
  786     my @flags = split(//, $flags);
  787     for my $f (@flags) {
  788         return 0 unless get_flag($res, $f);
  789     }
  790     return 1;
  791 }
  792 
  793 done_testing();
  794 
  795 END {
  796     unlink $ext_path if $ext_path;
  797 }