"Fossies" - the Fresh Open Source Software Archive 
Member "memcached-1.6.15/t/lib/MemcachedTest.pm" (21 Feb 2022, 14270 Bytes) of package /linux/www/memcached-1.6.15.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
See also the last
Fossies "Diffs" side-by-side code changes report for "MemcachedTest.pm":
1.6.12_vs_1.6.13.
1 package MemcachedTest;
2 use strict;
3 use IO::Socket::INET;
4 use IO::Socket::UNIX;
5 use POSIX ":sys_wait_h";
6 use Exporter 'import';
7 use Carp qw(croak);
8 use vars qw(@EXPORT);
9
10 # Instead of doing the substitution with Autoconf, we assume that
11 # cwd == builddir.
12 use Cwd;
13 my $builddir = getcwd;
14
15 my @unixsockets = ();
16
17 @EXPORT = qw(new_memcached sleep
18 mem_get_is mem_gets mem_gets_is mem_stats mem_move_time
19 supports_sasl free_port supports_drop_priv supports_extstore
20 wait_ext_flush supports_tls enabled_tls_testing run_help
21 supports_unix_socket get_memcached_exe supports_proxy);
22
23 use constant MAX_READ_WRITE_SIZE => 16384;
24 use constant SRV_CRT => "server_crt.pem";
25 use constant SRV_KEY => "server_key.pem";
26 use constant CLIENT_CRT => "client_crt.pem";
27 use constant CLIENT_KEY => "client_key.pem";
28 use constant CA_CRT => "cacert.pem";
29
30 my $testdir = $builddir . "/t/";
31 my $client_crt = $testdir. CLIENT_CRT;
32 my $client_key = $testdir. CLIENT_KEY;
33 my $server_crt = $testdir . SRV_CRT;
34 my $server_key = $testdir . SRV_KEY;
35
36 my $tls_checked = 0;
37
38 sub sleep {
39 my $n = shift;
40 select undef, undef, undef, $n;
41 }
42
43 # Wait until all items have flushed
44 sub wait_ext_flush {
45 my $sock = shift;
46 my $target = shift || 0;
47 my $sum = $target + 1;
48 while ($sum > $target) {
49 my $s = mem_stats($sock, "items");
50 $sum = 0;
51 for my $key (keys %$s) {
52 if ($key =~ m/items:(\d+):number/) {
53 # Ignore classes which can contain extstore items
54 next if $1 < 3;
55 $sum += $s->{$key};
56 }
57 }
58 sleep 1 if $sum > $target;
59 }
60 }
61
62 sub mem_stats {
63 my ($sock, $type) = @_;
64 $type = $type ? " $type" : "";
65 print $sock "stats$type\r\n";
66 my $stats = {};
67 while (<$sock>) {
68 last if /^(\.|END)/;
69 /^(STAT|ITEM) (\S+)\s+([^\r\n]+)/;
70 #print " slabs: $_";
71 $stats->{$2} = $3;
72 }
73 return $stats;
74 }
75
76 sub mem_move_time {
77 my ($sock, $move) = @_;
78 print $sock "debugtime $move\r\n";
79 <$sock>;
80 }
81
82 sub mem_get_is {
83 # works on single-line values only. no newlines in value.
84 my ($sock_opts, $key, $val, $msg) = @_;
85 my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
86 my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
87
88 my $expect_flags = $opts->{flags} || 0;
89 my $dval = defined $val ? "'$val'" : "<undef>";
90 $msg ||= "$key == $dval";
91
92 print $sock "get $key\r\n";
93 if (! defined $val) {
94 my $line = scalar <$sock>;
95 if ($line =~ /^VALUE/) {
96 $line .= scalar(<$sock>) . scalar(<$sock>);
97 }
98 Test::More::is($line, "END\r\n", $msg);
99 } else {
100 my $len = length($val);
101 my $body = scalar(<$sock>);
102 my $expected = "VALUE $key $expect_flags $len\r\n$val\r\nEND\r\n";
103 if (!$body || $body =~ /^END/) {
104 Test::More::is($body, $expected, $msg);
105 return;
106 }
107 $body .= scalar(<$sock>) . scalar(<$sock>);
108 Test::More::is($body, $expected, $msg);
109 }
110 }
111
112 sub mem_gets {
113 # works on single-line values only. no newlines in value.
114 my ($sock_opts, $key) = @_;
115 my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
116 my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
117 my $val;
118 my $expect_flags = $opts->{flags} || 0;
119
120 print $sock "gets $key\r\n";
121 my $response = <$sock>;
122 if ($response =~ /^END/) {
123 return "NOT_FOUND";
124 }
125 else
126 {
127 $response =~ /VALUE (.*) (\d+) (\d+) (\d+)/;
128 my $flags = $2;
129 my $len = $3;
130 my $identifier = $4;
131 read $sock, $val , $len;
132 # get the END
133 $_ = <$sock>;
134 $_ = <$sock>;
135
136 return ($identifier,$val);
137 }
138
139 }
140 sub mem_gets_is {
141 # works on single-line values only. no newlines in value.
142 my ($sock_opts, $identifier, $key, $val, $msg) = @_;
143 my $opts = ref $sock_opts eq "HASH" ? $sock_opts : {};
144 my $sock = ref $sock_opts eq "HASH" ? $opts->{sock} : $sock_opts;
145
146 my $expect_flags = $opts->{flags} || 0;
147 my $dval = defined $val ? "'$val'" : "<undef>";
148 $msg ||= "$key == $dval";
149
150 print $sock "gets $key\r\n";
151 if (! defined $val) {
152 my $line = scalar <$sock>;
153 if ($line =~ /^VALUE/) {
154 $line .= scalar(<$sock>) . scalar(<$sock>);
155 }
156 Test::More::is($line, "END\r\n", $msg);
157 } else {
158 my $len = length($val);
159 my $body = scalar(<$sock>);
160 my $expected = "VALUE $key $expect_flags $len $identifier\r\n$val\r\nEND\r\n";
161 if (!$body || $body =~ /^END/) {
162 Test::More::is($body, $expected, $msg);
163 return;
164 }
165 $body .= scalar(<$sock>) . scalar(<$sock>);
166 Test::More::is($body, $expected, $msg);
167 }
168 }
169
170 sub free_port {
171 my $type = shift || "tcp";
172 my $sock;
173 my $port;
174 while (!$sock) {
175 $port = int(rand(20000)) + 30000;
176 if (enabled_tls_testing()) {
177 $sock = eval qq{ IO::Socket::SSL->new(LocalAddr => '127.0.0.1',
178 LocalPort => $port,
179 Proto => '$type',
180 ReuseAddr => 1,
181 SSL_verify_mode => SSL_VERIFY_NONE);
182 };
183 die $@ if $@; # sanity check.
184 } else {
185 $sock = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
186 LocalPort => $port,
187 Proto => $type,
188 ReuseAddr => 1);
189 }
190 }
191 return $port;
192 }
193
194 sub print_help {
195 my $exe = get_memcached_exe();
196 my $output = `$exe -h`;
197 return $output;
198 }
199
200 sub supports_udp {
201 my $output = print_help();
202 return 0 if $output =~ /^memcached 1\.1\./;
203 return 1;
204 }
205
206 sub supports_sasl {
207 my $output = print_help();
208 return 1 if $output =~ /sasl/i;
209 return 0;
210 }
211
212 sub supports_extstore {
213 my $output = print_help();
214 return 1 if $output =~ /ext_path/i;
215 return 0;
216 }
217
218 sub supports_proxy {
219 my $output = print_help();
220 return 1 if $output =~ /proxy_config/i;
221 return 0;
222 }
223
224 sub supports_tls {
225 my $output = print_help();
226 return 1 if $output =~ /enable-ssl/i;
227 return 0;
228 }
229
230 sub supports_unix_socket {
231 my $output = print_help();
232 return 1 if $output =~ /unix-socket/i;
233 return 0;
234 }
235
236 sub enabled_tls_testing {
237 if ($tls_checked) {
238 return 1;
239 } elsif (supports_tls() && $ENV{SSL_TEST}) {
240 eval "use IO::Socket::SSL";
241 croak("IO::Socket::SSL not installed or failed to load, cannot run SSL tests as requested") if $@;
242 $tls_checked = 1;
243 return 1;
244 }
245 }
246
247 sub supports_drop_priv {
248 my $output = print_help();
249 return 1 if $output =~ /no_drop_privileges/i;
250 return 0;
251 }
252
253 sub get_memcached_exe {
254 my $exe = "$builddir/memcached-debug";
255 croak("memcached binary doesn't exist. Haven't run 'make' ?\n") unless -e $exe;
256 croak("memcached binary not executable\n") unless -x _;
257 return $exe;
258 }
259
260 sub run_help {
261 my $exe = get_memcached_exe();
262 return system("$exe -h");
263 }
264
265 # -1 if the pid is actually dead.
266 sub is_running {
267 return waitpid($_[0], WNOHANG) >= 0 ? 1 : 0;
268 }
269
270 sub new_memcached {
271 my ($args, $passed_port) = @_;
272 my $port = $passed_port;
273 my $host = '127.0.0.1';
274 my $ssl_enabled = enabled_tls_testing();
275 my $unix_socket_disabled = !supports_unix_socket();
276
277 if ($ENV{T_MEMD_USE_DAEMON}) {
278 my ($host, $port) = ($ENV{T_MEMD_USE_DAEMON} =~ m/^([^:]+):(\d+)$/);
279 my $conn;
280 if ($ssl_enabled) {
281 $conn = eval qq{IO::Socket::SSL->new(PeerAddr => "$host:$port",
282 SSL_verify_mode => SSL_VERIFY_NONE,
283 SSL_cert_file => '$client_crt',
284 SSL_key_file => '$client_key');
285 };
286 die $@ if $@; # sanity check.
287 } else {
288 $conn = IO::Socket::INET->new(PeerAddr => "$host:$port");
289 }
290 if ($conn) {
291 return Memcached::Handle->new(conn => $conn,
292 host => $host,
293 port => $port);
294 }
295 croak("Failed to connect to specified memcached server.") unless $conn;
296 }
297
298 if ($< == 0) {
299 $args .= " -u root";
300 }
301 $args .= " -o relaxed_privileges";
302
303 my $udpport;
304 if ($args =~ /-l (\S+)/ || (($ssl_enabled || $unix_socket_disabled) && ($args !~ /-s (\S+)/))) {
305 if (!$port) {
306 $port = free_port();
307 }
308 $udpport = free_port("udp");
309 $args .= " -p $port";
310 if (supports_udp() && $args !~ /-U (\S+)/) {
311 $args .= " -U $udpport";
312 }
313 if ($ssl_enabled) {
314 $args .= " -Z";
315 if ($args !~ /-o ssl_chain_cert=(\S+)/) {
316 $args .= " -o ssl_chain_cert=$server_crt";
317 }
318 if ($args !~ /-o ssl_key=(\S+)/) {
319 $args .= " -o ssl_key=$server_key";
320 }
321 }
322 } elsif ($args !~ /-s (\S+)/) {
323 my $num = @unixsockets;
324 my $file = "/tmp/memcachetest.$$.$num";
325 $args .= " -s $file";
326 push(@unixsockets, $file);
327 }
328
329 my $childpid = fork();
330
331 my $exe = get_memcached_exe();
332
333 unless ($childpid) {
334 my $valgrind = "";
335 my $valgrind_args = "--quiet --error-exitcode=1 --exit-on-first-error=yes";
336 if ($ENV{VALGRIND_ARGS}) {
337 $valgrind_args = $ENV{VALGRIND_ARGS};
338 }
339 if ($ENV{VALGRIND_TEST}) {
340 $valgrind = "valgrind $valgrind_args";
341 # NOTE: caller file stuff.
342 $valgrind .= " $ENV{VALGRIND_EXTRA_ARGS}";
343 }
344 my $cmd = "$builddir/timedrun 600 $valgrind $exe $args";
345 #print STDERR "RUN: $cmd\n\n";
346 exec $cmd;
347 exit; # never gets here.
348 }
349
350 # unix domain sockets
351 if ($args =~ /-s (\S+)/) {
352 # A slow/emulated/valgrinded/etc system may take longer than a second
353 # for the unix socket to appear.
354 my $filename = $1;
355 for (1..20) {
356 sleep 1;
357 my $conn = IO::Socket::UNIX->new(Peer => $filename);
358
359 if ($conn) {
360 return Memcached::Handle->new(pid => $childpid,
361 conn => $conn,
362 domainsocket => $filename,
363 host => $host,
364 port => $port);
365 } else {
366 croak("Failed to connect to unix socket: memcached not running") unless is_running($childpid);
367 sleep 1;
368 }
369 }
370 croak("Failed to connect to unix domain socket: $! '$filename'") if $@;
371 }
372
373 # try to connect / find open port, only if we're not using unix domain
374 # sockets
375
376 for (1..80) {
377 my $conn;
378 if ($ssl_enabled) {
379 $conn = eval qq{ IO::Socket::SSL->new(PeerAddr => "127.0.0.1:$port",
380 SSL_verify_mode => SSL_VERIFY_NONE,
381 SSL_cert_file => '$client_crt',
382 SSL_key_file => '$client_key');
383 };
384 die $@ if $@; # sanity check.
385 } else {
386 $conn = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
387 }
388 if ($conn) {
389 return Memcached::Handle->new(pid => $childpid,
390 conn => $conn,
391 udpport => $udpport,
392 host => $host,
393 port => $port);
394 }
395 croak("Failed to connect: memcached not running") unless is_running($childpid);
396 select undef, undef, undef, 0.25;
397 }
398 croak("Failed to startup/connect to memcached server.");
399 }
400
401 END {
402 for (@unixsockets) {
403 unlink $_;
404 }
405 }
406
407 ############################################################################
408 package Memcached::Handle;
409 use POSIX ":sys_wait_h";
410 sub new {
411 my ($class, %params) = @_;
412 return bless \%params, $class;
413 }
414
415 sub DESTROY {
416 my $self = shift;
417 kill 2, $self->{pid};
418 }
419
420 sub stop {
421 my $self = shift;
422 kill 15, $self->{pid};
423 }
424
425 sub graceful_stop {
426 my $self = shift;
427 kill 'SIGUSR1', $self->{pid};
428 }
429
430 # -1 if the pid is actually dead.
431 sub is_running {
432 my $self = shift;
433 return waitpid($self->{pid}, WNOHANG) >= 0 ? 1 : 0;
434 }
435
436 sub host { $_[0]{host} }
437 sub port { $_[0]{port} }
438 sub udpport { $_[0]{udpport} }
439
440 sub sock {
441 my $self = shift;
442
443 if ($self->{conn} && ($self->{domainsocket} || getpeername($self->{conn}))) {
444 return $self->{conn};
445 }
446 return $self->new_sock;
447 }
448
449 sub new_sock {
450 my $self = shift;
451 if ($self->{domainsocket}) {
452 return IO::Socket::UNIX->new(Peer => $self->{domainsocket});
453 } elsif (MemcachedTest::enabled_tls_testing()) {
454 my $ssl_session_cache = shift;
455 my $ssl_version = shift;
456 return eval qq{ IO::Socket::SSL->new(PeerAddr => "$self->{host}:$self->{port}",
457 SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
458 SSL_session_cache => \$ssl_session_cache,
459 SSL_version => '$ssl_version',
460 SSL_cert_file => '$client_crt',
461 SSL_key_file => '$client_key');
462 };
463 } else {
464 return IO::Socket::INET->new(PeerAddr => "$self->{host}:$self->{port}");
465 }
466 }
467
468 sub new_udp_sock {
469 my $self = shift;
470 return IO::Socket::INET->new(PeerAddr => '127.0.0.1',
471 PeerPort => $self->{udpport},
472 Proto => 'udp',
473 LocalAddr => '127.0.0.1',
474 LocalPort => MemcachedTest::free_port('udp'),
475 );
476
477 }
478
479 1;