"Fossies" - the Fresh Open Source Software Archive

Member "memcached-1.6.9/t/lib/MemcachedTest.pm" (21 Nov 2020, 13807 Bytes) of package /linux/www/memcached-1.6.9.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 latest Fossies "Diffs" side-by-side code changes report for "MemcachedTest.pm": 1.6.8_vs_1.6.9.

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