|
0
|
1 #!/usr/bin/perl
|
|
|
2
|
|
|
3 use strict;
|
|
|
4 use Test::More tests => 33;
|
|
|
5 use FindBin qw($Bin);
|
|
|
6 use lib "$Bin/lib";
|
|
|
7 use MemcachedTest;
|
|
|
8
|
|
|
9 my $server = new_memcached();
|
|
|
10 my $sock = $server->sock;
|
|
|
11
|
|
|
12 # set foo (and should get it)
|
|
|
13 print $sock "set foo 0 0 6\r\nfooval\r\n";
|
|
|
14 is(scalar <$sock>, "STORED\r\n", "stored foo");
|
|
|
15 mem_get_is($sock, "foo", "fooval");
|
|
|
16
|
|
|
17 my $usock = $server->new_udp_sock
|
|
|
18 or die "Can't bind : $@\n";
|
|
|
19
|
|
|
20 # test all the steps, one by one:
|
|
|
21 test_single($usock);
|
|
|
22
|
|
|
23 # testing sequence numbers
|
|
|
24 for my $offt (1, 1, 2) {
|
|
|
25 my $seq = 160 + $offt;
|
|
|
26 my $res = send_udp_request($usock, $seq, "get foo\r\n");
|
|
|
27 ok($res, "got result");
|
|
|
28 is(keys %$res, 1, "one key (one packet)");
|
|
|
29 ok($res->{0}, "only got seq number 0");
|
|
|
30 is(substr($res->{0}, 8), "VALUE foo 0 6\r\nfooval\r\nEND\r\n");
|
|
|
31 is(hexify(substr($res->{0}, 0, 2)), hexify(pack("n", $seq)), "sequence number in response ($seq) is correct");
|
|
|
32 }
|
|
|
33
|
|
|
34 # testing non-existent stuff
|
|
|
35 my $res = send_udp_request($usock, 404, "get notexist\r\n");
|
|
|
36 ok($res, "got result");
|
|
|
37 is(keys %$res, 1, "one key (one packet)");
|
|
|
38 ok($res->{0}, "only got seq number 0");
|
|
|
39 is(hexify(substr($res->{0}, 0, 2)), hexify(pack("n", 404)), "sequence number 404 correct");
|
|
|
40 is(substr($res->{0}, 8), "END\r\n");
|
|
|
41
|
|
|
42 # test multi-packet response
|
|
|
43 {
|
|
|
44 my $big = "abcd" x 1024;
|
|
|
45 my $len = length $big;
|
|
|
46 print $sock "set big 0 0 $len\r\n$big\r\n";
|
|
|
47 is(scalar <$sock>, "STORED\r\n", "stored big");
|
|
|
48 mem_get_is($sock, "big", $big, "big value matches");
|
|
|
49 my $res = send_udp_request($usock, 999, "get big\r\n");
|
|
|
50 is(scalar keys %$res, 3, "three packet response");
|
|
|
51 like($res->{0}, qr/VALUE big 0 4096/, "first packet has value line");
|
|
|
52 like($res->{2}, qr/\r\nEND\r\n/, "last packet has end");
|
|
|
53 is(hexify(substr($res->{1}, 0, 2)), hexify(pack("n", 999)), "sequence number of middle packet is correct");
|
|
|
54 }
|
|
|
55
|
|
|
56 sub test_single {
|
|
|
57 my $usock = shift;
|
|
|
58 my $req = pack("nnnn", 45, 0, 1, 0); # request id (opaque), seq num, #packets, reserved (must be 0)
|
|
|
59 $req .= "get foo\r\n";
|
|
|
60 ok(defined send($usock, $req, 0), "sent request");
|
|
|
61
|
|
|
62 my $rin = '';
|
|
|
63 vec($rin, fileno($usock), 1) = 1;
|
|
|
64 my $rout;
|
|
|
65 ok(select($rout = $rin, undef, undef, 2.0), "got readability");
|
|
|
66
|
|
|
67 my $sender;
|
|
|
68 my $res;
|
|
|
69 $sender = $usock->recv($res, 1500, 0);
|
|
|
70
|
|
|
71 my $id = pack("n", 45);
|
|
|
72 is(hexify(substr($res, 0, 8)), hexify($id) . '0000' . '0001' . '0000', "header is correct");
|
|
|
73 is(length $res, 36, '');
|
|
|
74 is(substr($res, 8), "VALUE foo 0 6\r\nfooval\r\nEND\r\n", "payload is as expected");
|
|
|
75 }
|
|
|
76
|
|
|
77 sub hexify {
|
|
|
78 my $val = shift;
|
|
|
79 $val =~ s/(.)/sprintf("%02x", ord($1))/egs;
|
|
|
80 return $val;
|
|
|
81 }
|
|
|
82
|
|
|
83 # returns undef on select timeout, or hashref of "seqnum" -> payload (including headers)
|
|
|
84 sub send_udp_request {
|
|
|
85 my ($sock, $reqid, $req) = @_;
|
|
|
86
|
|
|
87 my $pkt = pack("nnnn", $reqid, 0, 1, 0); # request id (opaque), seq num, #packets, reserved (must be 0)
|
|
|
88 $pkt .= $req;
|
|
|
89 my $fail = sub {
|
|
|
90 my $msg = shift;
|
|
|
91 warn " FAILING send_udp because: $msg\n";
|
|
|
92 return undef;
|
|
|
93 };
|
|
|
94 return $fail->("send") unless send($sock, $pkt, 0);
|
|
|
95
|
|
|
96 my $ret = {};
|
|
|
97
|
|
|
98 my $got = 0; # packets got
|
|
|
99 my $numpkts = undef;
|
|
|
100
|
|
|
101 while (!defined($numpkts) || $got < $numpkts) {
|
|
|
102 my $rin = '';
|
|
|
103 vec($rin, fileno($sock), 1) = 1;
|
|
|
104 my $rout;
|
|
|
105 return $fail->("timeout after $got packets") unless
|
|
|
106 select($rout = $rin, undef, undef, 1.5);
|
|
|
107
|
|
|
108 my $res;
|
|
|
109 my $sender = $sock->recv($res, 1500, 0);
|
|
|
110 my ($resid, $seq, $this_numpkts, $resv) = unpack("nnnn", substr($res, 0, 8));
|
|
|
111 die "Response ID of $resid doesn't match request if of $reqid" unless $resid == $reqid;
|
|
|
112 die "Reserved area not zero" unless $resv == 0;
|
|
|
113 die "num packets changed midstream!" if defined $numpkts && $this_numpkts != $numpkts;
|
|
|
114 $numpkts = $this_numpkts;
|
|
|
115 $ret->{$seq} = $res;
|
|
|
116 $got++;
|
|
|
117 }
|
|
|
118 return $ret;
|
|
|
119 }
|
|
|
120
|
|
|
121 __END__
|
|
|
122 $sender = recv($usock, $ans, 1050, 0);
|
|
|
123
|
|
|
124 __END__
|
|
|
125 $usock->send
|
|
|
126
|
|
|
127
|
|
|
128 ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!";
|
|
|
129 ($port, $hisiaddr) = sockaddr_in($hispaddr);
|
|
|
130 $host = gethostbyaddr($hisiaddr, AF_INET);
|
|
|
131 $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;
|
