xref: /memcached-1.4.29/t/lib/MemcachedTest.pm (revision 85ca98b5) 
1package MemcachedTest;
2use strict;
3use IO::Socket::INET;
4use IO::Socket::UNIX;
5use Exporter 'import';
6use FindBin qw($Bin);
7use Carp qw(croak);
8use vars qw(@EXPORT);
9
10@EXPORT = qw(new_memcached sleep mem_get_is mem_stats free_port);
11
12sub sleep {
13    my $n = shift;
14    select undef, undef, undef, $n;
15}
16
17sub 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
31sub 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
61sub 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
75sub supports_udp {
76    my $output = `$Bin/../memcached-debug -h`;
77    return 0 if $output =~ /^memcached 1\.1\./;
78    return 1;
79}
80
81sub 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############################################################################
133package Memcached::Handle;
134sub new {
135    my ($class, %params) = @_;
136    return bless \%params, $class;
137}
138
139sub DESTROY {
140    my $self = shift;
141    kill 9, $self->{pid};
142}
143
144sub port { $_[0]{port} }
145sub udpport { $_[0]{udpport} }
146
147sub 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
156sub 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
165sub 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
1761;
177