git.m6w6.name Git - awesomized/libmemcached/blob - memcached/t/udp.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use Test::More tests => 48;
   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();
  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 # op tests
  53 for my $prot (::IS_ASCII,::IS_BINARY) {
  54     udp_set_test($prot,45,"aval$prot","1",0,0);
  55     udp_set_test($prot,45,"bval$prot","abcd" x 1024,0,0);
  56     udp_get_test($prot,45,"aval$prot","1",::ENTRY_EXISTS);
  57     udp_get_test($prot,45,"404$prot","1",::ENTRY_MISSING);
  58     udp_incr_decr_test($prot,45,"aval$prot","1","incr",1);
  59     udp_incr_decr_test($prot,45,"aval$prot","1","decr",2);
  60     udp_delete_test($prot,45,"aval$prot");
  61 }
  62
  63 sub udp_set_test {
  64     my ($protocol, $req_id, $key, $value, $flags, $exp) = @_;
  65     my $req = "";
  66     my $val_len = length($value);
  67
  68     if ($protocol == ::IS_ASCII) {
  69         $req = "set $key $flags $exp $val_len\r\n$value\r\n";
  70     } elsif ($protocol == ::IS_BINARY) {
  71         my $key_len = length($key);
  72         my $extra = pack "NN",$flags,$exp;
  73         my $extra_len = length($extra);
  74         my $total_len = $val_len + $extra_len + $key_len;
  75         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_SET, $key_len, $extra_len, 0, 0, $total_len, 0, 0, 0);
  76         $req .=  $extra . $key . $value;
  77     }
  78
  79     my $datagrams = send_udp_request($usock, $req_id, $req);
  80     my $resp = construct_udp_message($datagrams);
  81
  82     if ($protocol == ::IS_ASCII) {
  83         is($resp,"STORED\r\n","Store key $key using ASCII protocol");
  84     } elsif ($protocol == ::IS_BINARY) {
  85         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
  86             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
  87         is($resp_status,"0","Store key $key using binary protocol");
  88     }
  89 }
  90
  91 sub udp_get_test {
  92     my ($protocol, $req_id, $key, $value, $exists) = @_;
  93     my $key_len = length($key);
  94     my $value_len = length($value);
  95     my $req = "";
  96
  97     if ($protocol == ::IS_ASCII) {
  98         $req = "get $key\r\n";
  99     } elsif ($protocol == ::IS_BINARY) {
 100         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_GET, $key_len, 0, 0, 0, $key_len, 0, 0, 0);
 101         $req .= $key;
 102     }
 103
 104     my $datagrams = send_udp_request($usock, $req_id, $req);
 105     my $resp = construct_udp_message($datagrams);
 106
 107     if ($protocol == ::IS_ASCII) {
 108         if ($exists == ::ENTRY_EXISTS) {
 109             is($resp,"VALUE $key 0 $value_len\r\n$value\r\nEND\r\n","Retrieve entry with key $key using ASCII protocol");
 110         } else {
 111             is($resp,"END\r\n","Retrieve non existing entry with key $key using ASCII protocol");
 112         }
 113     } elsif ($protocol == ::IS_BINARY) {
 114         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
 115             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
 116         if ($exists == ::ENTRY_EXISTS) {
 117             is($resp_status,"0","Retrieve entry with key $key using binary protocol");
 118             is(substr($resp,::MIN_RECV_BYTES + $resp_extra_len + $resp_key_len, $value_len),$value,"Value for key $key retrieved with binary protocol matches");
 119         } else {
 120             is($resp_status,"1","Retrieve non existing entry with key $key using binary protocol");
 121         }
 122     }
 123 }
 124
 125 sub udp_delete_test {
 126     my ($protocol, $req_id, $key) = @_;
 127     my $req = "";
 128     my $key_len = length($key);
 129
 130     if ($protocol == ::IS_ASCII) {
 131         $req = "delete $key\r\n";
 132     } elsif ($protocol == ::IS_BINARY) {
 133         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, ::CMD_DELETE, $key_len, 0, 0, 0, $key_len, 0, 0, 0);
 134         $req .= $key;
 135     }
 136
 137     my $datagrams = send_udp_request($usock, $req_id, $req);
 138     my $resp = construct_udp_message($datagrams);
 139
 140     if ($protocol == ::IS_ASCII) {
 141         is($resp,"DELETED\r\n","Delete key $key using ASCII protocol");
 142     } elsif ($protocol == ::IS_BINARY) {
 143         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
 144             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
 145         is($resp_status,"0","Delete key $key using binary protocol");
 146     }
 147 }
 148
 149 sub udp_incr_decr_test {
 150     my ($protocol, $req_id, $key, $val, $optype, $init_val) = @_;
 151     my $req = "";
 152     my $key_len = length($key);
 153     my $expected_value = 0;
 154     my $acmd = "incr";
 155     my $bcmd = ::CMD_INCR;
 156     if ($optype eq "incr") {
 157         $expected_value = $init_val + $val;
 158     } else {
 159         $acmd = "decr";
 160         $bcmd = ::CMD_DECR;
 161         $expected_value = $init_val - $val;
 162     }
 163
 164     if ($protocol == ::IS_ASCII) {
 165         $req = "$acmd $key $val\r\n";
 166     } elsif ($protocol == ::IS_BINARY) {
 167         my $extra = pack(::INCRDECR_PKT_FMT, ($val / 2 ** 32),($val % 2 ** 32), 0, 0, 0);
 168         my $extra_len = length($extra);
 169         $req = pack(::REQ_PKT_FMT, ::BIN_REQ_MAGIC, $bcmd, $key_len, $extra_len, 0, 0, $key_len + $extra_len, 0, 0, 0);
 170         $req .= $extra . $key;
 171     }
 172
 173     my $datagrams = send_udp_request($usock, $req_id, $req);
 174     my $resp = construct_udp_message($datagrams);
 175
 176     if ($protocol == ::IS_ASCII) {
 177         is($resp,"$expected_value\r\n","perform $acmd math operation on key $key with ASCII protocol");
 178     } elsif ($protocol == ::IS_BINARY) {
 179         my ($resp_magic, $resp_op_code, $resp_key_len, $resp_extra_len, $resp_data_type, $resp_status, $resp_total_len,
 180             $resp_opaque, $resp_ident_hi, $resp_ident_lo) = unpack(::RES_PKT_FMT, $resp);
 181         is($resp_status,"0","perform $acmd math operation on key $key with binary protocol");
 182         my ($resp_hi,$resp_lo) = unpack("NN",substr($resp,::MIN_RECV_BYTES + $resp_extra_len + $resp_key_len,
 183                                                     $resp_total_len - $resp_extra_len - $resp_key_len));
 184         is(($resp_hi * 2 ** 32) + $resp_lo,$expected_value,"validate result of binary protocol math operation $acmd . Expected value $expected_value")
 185     }
 186 }
 187
 188 sub construct_udp_message {
 189     my $datagrams = shift;
 190     my $num_datagram = keys (%$datagrams);
 191     my $msg = "";
 192     my $cur_dg ="";
 193     my $cur_udp_header ="";
 194     for (my $cur_dg_index = 0; $cur_dg_index < $num_datagram; $cur_dg_index++) {
 195         $cur_dg = $datagrams->{$cur_dg_index};
 196         isnt($cur_dg,"","missing datagram for segment $cur_dg_index");
 197         $cur_udp_header=substr($cur_dg, 0, 8);
 198         $msg .= substr($cur_dg,8);
 199     }
 200     return $msg;
 201 }
 202
 203 sub hexify {
 204     my $val = shift;
 205     $val =~ s/(.)/sprintf("%02x", ord($1))/egs;
 206     return $val;
 207 }
 208
 209 # returns undef on select timeout, or hashref of "seqnum" -> payload (including headers)
 210 # verifies that resp_id is equal to id sent in request
 211 # ensures consistency in num packets that make up response
 212 sub send_udp_request {
 213     my ($sock, $reqid, $req) = @_;
 214
 215     my $pkt = pack("nnnn", $reqid, 0, 1, 0);  # request id (opaque), seq num, #packets, reserved (must be 0)
 216     $pkt .= $req;
 217     my $fail = sub {
 218         my $msg = shift;
 219         warn "  FAILING send_udp because: $msg\n";
 220         return undef;
 221     };
 222     return $fail->("send") unless send($sock, $pkt, 0);
 223
 224     my $ret = {};
 225
 226     my $got = 0;   # packets got
 227     my $numpkts = undef;
 228
 229     while (!defined($numpkts) || $got < $numpkts) {
 230         my $rin = '';
 231         vec($rin, fileno($sock), 1) = 1;
 232         my $rout;
 233         return $fail->("timeout after $got packets") unless
 234             select($rout = $rin, undef, undef, 1.5);
 235
 236         my $res;
 237         my $sender = $sock->recv($res, 1500, 0);
 238         my ($resid, $seq, $this_numpkts, $resv) = unpack("nnnn", substr($res, 0, 8));
 239         die "Response ID of $resid doesn't match request if of $reqid" unless $resid == $reqid;
 240         die "Reserved area not zero" unless $resv == 0;
 241         die "num packets changed midstream!" if defined $numpkts && $this_numpkts != $numpkts;
 242         $numpkts = $this_numpkts;
 243         $ret->{$seq} = $res;
 244         $got++;
 245     }
 246     return $ret;
 247 }
 248
 249
 250 __END__
 251     $sender = recv($usock, $ans, 1050, 0);
 252
 253 __END__
 254     $usock->send
 255
 256
 257     ($hispaddr = recv(SOCKET, $rtime, 4, 0))        || die "recv: $!";
 258 ($port, $hisiaddr) = sockaddr_in($hispaddr);
 259 $host = gethostbyaddr($hisiaddr, AF_INET);
 260 $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;