xref: /memcached-1.4.29/t/lib/MemcachedTest.pm (revision 189b78de) 
1package MemcachedTest;
2use strict;
3use IO::Socket::INET;
4use IO::Socket::UNIX;
5use Exporter 'import';
6use Carp qw(croak);
7use vars qw(@EXPORT);
8
9# Instead of doing the substitution with Autoconf, we assume that
10# cwd == builddir.
11use Cwd;
12my $builddir = getcwd;
13
14
15@EXPORT = qw(new_memcached sleep mem_get_is mem_gets mem_gets_is mem_stats free_port);
16
17sub sleep {
18    my $n = shift;
19    select undef, undef, undef, $n;
20}
21
22sub mem_stats {
23    my ($sock, $type) = @_;
24    $type = $type ? " $type" : "";
25    print $sock "stats$type\r\n";
26    my $stats = {};
27    while (<$sock>) {
28        last if /^(\.|END)/;
29        /^(STAT|ITEM) (\S+)\s+([^\r\n]+)/;
30        #print " slabs: $_";
31        $stats->{$2} = $3;
32    }
33    return $stats;
34}
35
36sub mem_get_is {
37    # works on single-line values only.  no newlines in value.
38    my ($sock_opts, $key, $val, $msg) = @_;
39    my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
40    my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
41
42    my $expect_flags = $opts->{flags} || 0;
43    my $dval = defined $val ? "'$val'" : "<undef>";
44    $msg ||= "$key == $dval";
45
46    print $sock "get $key\r\n";
47    if (! defined $val) {
48        my $line = scalar <$sock>;
49        if ($line =~ /^VALUE/) {
50            $line .= scalar(<$sock>) . scalar(<$sock>);
51        }
52        Test::More::is($line, "END\r\n", $msg);
53    } else {
54        my $len = length($val);
55        my $body = scalar(<$sock>);
56        my $expected = "VALUE $key $expect_flags $len\r\n$val\r\nEND\r\n";
57        if (!$body || $body =~ /^END/) {
58            Test::More::is($body, $expected, $msg);
59            return;
60        }
61        $body .= scalar(<$sock>) . scalar(<$sock>);
62        Test::More::is($body, $expected, $msg);
63    }
64}
65
66sub mem_gets {
67    # works on single-line values only.  no newlines in value.
68    my ($sock_opts, $key) = @_;
69    my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
70    my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
71    my $val;
72    my $expect_flags = $opts->{flags} || 0;
73
74    print $sock "gets $key\r\n";
75    my $response = <$sock>;
76    if ($response =~ /^END/) {
77        return "NOT_FOUND";
78    }
79    else
80    {
81        $response =~ /VALUE (.*) (\d+) (\d+) (\d+)/;
82        my $flags = $2;
83        my $len = $3;
84        my $identifier = $4;
85        read $sock, $val , $len;
86        # get the END
87        $_ = <$sock>;
88        $_ = <$sock>;
89
90        return ($identifier,$val);
91    }
92
93}
94sub mem_gets_is {
95    # works on single-line values only.  no newlines in value.
96    my ($sock_opts, $identifier, $key, $val, $msg) = @_;
97    my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
98    my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
99
100    my $expect_flags = $opts->{flags} || 0;
101    my $dval = defined $val ? "'$val'" : "<undef>";
102    $msg ||= "$key == $dval";
103
104    print $sock "gets $key\r\n";
105    if (! defined $val) {
106        my $line = scalar <$sock>;
107        if ($line =~ /^VALUE/) {
108            $line .= scalar(<$sock>) . scalar(<$sock>);
109        }
110        Test::More::is($line, "END\r\n", $msg);
111    } else {
112        my $len = length($val);
113        my $body = scalar(<$sock>);
114        my $expected = "VALUE $key $expect_flags $len $identifier\r\n$val\r\nEND\r\n";
115        if (!$body || $body =~ /^END/) {
116            Test::More::is($body, $expected, $msg);
117            return;
118        }
119        $body .= scalar(<$sock>) . scalar(<$sock>);
120        Test::More::is($body, $expected, $msg);
121    }
122}
123
124sub free_port {
125    my $type = shift || "tcp";
126    my $sock;
127    my $port;
128    while (!$sock) {
129        $port = int(rand(20000)) + 30000;
130        $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
131                                      LocalPort => $port,
132                                      Proto     => $type,
133                                      ReuseAddr => 1);
134    }
135    return $port;
136}
137
138sub supports_udp {
139    my $output = `$builddir/memcached-debug -h`;
140    return 0 if $output =~ /^memcached 1\.1\./;
141    return 1;
142}
143
144sub new_memcached {
145    my ($args, $passed_port) = @_;
146    my $port = $passed_port || free_port();
147    my $host = '127.0.0.1';
148
149    if ($ENV{T_MEMD_USE_DAEMON}) {
150        my ($host, $port) = ($ENV{T_MEMD_USE_DAEMON} =~ m/^([^:]+):(\d+)$/);
151        my $conn = IO::Socket::INET->new(PeerAddr => "$host:$port");
152        if ($conn) {
153            return Memcached::Handle->new(conn => $conn,
154                                          host => $host,
155                                          port => $port);
156        }
157        croak("Failed to connect to specified memcached server.") unless $conn;
158    }
159
160    my $udpport = free_port("udp");
161    $args .= " -p $port";
162    if (supports_udp()) {
163        $args .= " -U $udpport";
164    }
165    if ($< == 0) {
166        $args .= " -u root";
167    }
168    my $childpid = fork();
169
170    my $exe = "$builddir/memcached-debug";
171    croak("memcached binary doesn't exist.  Haven't run 'make' ?\n") unless -e $exe;
172    croak("memcached binary not executable\n") unless -x _;
173
174    unless ($childpid) {
175        exec "$builddir/timedrun 600 $exe $args";
176        exit; # never gets here.
177    }
178
179    # unix domain sockets
180    if ($args =~ /-s (\S+)/) {
181        sleep 1;
182        my $filename = $1;
183        my $conn = IO::Socket::UNIX->new(Peer => $filename) ||
184            croak("Failed to connect to unix domain socket: $! '$filename'");
185
186        return Memcached::Handle->new(pid  => $childpid,
187                                      conn => $conn,
188                                      domainsocket => $filename,
189                                      host => $host,
190                                      port => $port);
191    }
192
193    # try to connect / find open port, only if we're not using unix domain
194    # sockets
195
196    for (1..20) {
197        my $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
198        if ($conn) {
199            return Memcached::Handle->new(pid  => $childpid,
200                                          conn => $conn,
201                                          udpport => $udpport,
202                                          host => $host,
203                                          port => $port);
204        }
205        select undef, undef, undef, 0.10;
206    }
207    croak("Failed to startup/connect to memcached server.");
208}
209
210############################################################################
211package Memcached::Handle;
212sub new {
213    my ($class, %params) = @_;
214    return bless \%params, $class;
215}
216
217sub DESTROY {
218    my $self = shift;
219    kill 2, $self->{pid};
220}
221
222sub stop {
223    my $self = shift;
224    kill 15, $self->{pid};
225}
226
227sub host { $_[0]{host} }
228sub port { $_[0]{port} }
229sub udpport { $_[0]{udpport} }
230
231sub sock {
232    my $self = shift;
233
234    if ($self->{conn} && ($self->{domainsocket} || getpeername($self->{conn}))) {
235        return $self->{conn};
236    }
237    return $self->new_sock;
238}
239
240sub new_sock {
241    my $self = shift;
242    if ($self->{domainsocket}) {
243        return IO::Socket::UNIX->new(Peer => $self->{domainsocket});
244    } else {
245        return IO::Socket::INET->new(PeerAddr => "$self->{host}:$self->{port}");
246    }
247}
248
249sub new_udp_sock {
250    my $self = shift;
251    return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
252                                 PeerPort => $self->{udpport},
253                                 Proto    => 'udp',
254                                 LocalAddr => '127.0.0.1',
255                                 LocalPort => MemcachedTest::free_port('udp'),
256        );
257
258}
259
2601;
261