|
0
|
1 package MemcachedTest;
|
|
|
2 use strict;
|
|
|
3 use IO::Socket::INET;
|
|
|
4 use IO::Socket::UNIX;
|
|
|
5 use Exporter 'import';
|
|
|
6 use FindBin qw($Bin);
|
|
|
7 use Carp qw(croak);
|
|
|
8 use vars qw(@EXPORT);
|
|
|
9
|
|
|
10 @EXPORT = qw(new_memcached sleep mem_get_is mem_stats free_port);
|
|
|
11
|
|
|
12 sub sleep {
|
|
|
13 my $n = shift;
|
|
|
14 select undef, undef, undef, $n;
|
|
|
15 }
|
|
|
16
|
|
|
17 sub mem_stats {
|
|
|
18 my ($sock, $type) = @_;
|
|
|
19 $type = $type ? " $type" : "";
|
|
|
20 print $sock "stats$type\r\n";
|
|
|
21 my $stats = {};
|
|
|
22 while (<$sock>) {
|
|
|
23 last if /^(\.|END)/;
|
|
|
24 /^STAT (\S+) (\d+)/;
|
|
|
25 #print " slabs: $_";
|
|
|
26 $stats->{$1} = $2;
|
|
|
27 }
|
|
|
28 return $stats;
|
|
|
29 }
|
|
|
30
|
|
|
31 sub mem_get_is {
|
|
|
32 # works on single-line values only. no newlines in value.
|
|
|
33 my ($sock_opts, $key, $val, $msg) = @_;
|
|
|
34 my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
|
|
|
35 my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
|
|
|
36
|
|
|
37 my $expect_flags = $opts->{flags} || 0;
|
|
|
38 my $dval = defined $val ? "'$val'" : "<undef>";
|
|
|
39 $msg ||= "$key == $dval";
|
|
|
40
|
|
|
41 print $sock "get $key\r\n";
|
|
|
42 if (! defined $val) {
|
|
|
43 my $line = scalar <$sock>;
|
|
|
44 if ($line =~ /^VALUE/) {
|
|
|
45 $line .= scalar(<$sock>) . scalar(<$sock>);
|
|
|
46 }
|
|
|
47 Test::More::is($line, "END\r\n", $msg);
|
|
|
48 } else {
|
|
|
49 my $len = length($val);
|
|
|
50 my $body = scalar(<$sock>);
|
|
|
51 my $expected = "VALUE $key $expect_flags $len\r\n$val\r\nEND\r\n";
|
|
|
52 if (!$body || $body =~ /^END/) {
|
|
|
53 Test::More::is($body, $expected, $msg);
|
|
|
54 return;
|
|
|
55 }
|
|
|
56 $body .= scalar(<$sock>) . scalar(<$sock>);
|
|
|
57 Test::More::is($body, $expected, $msg);
|
|
|
58 }
|
|
|
59 }
|
|
|
60
|
|
|
61 sub free_port {
|
|
|
62 my $type = shift || "tcp";
|
|
|
63 my $sock;
|
|
|
64 my $port;
|
|
|
65 while (!$sock) {
|
|
|
66 $port = int(rand(20000)) + 30000;
|
|
|
67 $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
|
|
|
68 LocalPort => $port,
|
|
|
69 Proto => $type,
|
|
|
70 ReuseAddr => 1);
|
|
|
71 }
|
|
|
72 return $port;
|
|
|
73 }
|
|
|
74
|
|
|
75 sub supports_udp {
|
|
|
76 my $output = `$Bin/../memcached-debug -h`;
|
|
|
77 return 0 if $output =~ /^memcached 1\.1\./;
|
|
|
78 return 1;
|
|
|
79 }
|
|
|
80
|
|
|
81 sub new_memcached {
|
|
|
82 my $args = shift || "";
|
|
|
83 my $port = free_port();
|
|
|
84 my $udpport = free_port("udp");
|
|
|
85 $args .= " -p $port";
|
|
|
86 if (supports_udp()) {
|
|
|
87 $args .= " -U $udpport";
|
|
|
88 }
|
|
|
89 if ($< == 0) {
|
|
|
90 $args .= " -u root";
|
|
|
91 }
|
|
|
92 my $childpid = fork();
|
|
|
93
|
|
|
94 my $exe = "$Bin/../memcached-debug";
|
|
|
95 croak("memcached binary doesn't exist. Haven't run 'make' ?\n") unless -e $exe;
|
|
|
96 croak("memcached binary not executable\n") unless -x _;
|
|
|
97
|
|
|
98 unless ($childpid) {
|
|
|
99 exec "$exe $args";
|
|
|
100 exit; # never gets here.
|
|
|
101 }
|
|
|
102
|
|
|
103 # unix domain sockets
|
|
|
104 if ($args =~ /-s (\S+)/) {
|
|
|
105 sleep 1;
|
|
|
106 my $filename = $1;
|
|
|
107 my $conn = IO::Socket::UNIX->new(Peer => $filename) ||
|
|
|
108 croak("Failed to connect to unix domain socket: $! '$filename'");
|
|
|
109
|
|
|
110 return Memcached::Handle->new(pid => $childpid,
|
|
|
111 conn => $conn,
|
|
|
112 domainsocket => $filename,
|
|
|
113 port => $port);
|
|
|
114 }
|
|
|
115
|
|
|
116 # try to connect / find open port, only if we're not using unix domain
|
|
|
117 # sockets
|
|
|
118
|
|
|
119 for (1..20) {
|
|
|
120 my $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
|
|
|
121 if ($conn) {
|
|
|
122 return Memcached::Handle->new(pid => $childpid,
|
|
|
123 conn => $conn,
|
|
|
124 udpport => $udpport,
|
|
|
125 port => $port);
|
|
|
126 }
|
|
|
127 select undef, undef, undef, 0.10;
|
|
|
128 }
|
|
|
129 croak("Failed to startup/connect to memcached server.");
|
|
|
130 }
|
|
|
131
|
|
|
132 ############################################################################
|
|
|
133 package Memcached::Handle;
|
|
|
134 sub new {
|
|
|
135 my ($class, %params) = @_;
|
|
|
136 return bless \%params, $class;
|
|
|
137 }
|
|
|
138
|
|
|
139 sub DESTROY {
|
|
|
140 my $self = shift;
|
|
|
141 kill 9, $self->{pid};
|
|
|
142 }
|
|
|
143
|
|
|
144 sub port { $_[0]{port} }
|
|
|
145 sub udpport { $_[0]{udpport} }
|
|
|
146
|
|
|
147 sub sock {
|
|
|
148 my $self = shift;
|
|
|
149
|
|
|
150 if ($self->{conn} && ($self->{domainsocket} || getpeername($self->{conn}))) {
|
|
|
151 return $self->{conn};
|
|
|
152 }
|
|
|
153 return $self->new_sock;
|
|
|
154 }
|
|
|
155
|
|
|
156 sub new_sock {
|
|
|
157 my $self = shift;
|
|
|
158 if ($self->{domainsocket}) {
|
|
|
159 return IO::Socket::UNIX->new(Peer => $self->{domainsocket});
|
|
|
160 } else {
|
|
|
161 return IO::Socket::INET->new(PeerAddr => "127.0.0.1:$self->{port}");
|
|
|
162 }
|
|
|
163 }
|
|
|
164
|
|
|
165 sub new_udp_sock {
|
|
|
166 my $self = shift;
|
|
|
167 return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
|
|
|
168 PeerPort => $self->{udpport},
|
|
|
169 Proto => 'udp',
|
|
|
170 LocalAddr => '127.0.0.1',
|
|
|
171 LocalPort => MemcachedTest::free_port('udp'),
|
|
|
172 );
|
|
|
173
|
|
|
174 }
|
|
|
175
|
|
|
176 1;
|
