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