Mercurial > hg > memcached

comparison t/lib/MemcachedTest.pm @ 0:30782bb1fc04 MEMCACHED_1_2_3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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;