9 # Instead of doing the substitution with Autoconf, we assume that
12 my $builddir = getcwd;
15 @EXPORT = qw(new_memcached sleep mem_get_is mem_gets mem_gets_is mem_stats
16 supports_sasl free_port);
20 select undef, undef, undef, $n;
24 my ($sock, $type) = @_;
25 $type = $type ?
" $type" : "";
26 print $sock "stats$type\r\n";
30 /^(STAT|ITEM) (\S+)\s+([^\r\n]+)/;
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;
43 my $expect_flags = $opts->{flags
} || 0;
44 my $dval = defined $val ?
"'$val'" : "<undef>";
45 $msg ||= "$key == $dval";
47 print $sock "get $key\r\n";
49 my $line = scalar <$sock>;
50 if ($line =~ /^VALUE/) {
51 $line .= scalar(<$sock>) . scalar(<$sock>);
53 Test
::More
::is
($line, "END\r\n", $msg);
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);
62 $body .= scalar(<$sock>) . scalar(<$sock>);
63 Test
::More
::is
($body, $expected, $msg);
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;
73 my $expect_flags = $opts->{flags
} || 0;
75 print $sock "gets $key\r\n";
76 my $response = <$sock>;
77 if ($response =~ /^END/) {
82 $response =~ /VALUE (.*) (\d+) (\d+) (\d+)/;
86 read $sock, $val , $len;
91 return ($identifier,$val);
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;
101 my $expect_flags = $opts->{flags
} || 0;
102 my $dval = defined $val ?
"'$val'" : "<undef>";
103 $msg ||= "$key == $dval";
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>);
111 Test
::More
::is
($line, "END\r\n", $msg);
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);
120 $body .= scalar(<$sock>) . scalar(<$sock>);
121 Test
::More
::is
($body, $expected, $msg);
126 my $type = shift || "tcp";
130 $port = int(rand(20000)) + 30000;
131 $sock = IO
::Socket
::INET
->new(LocalAddr
=> '127.0.0.1',
140 my $output = `$builddir/memcached-debug -h`;
141 return 0 if $output =~ /^memcached 1\.1\./;
146 my $output = `$builddir/memcached-debug -h`;
147 return 1 if $output =~ /sasl/i;
152 my ($args, $passed_port) = @_;
153 my $port = $passed_port || free_port
();
154 my $host = '127.0.0.1';
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");
160 return Memcached
::Handle
->new(conn
=> $conn,
164 croak
("Failed to connect to specified memcached server.") unless $conn;
167 my $udpport = free_port
("udp");
168 $args .= " -p $port";
169 if (supports_udp
()) {
170 $args .= " -U $udpport";
176 my $childpid = fork();
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 _
;
183 exec "$builddir/timedrun 600 $exe $args";
184 exit; # never gets here.
187 # unix domain sockets
188 if ($args =~ /-s (\S+)/) {
191 my $conn = IO
::Socket
::UNIX
->new(Peer
=> $filename) ||
192 croak
("Failed to connect to unix domain socket: $! '$filename'");
194 return Memcached
::Handle
->new(pid
=> $childpid,
196 domainsocket
=> $filename,
201 # try to connect / find open port, only if we're not using unix domain
205 my $conn = IO
::Socket
::INET
->new(PeerAddr
=> "127.0.0.1:$port");
207 return Memcached
::Handle
->new(pid
=> $childpid,
213 select undef, undef, undef, 0.10;
215 croak
("Failed to startup/connect to memcached server.");
218 ############################################################################
219 package Memcached
::Handle
;
221 my ($class, %params) = @_;
222 return bless \
%params, $class;
227 kill 2, $self->{pid
};
232 kill 15, $self->{pid
};
235 sub host
{ $_[0]{host
} }
236 sub port
{ $_[0]{port
} }
237 sub udpport
{ $_[0]{udpport
} }
242 if ($self->{conn
} && ($self->{domainsocket
} || getpeername($self->{conn
}))) {
243 return $self->{conn
};
245 return $self->new_sock;
250 if ($self->{domainsocket
}) {
251 return IO
::Socket
::UNIX
->new(Peer
=> $self->{domainsocket
});
253 return IO
::Socket
::INET
->new(PeerAddr
=> "$self->{host}:$self->{port}");
259 return IO
::Socket
::INET
->new(PeerAddr
=> '127.0.0.1',
260 PeerPort
=> $self->{udpport
},
262 LocalAddr
=> '127.0.0.1',
263 LocalPort
=> MemcachedTest
::free_port
('udp'),