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