← Back to branch summary

~brianaker/libmemcached/1164440

« back to all changes in this revision

Viewing changes to memcached/t/lib/MemcachedTest.pm

Merge working tree with build tree.

Show diffs side-by-side

added added

removed removed

Lines of Context:
memcached/t/lib/MemcachedTest.pm
 
1
package MemcachedTest;
 
2
use strict;
 
3
use IO::Socket::INET;
 
4
use IO::Socket::UNIX;
 
5
use Exporter 'import';
 
6
use Carp qw(croak);
 
7
use vars qw(@EXPORT);
 
8
 
 
9
# Instead of doing the substitution with Autoconf, we assume that
 
10
# cwd == builddir.
 
11
use Cwd;
 
12
my $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
 
 
18
sub sleep {
 
19
    my $n = shift;
 
20
    select undef, undef, undef, $n;
 
21
}
 
22
 
 
23
sub 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
 
 
37
sub 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
 
 
67
sub 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
}
 
95
sub 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
 
 
125
sub 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
 
 
139
sub supports_udp {
 
140
    my $output = `$builddir/memcached-debug -h`;
 
141
    return 0 if $output =~ /^memcached 1\.1\./;
 
142
    return 1;
 
143
}
 
144
 
 
145
sub supports_sasl {
 
146
    my $output = `$builddir/memcached-debug -h`;
 
147
    return 1 if $output =~ /sasl/i;
 
148
    return 0;
 
149
}
 
150
 
 
151
sub 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
############################################################################
 
219
package Memcached::Handle;
 
220
sub new {
 
221
    my ($class, %params) = @_;
 
222
    return bless \%params, $class;
 
223
}
 
224
 
 
225
sub DESTROY {
 
226
    my $self = shift;
 
227
    kill 2, $self->{pid};
 
228
}
 
229
 
 
230
sub stop {
 
231
    my $self = shift;
 
232
    kill 15, $self->{pid};
 
233
}
 
234
 
 
235
sub host { $_[0]{host} }
 
236
sub port { $_[0]{port} }
 
237
sub udpport { $_[0]{udpport} }
 
238
 
 
239
sub 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
 
 
248
sub 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
 
 
257
sub 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
 
 
268
1;