"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;