git.m6w6.name Git - awesomized/libmemcached/blob - memcached/t/lib/MemcachedTest.pm

   1 package MemcachedTest;
   2 use strict;
   3 use IO::Socket::INET;
   4 use IO::Socket::UNIX;
   5 use Exporter 'import';
   6 use Carp qw(croak);
   7 use vars qw(@EXPORT);
   8
   9 # Instead of doing the substitution with Autoconf, we assume that
  10 # cwd == builddir.
  11 use Cwd;
  12 my $builddir = getcwd;
  13
  14
  15 @EXPORT = qw(new_memcached sleep mem_get_is mem_gets mem_gets_is mem_stats
  16              supports_sasl free_port);
  17
  18 sub sleep {
  19     my $n = shift;
  20     select undef, undef, undef, $n;
  21 }
  22
  23 sub mem_stats {
  24     my ($sock, $type) = @_;
  25     $type = $type ? " $type" : "";
  26     print $sock "stats$type\r\n";
  27     my $stats = {};
  28     while (<$sock>) {
  29         last if /^(\.|END)/;
  30         /^(STAT|ITEM) (\S+)\s+([^\r\n]+)/;
  31         #print " slabs: $_";
  32         $stats->{$2} = $3;
  33     }
  34     return $stats;
  35 }
  36
  37 sub mem_get_is {
  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;
  42
  43     my $expect_flags = $opts->{flags} || 0;
  44     my $dval = defined $val ? "'$val'" : "<undef>";
  45     $msg ||= "$key == $dval";
  46
  47     print $sock "get $key\r\n";
  48     if (! defined $val) {
  49         my $line = scalar <$sock>;
  50         if ($line =~ /^VALUE/) {
  51             $line .= scalar(<$sock>) . scalar(<$sock>);
  52         }
  53         Test::More::is($line, "END\r\n", $msg);
  54     } else {
  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);
  60             return;
  61         }
  62         $body .= scalar(<$sock>) . scalar(<$sock>);
  63         Test::More::is($body, $expected, $msg);
  64     }
  65 }
  66
  67 sub mem_gets {
  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;
  72     my $val;
  73     my $expect_flags = $opts->{flags} || 0;
  74
  75     print $sock "gets $key\r\n";
  76     my $response = <$sock>;
  77     if ($response =~ /^END/) {
  78         return "NOT_FOUND";
  79     }
  80     else
  81     {
  82         $response =~ /VALUE (.*) (\d+) (\d+) (\d+)/;
  83         my $flags = $2;
  84         my $len = $3;
  85         my $identifier = $4;
  86         read $sock, $val , $len;
  87         # get the END
  88         $_ = <$sock>;
  89         $_ = <$sock>;
  90
  91         return ($identifier,$val);
  92     }
  93
  94 }
  95 sub mem_gets_is {
  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;
 100
 101     my $expect_flags = $opts->{flags} || 0;
 102     my $dval = defined $val ? "'$val'" : "<undef>";
 103     $msg ||= "$key == $dval";
 104
 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>);
 110         }
 111         Test::More::is($line, "END\r\n", $msg);
 112     } else {
 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);
 118             return;
 119         }
 120         $body .= scalar(<$sock>) . scalar(<$sock>);
 121         Test::More::is($body, $expected, $msg);
 122     }
 123 }
 124
 125 sub free_port {
 126     my $type = shift || "tcp";
 127     my $sock;
 128     my $port;
 129     while (!$sock) {
 130         $port = int(rand(20000)) + 30000;
 131         $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
 132                                       LocalPort => $port,
 133                                       Proto     => $type,
 134                                       ReuseAddr => 1);
 135     }
 136     return $port;
 137 }
 138
 139 sub supports_udp {
 140     my $output = `$builddir/memcached-debug -h`;
 141     return 0 if $output =~ /^memcached 1\.1\./;
 142     return 1;
 143 }
 144
 145 sub supports_sasl {
 146     my $output = `$builddir/memcached-debug -h`;
 147     return 1 if $output =~ /sasl/i;
 148     return 0;
 149 }
 150
 151 sub new_memcached {
 152     my ($args, $passed_port) = @_;
 153     my $port = $passed_port || free_port();
 154     my $host = '127.0.0.1';
 155
 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");
 159         if ($conn) {
 160             return Memcached::Handle->new(conn => $conn,
 161                                           host => $host,
 162                                           port => $port);
 163         }
 164         croak("Failed to connect to specified memcached server.") unless $conn;
 165     }
 166
 167     my $udpport = free_port("udp");
 168     $args .= " -p $port";
 169     if (supports_udp()) {
 170         $args .= " -U $udpport";
 171     }
 172     if ($< == 0) {
 173         $args .= " -u root";
 174     }
 175
 176     my $childpid = fork();
 177
 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 _;
 181
 182     unless ($childpid) {
 183         exec "$builddir/timedrun 600 $exe $args";
 184         exit; # never gets here.
 185     }
 186
 187     # unix domain sockets
 188     if ($args =~ /-s (\S+)/) {
 189         sleep 1;
 190         my $filename = $1;
 191         my $conn = IO::Socket::UNIX->new(Peer => $filename) ||
 192             croak("Failed to connect to unix domain socket: $! '$filename'");
 193
 194         return Memcached::Handle->new(pid  => $childpid,
 195                                       conn => $conn,
 196                                       domainsocket => $filename,
 197                                       host => $host,
 198                                       port => $port);
 199     }
 200
 201     # try to connect / find open port, only if we're not using unix domain
 202     # sockets
 203
 204     for (1..20) {
 205         my $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
 206         if ($conn) {
 207             return Memcached::Handle->new(pid  => $childpid,
 208                                           conn => $conn,
 209                                           udpport => $udpport,
 210                                           host => $host,
 211                                           port => $port);
 212         }
 213         select undef, undef, undef, 0.10;
 214     }
 215     croak("Failed to startup/connect to memcached server.");
 216 }
 217
 218 ############################################################################
 219 package Memcached::Handle;
 220 sub new {
 221     my ($class, %params) = @_;
 222     return bless \%params, $class;
 223 }
 224
 225 sub DESTROY {
 226     my $self = shift;
 227     kill 2, $self->{pid};
 228 }
 229
 230 sub stop {
 231     my $self = shift;
 232     kill 15, $self->{pid};
 233 }
 234
 235 sub host { $_[0]{host} }
 236 sub port { $_[0]{port} }
 237 sub udpport { $_[0]{udpport} }
 238
 239 sub sock {
 240     my $self = shift;
 241
 242     if ($self->{conn} && ($self->{domainsocket} || getpeername($self->{conn}))) {
 243         return $self->{conn};
 244     }
 245     return $self->new_sock;
 246 }
 247
 248 sub new_sock {
 249     my $self = shift;
 250     if ($self->{domainsocket}) {
 251         return IO::Socket::UNIX->new(Peer => $self->{domainsocket});
 252     } else {
 253         return IO::Socket::INET->new(PeerAddr => "$self->{host}:$self->{port}");
 254     }
 255 }
 256
 257 sub new_udp_sock {
 258     my $self = shift;
 259     return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
 260                                  PeerPort => $self->{udpport},
 261                                  Proto    => 'udp',
 262                                  LocalAddr => '127.0.0.1',
 263                                  LocalPort => MemcachedTest::free_port('udp'),
 264         );
 265
 266 }
 267
 268 1;