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