1#!/usr/bin/perl 2 3use strict; 4use Test::More tests => 48; 5use FindBin qw($Bin); 6use lib "$Bin/lib"; 7use MemcachedTest; 8 9use constant IS_ASCII => 0; 10use constant IS_BINARY => 1; 11use constant ENTRY_EXISTS => 0; 12use constant ENTRY_MISSING => 1; 13use constant BIN_REQ_MAGIC => 0x80; 14use constant BIN_RES_MAGIC => 0x81; 15use constant CMD_GET => 0x00; 16use constant CMD_SET => 0x01; 17use constant CMD_ADD => 0x02; 18use constant CMD_REPLACE => 0x03; 19use constant CMD_DELETE => 0x04; 20use constant CMD_INCR => 0x05; 21use constant CMD_DECR => 0x06; 22use constant CMD_APPEND => 0x0E; 23use constant CMD_PREPEND => 0x0F; 24use constant REQ_PKT_FMT => "CCnCCnNNNN"; 25use constant RES_PKT_FMT => "CCnCCnNNNN"; 26use constant INCRDECR_PKT_FMT => "NNNNN"; 27use constant MIN_RECV_BYTES => length(pack(RES_PKT_FMT)); 28 29 30my $server = new_memcached(); 31my $sock = $server->sock; 32 33# set foo (and should get it) 34print $sock "set foo 0 0 6\r\nfooval\r\n"; 35is(scalar <$sock>, "STORED\r\n", "stored foo"); 36mem_get_is($sock, "foo", "fooval"); 37 38my $usock = $server->new_udp_sock 39 or die "Can't bind : $@\n"; 40 41# testing sequence of request ids 42for 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 53for 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 63sub 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 91sub 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 125sub 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 149sub 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 188sub 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 203sub 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 212sub 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 ; 261