Mercurial > hg > memcached
comparison t/lib/MemcachedTest.pm @ 0:30782bb1fc04 MEMCACHED_1_2_3
memcached-1.2.3
author | Maxim Dounin <mdounin@mdounin.ru> |
---|---|
date | Sun, 23 Sep 2007 03:58:34 +0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:30782bb1fc04 |
---|---|
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; |