Mercurial > hg > memcached
comparison t/udp.t @ 0:30782bb1fc04 MEMCACHED_1_2_3
memcached-1.2.3
author | Maxim Dounin <mdounin@mdounin.ru> |
---|---|
date | Sun, 23 Sep 2007 03:58:34 +0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:30782bb1fc04 |
---|---|
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 ; |