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