1#!/usr/bin/env perl
2
3use strict;
4use warnings;
5use Test::More;
6use FindBin qw($Bin);
7use lib "$Bin/lib";
8use Carp qw(croak);
9use MemcachedTest;
10use IO::Socket qw(AF_INET SOCK_STREAM);
11use IO::Select;
12use Data::Dumper qw/Dumper/;
13
14if (!supports_proxy()) {
15    plan skip_all => 'proxy not enabled';
16    exit 0;
17}
18
19# Set up some server sockets.
20sub mock_server {
21    my $port = shift;
22    my $srv = IO::Socket->new(
23        Domain => AF_INET,
24        Type => SOCK_STREAM,
25        Proto => 'tcp',
26        LocalHost => '127.0.0.1',
27        LocalPort => $port,
28        ReusePort => 1,
29        Listen => 5) || die "IO::Socket: $@";
30    return $srv;
31}
32
33# Put a version command down the pipe to ensure the socket is clear.
34# client version commands skip the proxy code
35sub check_version {
36    my $ps = shift;
37    print $ps "version\r\n";
38    like(<$ps>, qr/VERSION /, "version received");
39}
40
41my $p_srv = new_memcached("-o proxy_config=./t/proxyinternal2.lua,slab_chunk_max=32 -t 1");
42my $ps = $p_srv->sock;
43$ps->autoflush(1);
44
45subtest 'basic large item' => sub {
46    my $data = 'x' x 500000;
47    print $ps "set /b/beeeg 0 0 500000\r\n$data\r\n";
48    is(scalar <$ps>, "STORED\r\n", "big item stored");
49
50    print $ps "get /b/beeeg\r\n";
51    is(scalar <$ps>, "VALUE /b/beeeg 0 500000\r\n", "got large response");
52    is(scalar <$ps>, "$data\r\n", "got data portion back");
53    is(scalar <$ps>, "END\r\n", "saw END");
54
55    print $ps "delete /b/beeeg\r\n";
56    is(scalar <$ps>, "DELETED\r\n");
57    check_version($ps);
58};
59
60subtest 'basic chunked item' => sub {
61    my $data = 'x' x 900000;
62    print $ps "set /b/chunked 0 0 900000\r\n$data\r\n";
63    is(scalar <$ps>, "STORED\r\n", "big item stored");
64
65    print $ps "get /b/chunked\r\n";
66    is(scalar <$ps>, "VALUE /b/chunked 0 900000\r\n", "got large response");
67    is(scalar <$ps>, "$data\r\n", "got data portion back");
68    is(scalar <$ps>, "END\r\n", "saw END");
69
70    print $ps "delete /b/chunked\r\n";
71    is(scalar <$ps>, "DELETED\r\n");
72    check_version($ps);
73};
74
75subtest 'flood memory' => sub {
76    # ensure we don't have a basic reference counter leak
77    my $data = 'x' x 500000;
78    for (1 .. 200) {
79        print $ps "set /b/$_ 0 0 500000\r\n$data\r\n";
80        is(scalar <$ps>, "STORED\r\n", "flood set");
81    }
82    for (1 .. 200) {
83        print $ps "ms /b/$_ 500000 T30\r\n$data\r\n";
84        is(scalar <$ps>, "HD\r\n", "flood ms");
85    }
86
87    # overwrite the same value a bunch of times.
88    for (1 .. 200) {
89        print $ps "ms BOOM 500000 T30\r\n$data\r\n";
90        is(scalar <$ps>, "HD\r\n", "flood ms");
91        # fetch to attempt to leak objects
92        mem_get_is($ps, "BOOM", $data);
93    }
94    print $ps "md BOOM\r\n";
95    like(scalar <$ps>, qr/HD|NF/, "deleted");
96
97    check_version($ps);
98};
99
100subtest 'check stats' => sub {
101    # delete things manually since we can't easily call flush_all
102    for (1 .. 200) {
103        print $ps "md /b/$_\r\n";
104        like(scalar <$ps>, qr/HD|NF/, "deleted");
105    }
106    # everything else should've been pushed out of memory by the flood
107
108    my $s = mem_stats($ps, 'slabs');
109    for my $k (keys %$s) {
110        if ($k =~ m/(\d+):used/) {
111            is($s->{$k}, 0, "class " . $k . " is empty")
112            #print STDERR $k, " => ", $s->{$k}, "\n";
113        }
114    }
115    #print STDERR "DUMP:", Dumper($s), "\n";
116};
117
118done_testing();
119