"Fossies" - the Fresh Open Source Software Archive

Member "memcached-1.6.15/t/udp.t" (21 Feb 2022, 10236 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.

    1 #!/usr/bin/perl
    2 
    3 use strict;
    4 use Test::More tests => 67;
    5 use FindBin qw($Bin);
    6 use lib "$Bin/lib";
    7 use MemcachedTest;
    8 
    9 use constant IS_ASCII         => 0;
   10 use constant IS_BINARY        => 1;
   11 use constant ENTRY_EXISTS     => 0;
   12 use constant ENTRY_MISSING    => 1;
   13 use constant BIN_REQ_MAGIC    => 0x80;
   14 use constant BIN_RES_MAGIC    => 0x81;
   15 use constant CMD_GET          => 0x00;
   16 use constant CMD_SET          => 0x01;
   17 use constant CMD_ADD          => 0x02;
   18 use constant CMD_REPLACE      => 0x03;
   19 use constant CMD_DELETE       => 0x04;
   20 use constant CMD_INCR         => 0x05;
   21 use constant CMD_DECR         => 0x06;
   22 use constant CMD_APPEND       => 0x0E;
   23 use constant CMD_PREPEND      => 0x0F;
   24 use constant REQ_PKT_FMT      => "CCnCCnNNNN";
   25 use constant RES_PKT_FMT      => "CCnCCnNNNN";
   26 use constant INCRDECR_PKT_FMT => "NNNNN";
   27 use constant MIN_RECV_BYTES   => length(pack(RES_PKT_FMT));
   28 
   29 
   30 my $server = new_memcached("-l 127.0.0.1");
   31 my $sock = $server->sock;
   32 
   33 # set foo (and should get it)
   34 print $sock "set foo 0 0 6\r\nfooval\r\n";
   35 is(scalar <$sock>, "STORED\r\n", "stored foo");
   36 mem_get_is($sock, "foo", "fooval");
   37 
   38 my $usock = $server->new_udp_sock
   39     or die "Can't bind : $@\n";
   40 
   41 # testing sequence of request ids
   42 for my $offt (1, 1, 2) {
   43     my $req = 160 + $offt;
   44     my $res = send_udp_request($usock, $req, "get foo\r\n");
   45     ok($res, "got result");
   46     is(keys %$res, 1, "one key (one packet)");
   47     ok($res->{0}, "only got seq number 0");
   48     is(substr($res->{0}, 8), "VALUE foo 0 6\r\nfooval\r\nEND\r\n");
   49     is(hexify(substr($res->{0}, 0, 2)), hexify(pack("n", $req)), "udp request number in response ($req) is correct");
   50 }
   51 
   52 my $bvalue;
   53 my $bsize = 20000;
   54 {
   55     my @chars = ("C".."Z");
   56     for (1 .. $bsize) {
   57         $bvalue .= $chars[rand @chars];
   58     }
   59 }
   60 
   61 # set and test a multi-packet value
   62 {
   63     print $sock "set bigvalue 0 0 $bsize\r\n$bvalue\r\n";
   64     is(scalar <$sock>, "STORED\r\n", "stored bigvalue");
   65     mem_get_is($sock, "bigvalue", $bvalue);
   66 
   67     my $res = send_udp_request($usock, 53, "get bigvalue\r\n");
   68     ok($res, "got result");
   69     my $resp = construct_udp_message($res);
   70     is($resp, "VALUE bigvalue 0 $bsize\r\n$bvalue\r\nEND\r\n");
   71 }
   72 
   73 # op tests
   74 for my $prot (::IS_ASCII,::IS_BINARY) {
   75     udp_set_test($prot,45,"aval$prot","1",0,0);
   76     udp_set_test($prot,45,"bval$prot","abcd" x 1024,0,0);
   77     udp_get_test($prot,45,"aval$prot","1",::ENTRY_EXISTS);
   78     udp_get_test($prot,45,"404$prot","1",::ENTRY_MISSING);
   79     udp_incr_decr_test($prot,45,"aval$prot","1","incr",1);
   80     udp_incr_decr_test($prot,45,"aval$prot","1","decr",2);
   81     udp_delete_test($prot,45,"aval$prot");
   82 }
   83 
   84 sub udp_set_test {
   85     my ($protocol, $req_id, $key, $value, $flags, $exp) = @_;
   86     my $req = "";
   87     my $val_len = length($value);
   88 
   89     if ($protocol == ::IS_ASCII) {
   90         $req = "set $key $flags $exp $val_len\r\n$value\r\n";
   91     } elsif ($protocol == ::IS_BINARY) {
   92         my $key_len = length($key);
   93         my $extra = pack "NN",$flags,$exp;
   94         my $extra_len = length($extra);
   95         my $total_len = $val_len + $extra_len + $key_len;
   96         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_SET, $key_len, $extra_len, 0, 0, $total_len, 0, 0, 0);
   97         $req .=  $extra . $key . $value;
   98     }
   99 
  100     my $datagrams = send_udp_request($usock, $req_id, $req);
  101     my $resp = construct_udp_message($datagrams);
  102 
  103     if ($protocol == ::IS_ASCII) {
  104         is($resp,"STORED\r\n","Store key $key using ASCII protocol");
  105     } elsif ($protocol == ::IS_BINARY) {
  106         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
  107             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
  108         is($resp_status,"0","Store key $key using binary protocol");
  109     }
  110 }
  111 
  112 sub udp_get_test {
  113     my ($protocol, $req_id, $key, $value, $exists) = @_;
  114     my $key_len = length($key);
  115     my $value_len = length($value);
  116     my $req = "";
  117 
  118     if ($protocol == ::IS_ASCII) {
  119         $req = "get $key\r\n";
  120     } elsif ($protocol == ::IS_BINARY) {
  121         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_GET, $key_len, 0, 0, 0, $key_len, 0, 0, 0);
  122         $req .= $key;
  123     }
  124 
  125     my $datagrams = send_udp_request($usock, $req_id, $req);
  126     my $resp = construct_udp_message($datagrams);
  127 
  128     if ($protocol == ::IS_ASCII) {
  129         if ($exists == ::ENTRY_EXISTS) {
  130             is($resp,"VALUE $key 0 $value_len\r\n$value\r\nEND\r\n","Retrieve entry with key $key using ASCII protocol");
  131         } else {
  132             is($resp,"END\r\n","Retrieve non existing entry with key $key using ASCII protocol");
  133         }
  134     } elsif ($protocol == ::IS_BINARY) {
  135         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
  136             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
  137         if ($exists == ::ENTRY_EXISTS) {
  138             is($resp_status,"0","Retrieve entry with key $key using binary protocol");
  139             is(substr($resp,::MIN_RECV_BYTES + $resp_extra_len + $resp_key_len, $value_len),$value,"Value for key $key retrieved with binary protocol matches");
  140         } else {
  141             is($resp_status,"1","Retrieve non existing entry with key $key using binary protocol");
  142         }
  143     }
  144 }
  145 
  146 sub udp_delete_test {
  147     my ($protocol, $req_id, $key) = @_;
  148     my $req = "";
  149     my $key_len = length($key);
  150 
  151     if ($protocol == ::IS_ASCII) {
  152         $req = "delete $key\r\n";
  153     } elsif ($protocol == ::IS_BINARY) {
  154         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_DELETE, $key_len, 0, 0, 0, $key_len, 0, 0, 0);
  155         $req .= $key;
  156     }
  157 
  158     my $datagrams = send_udp_request($usock, $req_id, $req);
  159     my $resp = construct_udp_message($datagrams);
  160 
  161     if ($protocol == ::IS_ASCII) {
  162         is($resp,"DELETED\r\n","Delete key $key using ASCII protocol");
  163     } elsif ($protocol == ::IS_BINARY) {
  164         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
  165             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
  166         is($resp_status,"0","Delete key $key using binary protocol");
  167     }
  168 }
  169 
  170 sub udp_incr_decr_test {
  171     my ($protocol, $req_id, $key, $val, $optype, $init_val) = @_;
  172     my $req = "";
  173     my $key_len = length($key);
  174     my $expected_value = 0;
  175     my $acmd = "incr";
  176     my $bcmd = ::CMD_INCR;
  177     if ($optype eq "incr") {
  178         $expected_value = $init_val + $val;
  179     } else {
  180         $acmd = "decr";
  181         $bcmd = ::CMD_DECR;
  182         $expected_value = $init_val - $val;
  183     }
  184 
  185     if ($protocol == ::IS_ASCII) {
  186         $req = "$acmd $key $val\r\n";
  187     } elsif ($protocol == ::IS_BINARY) {
  188         my $extra = pack(::INCRDECR_PKT_FMT, ($val / 2 ** 32),($val % 2 ** 32), 0, 0, 0);
  189         my $extra_len = length($extra);
  190         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, $bcmd, $key_len, $extra_len, 0, 0, $key_len + $extra_len, 0, 0, 0);
  191         $req .= $extra . $key;
  192     }
  193 
  194     my $datagrams = send_udp_request($usock, $req_id, $req);
  195     my $resp = construct_udp_message($datagrams);
  196 
  197     if ($protocol == ::IS_ASCII) {
  198         is($resp,"$expected_value\r\n","perform $acmd math operation on key $key with ASCII protocol");
  199     } elsif ($protocol == ::IS_BINARY) {
  200         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
  201             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
  202         is($resp_status,"0","perform $acmd math operation on key $key with binary protocol");
  203         my ($resp_hi,$resp_lo) = unpack("NN",substr($resp,::MIN_RECV_BYTES + $resp_extra_len + $resp_key_len,
  204                                                     $resp_total_len - $resp_extra_len - $resp_key_len));
  205         is(($resp_hi * 2 ** 32) + $resp_lo,$expected_value,"validate result of binary protocol math operation $acmd . Expected value $expected_value")
  206     }
  207 }
  208 
  209 sub construct_udp_message {
  210     my $datagrams = shift;
  211     my $num_datagram = keys (%$datagrams);
  212     my $msg = "";
  213     my $cur_dg ="";
  214     my $cur_udp_header ="";
  215     for (my $cur_dg_index = 0; $cur_dg_index < $num_datagram; $cur_dg_index++) {
  216         $cur_dg = $datagrams->{$cur_dg_index};
  217         isnt($cur_dg,"","missing datagram for segment $cur_dg_index");
  218         $cur_udp_header=substr($cur_dg, 0, 8);
  219         $msg .= substr($cur_dg,8);
  220     }
  221     return $msg;
  222 }
  223 
  224 sub hexify {
  225     my $val = shift;
  226     $val =~ s/(.)/sprintf("%02x", ord($1))/egs;
  227     return $val;
  228 }
  229 
  230 # returns undef on select timeout, or hashref of "seqnum" -> payload (including headers)
  231 # verifies that resp_id is equal to id sent in request
  232 # ensures consistency in num packets that make up response
  233 sub send_udp_request {
  234     my ($sock, $reqid, $req) = @_;
  235 
  236     my $pkt = pack("nnnn", $reqid, 0, 1, 0);  # request id (opaque), seq num, #packets, reserved (must be 0)
  237     $pkt .= $req;
  238     my $fail = sub {
  239         my $msg = shift;
  240         warn "  FAILING send_udp because: $msg\n";
  241         return undef;
  242     };
  243     return $fail->("send") unless send($sock, $pkt, 0);
  244 
  245     my $ret = {};
  246 
  247     my $got = 0;   # packets got
  248     my $numpkts = undef;
  249 
  250     while (!defined($numpkts) || $got < $numpkts) {
  251         my $rin = '';
  252         vec($rin, fileno($sock), 1) = 1;
  253         my $rout;
  254         return $fail->("timeout after $got packets") unless
  255             select($rout = $rin, undef, undef, 1.5);
  256 
  257         my $res;
  258         my $sender = $sock->recv($res, 1500, 0);
  259         my ($resid, $seq, $this_numpkts, $resv) = unpack("nnnn", substr($res, 0, 8));
  260         die "Response ID of $resid doesn't match request if of $reqid" unless $resid == $reqid;
  261         die "Reserved area not zero" unless $resv == 0;
  262         die "num packets changed midstream!" if defined $numpkts && $this_numpkts != $numpkts;
  263         $numpkts = $this_numpkts;
  264         $ret->{$seq} = $res;
  265         $got++;
  266     }
  267     return $ret;
  268 }
  269 
  270 
  271 __END__
  272     $sender = recv($usock, $ans, 1050, 0);
  273 
  274 __END__
  275     $usock->send
  276 
  277 
  278     ($hispaddr = recv(SOCKET, $rtime, 4, 0))        || die "recv: $!";
  279 ($port, $hisiaddr) = sockaddr_in($hispaddr);
  280 $host = gethostbyaddr($hisiaddr, AF_INET);
  281 $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;