« back to all changes in this revision
Viewing changes to t/binary.t
- browse files at revision 8
- compare with another revision
- download diff
- download tarball
- view history from revision 8
- Committer: Bazaar Package Importer
- Author(s): David Martínez Moreno
- Date: 2009-10-16 15:09:43 UTC
- mfrom: (1.1.6 upstream) (3.1.7 sid)
- Revision ID: james.westby@ubuntu.com-20091016150943-0rhh8x206ebgwzeu
Tags: 1.4.2-1
* New upstream release, primarily bugfixes, some of them critical, hence
the urgency:
- Reject keys larger than 250 bytes in the binary protocol.
- Bounds checking on stats cachedump.
- Binary protocol set+cas wasn't returning a new cas ID.
- Binary quitq didn't actually close the connection
- Slab boundary checking cleanup (bad logic in unreachable code)
- Get hit memory optimizations
- Disallow -t options that cause the server to not work
- Killed off incomplete slab rebalance feature.
* debian/patches:
- 01_init_script_compliant_with_LSB.patch: Remade as upstream applied a
whitespace cleanup script that broke the patch.
- 02_manpage_additions.patch: Added missing parameters to the memcached
manpage.
* Removed TODO from debian/docs.
the urgency:
- Reject keys larger than 250 bytes in the binary protocol.
- Bounds checking on stats cachedump.
- Binary protocol set+cas wasn't returning a new cas ID.
- Binary quitq didn't actually close the connection
- Slab boundary checking cleanup (bad logic in unreachable code)
- Get hit memory optimizations
- Disallow -t options that cause the server to not work
- Killed off incomplete slab rebalance feature.
* debian/patches:
- 01_init_script_compliant_with_LSB.patch: Remade as upstream applied a
whitespace cleanup script that broke the patch.
- 02_manpage_additions.patch: Added missing parameters to the memcached
manpage.
* Removed TODO from debian/docs.
added
removed
t/binary.t
1
#!/usr/bin/perl
2
3
use strict;
4
use warnings;
5
use Test::More tests => 3322;
6
use FindBin qw($Bin);
7
use lib "$Bin/lib";
8
use MemcachedTest;
9
10
my $server = new_memcached();
11
ok($server, "started the server");
12
13
# Based almost 100% off testClient.py which is:
14
# Copyright (c) 2007 Dustin Sallings <dustin@spy.net>
15
16
# Command constants
17
use constant CMD_GET => 0x00;
18
use constant CMD_SET => 0x01;
19
use constant CMD_ADD => 0x02;
20
use constant CMD_REPLACE => 0x03;
21
use constant CMD_DELETE => 0x04;
22
use constant CMD_INCR => 0x05;
23
use constant CMD_DECR => 0x06;
24
use constant CMD_QUIT => 0x07;
25
use constant CMD_FLUSH => 0x08;
26
use constant CMD_GETQ => 0x09;
27
use constant CMD_NOOP => 0x0A;
28
use constant CMD_VERSION => 0x0B;
29
use constant CMD_GETK => 0x0C;
30
use constant CMD_GETKQ => 0x0D;
31
use constant CMD_APPEND => 0x0E;
32
use constant CMD_PREPEND => 0x0F;
33
use constant CMD_STAT => 0x10;
34
use constant CMD_SETQ => 0x11;
35
use constant CMD_ADDQ => 0x12;
36
use constant CMD_REPLACEQ => 0x13;
37
use constant CMD_DELETEQ => 0x14;
38
use constant CMD_INCREMENTQ => 0x15;
39
use constant CMD_DECREMENTQ => 0x16;
40
use constant CMD_QUITQ => 0x17;
41
use constant CMD_FLUSHQ => 0x18;
42
use constant CMD_APPENDQ => 0x19;
43
use constant CMD_PREPENDQ => 0x1A;
44
45
# REQ and RES formats are divided even though they currently share
46
# the same format, since they _could_ differ in the future.
47
use constant REQ_PKT_FMT => "CCnCCnNNNN";
48
use constant RES_PKT_FMT => "CCnCCnNNNN";
49
use constant INCRDECR_PKT_FMT => "NNNNN";
50
use constant MIN_RECV_BYTES => length(pack(RES_PKT_FMT));
51
use constant REQ_MAGIC => 0x80;
52
use constant RES_MAGIC => 0x81;
53
54
my $mc = MC::Client->new;
55
56
# Let's turn on detail stats for all this stuff
57
58
$mc->stats('detail on');
59
60
my $check = sub {
61
my ($key, $orig_flags, $orig_val) = @_;
62
my ($flags, $val, $cas) = $mc->get($key);
63
is($flags, $orig_flags, "Flags is set properly");
64
ok($val eq $orig_val || $val == $orig_val, $val . " = " . $orig_val);
65
};
66
67
my $set = sub {
68
my ($key, $exp, $orig_flags, $orig_value) = @_;
69
$mc->set($key, $orig_value, $orig_flags, $exp);
70
$check->($key, $orig_flags, $orig_value);
71
};
72
73
my $empty = sub {
74
my $key = shift;
75
my $rv =()= eval { $mc->get($key) };
76
is($rv, 0, "Didn't get a result from get");
77
ok($@->not_found, "We got a not found error when we expected one");
78
};
79
80
my $delete = sub {
81
my ($key, $when) = @_;
82
$mc->delete($key, $when);
83
$empty->($key);
84
};
85
86
# diag "Test Version";
87
my $v = $mc->version;
88
ok(defined $v && length($v), "Proper version: $v");
89
90
# Bug 71
91
{
92
my %stats1 = $mc->stats('');
93
$mc->flush;
94
my %stats2 = $mc->stats('');
95
96
is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
97
"Stats not updated on a binary flush");
98
}
99
100
# diag "Flushing...";
101
$mc->flush;
102
103
# diag "Noop";
104
$mc->noop;
105
106
# diag "Simple set/get";
107
$set->('x', 5, 19, "somevalue");
108
109
# diag "Delete";
110
$delete->('x');
111
112
# diag "Flush";
113
$set->('x', 5, 19, "somevaluex");
114
$set->('y', 5, 17, "somevaluey");
115
$mc->flush;
116
$empty->('x');
117
$empty->('y');
118
119
{
120
# diag "Add";
121
$empty->('i');
122
$mc->add('i', 'ex', 5, 10);
123
$check->('i', 5, "ex");
124
125
my $rv =()= eval { $mc->add('i', "ex2", 10, 5) };
126
is($rv, 0, "Add didn't return anything");
127
ok($@->exists, "Expected exists error received");
128
$check->('i', 5, "ex");
129
}
130
131
{
132
# diag "Too big.";
133
$empty->('toobig');
134
$mc->set('toobig', 'not too big', 10, 10);
135
eval {
136
my $bigval = ("x" x (1024*1024)) . "x";
137
$mc->set('toobig', $bigval, 10, 10);
138
};
139
ok($@->too_big, "Was too big");
140
$empty->('toobig');
141
}
142
143
{
144
# diag "Replace";
145
$empty->('j');
146
147
my $rv =()= eval { $mc->replace('j', "ex", 19, 5) };
148
is($rv, 0, "Replace didn't return anything");
149
ok($@->not_found, "Expected not_found error received");
150
$empty->('j');
151
$mc->add('j', "ex2", 14, 5);
152
$check->('j', 14, "ex2");
153
$mc->replace('j', "ex3", 24, 5);
154
$check->('j', 24, "ex3");
155
}
156
157
{
158
# diag "MultiGet";
159
$mc->add('xx', "ex", 1, 5);
160
$mc->add('wye', "why", 2, 5);
161
my $rv = $mc->get_multi(qw(xx wye zed));
162
163
# CAS is returned with all gets.
164
$rv->{xx}->[2] = 0;
165
$rv->{wye}->[2] = 0;
166
is_deeply($rv->{xx}, [1, 'ex', 0], "X is correct");
167
is_deeply($rv->{wye}, [2, 'why', 0], "Y is correct");
168
is(keys(%$rv), 2, "Got only two answers like we expect");
169
}
170
171
# diag "Test increment";
172
$mc->flush;
173
is($mc->incr("x"), 0, "First incr call is zero");
174
is($mc->incr("x"), 1, "Second incr call is one");
175
is($mc->incr("x", 211), 212, "Adding 211 gives you 212");
176
is($mc->incr("x", 2**33), 8589934804, "Blast the 32bit border");
177
178
# diag "Issue 48 - incrementing plain text.";
179
{
180
$mc->set("issue48", "text", 0, 0);
181
my $rv =()= eval { $mc->incr('issue48'); };
182
ok($@ && $@->delta_badval, "Expected invalid value when incrementing text.");
183
$check->('issue48', 0, "text");
184
185
$rv =()= eval { $mc->decr('issue48'); };
186
ok($@ && $@->delta_badval, "Expected invalid value when decrementing text.");
187
$check->('issue48', 0, "text");
188
}
189
190
191
# diag "Test decrement";
192
$mc->flush;
193
is($mc->incr("x", undef, 5), 5, "Initial value");
194
is($mc->decr("x"), 4, "Decrease by one");
195
is($mc->decr("x", 211), 0, "Floor is zero");
196
197
{
198
# diag "bug21";
199
$mc->add("bug21", "9223372036854775807", 0, 0);
200
is($mc->incr("bug21"), 9223372036854775808, "First incr for bug21.");
201
is($mc->incr("bug21"), 9223372036854775809, "Second incr for bug21.");
202
is($mc->decr("bug21"), 9223372036854775808, "Decr for bug21.");
203
}
204
205
{
206
# diag "CAS";
207
$mc->flush;
208
209
{
210
my $rv =()= eval { $mc->set("x", "bad value", 19, 5, 0x7FFFFFF) };
211
is($rv, 0, "Empty return on expected failure");
212
ok($@->not_found, "Error was 'not found' as expected");
213
}
214
215
my ($r, $rcas) = $mc->add("x", "original value", 5, 19);
216
217
my ($flags, $val, $i) = $mc->get("x");
218
is($val, "original value", "->gets returned proper value");
219
is($rcas, $i, "Add CAS matched.");
220
221
{
222
my $rv =()= eval { $mc->set("x", "broken value", 19, 5, $i+1) };
223
is($rv, 0, "Empty return on expected failure (1)");
224
ok($@->exists, "Expected error state of 'exists' (1)");
225
}
226
227
($r, $rcas) = $mc->set("x", "new value", 19, 5, $i);
228
229
my ($newflags, $newval, $newi) = $mc->get("x");
230
is($newval, "new value", "CAS properly overwrote value");
231
is($rcas, $newi, "Get CAS matched.");
232
233
{
234
my $rv =()= eval { $mc->set("x", "replay value", 19, 5, $i) };
235
is($rv, 0, "Empty return on expected failure (2)");
236
ok($@->exists, "Expected error state of 'exists' (2)");
237
}
238
}
239
240
# diag "Silent set.";
241
$mc->silent_mutation(::CMD_SETQ, 'silentset', 'silentsetval');
242
243
# diag "Silent add.";
244
$mc->silent_mutation(::CMD_ADDQ, 'silentadd', 'silentaddval');
245
246
# diag "Silent replace.";
247
{
248
my $key = "silentreplace";
249
my $extra = pack "NN", 829, 0;
250
$empty->($key);
251
# $mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
252
# $empty->($key);
253
254
$mc->add($key, "xval", 831, 0);
255
$check->($key, 831, 'xval');
256
257
$mc->send_silent(::CMD_REPLACEQ, $key, 'somevalue', 7278552, $extra, 0);
258
$check->($key, 829, 'somevalue');
259
}
260
261
# diag "Silent delete";
262
{
263
my $key = "silentdelete";
264
$empty->($key);
265
$mc->set($key, "some val", 19, 0);
266
$mc->send_silent(::CMD_DELETEQ, $key, '', 772);
267
$empty->($key);
268
}
269
270
# diag "Silent increment";
271
{
272
my $key = "silentincr";
273
my $opaque = 98428747;
274
$empty->($key);
275
$mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 0, 0, 0);
276
is($mc->incr($key, 0), 0, "First call is 0");
277
278
$mc->silent_incrdecr(::CMD_INCREMENTQ, $key, 8, 0, 0);
279
is($mc->incr($key, 0), 8);
280
}
281
282
# diag "Silent decrement";
283
{
284
my $key = "silentdecr";
285
my $opaque = 98428147;
286
$empty->($key);
287
$mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 0, 185, 0);
288
is($mc->incr($key, 0), 185);
289
290
$mc->silent_incrdecr(::CMD_DECREMENTQ, $key, 8, 0, 0);
291
is($mc->incr($key, 0), 177);
292
}
293
294
# diag "Silent flush";
295
{
296
my %stats1 = $mc->stats('');
297
298
$set->('x', 5, 19, "somevaluex");
299
$set->('y', 5, 17, "somevaluey");
300
$mc->send_silent(::CMD_FLUSHQ, '', '', 2775256);
301
$empty->('x');
302
$empty->('y');
303
304
my %stats2 = $mc->stats('');
305
is($stats2{'cmd_flush'}, $stats1{'cmd_flush'} + 1,
306
"Stats not updated on a binary quiet flush");
307
}
308
309
# diag "Append";
310
{
311
my $key = "appendkey";
312
my $value = "some value";
313
$set->($key, 8, 19, $value);
314
$mc->_append_prepend(::CMD_APPEND, $key, " more");
315
$check->($key, 19, $value . " more");
316
}
317
318
# diag "Prepend";
319
{
320
my $key = "prependkey";
321
my $value = "some value";
322
$set->($key, 8, 19, $value);
323
$mc->_append_prepend(::CMD_PREPEND, $key, "prefixed ");
324
$check->($key, 19, "prefixed " . $value);
325
}
326
327
# diag "Silent append";
328
{
329
my $key = "appendqkey";
330
my $value = "some value";
331
$set->($key, 8, 19, $value);
332
$mc->send_silent(::CMD_APPENDQ, $key, " more", 7284492);
333
$check->($key, 19, $value . " more");
334
}
335
336
# diag "Silent prepend";
337
{
338
my $key = "prependqkey";
339
my $value = "some value";
340
$set->($key, 8, 19, $value);
341
$mc->send_silent(::CMD_PREPENDQ, $key, "prefixed ", 7284492);
342
$check->($key, 19, "prefixed " . $value);
343
}
344
345
# diag "Leaky binary get test.";
346
# # http://code.google.com/p/memcached/issues/detail?id=16
347
{
348
# Get a new socket so we can speak text to it.
349
my $sock = $server->new_sock;
350
my $max = 1024 * 1024;
351
my $big = "a big value that's > .5M and < 1M. ";
352
while (length($big) * 2 < $max) {
353
$big = $big . $big;
354
}
355
my $biglen = length($big);
356
357
for(1..100) {
358
my $key = "some_key_$_";
359
# print STDERR "Key is $key\n";
360
# print $sock "set $key 0 0 $vallen\r\n$value\r\n";
361
print $sock "set $key 0 0 $biglen\r\n$big\r\n";
362
is(scalar <$sock>, "STORED\r\n", "stored big");
363
my ($f, $v, $c) = $mc->get($key);
364
}
365
}
366
367
# diag "Test stats settings."
368
{
369
my %stats = $mc->stats('settings');
370
371
is(1024, $stats{'maxconns'});
372
is('NULL', $stats{'domain_socket'});
373
is('on', $stats{'evictions'});
374
is('yes', $stats{'cas_enabled'});
375
}
376
377
# diag "Test quit commands.";
378
{
379
my $s2 = new_memcached();
380
my $mc2 = MC::Client->new($s2);
381
$mc2->send_command(CMD_QUITQ, '', '', 0, '', 0);
382
383
# Five seconds ought to be enough to get hung up on.
384
my $oldalarmt = alarm(5);
385
386
# Verify we can't read anything.
387
my $bytesread = -1;
388
eval {
389
local $SIG{'ALRM'} = sub { die "timeout" };
390
my $data = "";
391
$bytesread = sysread($mc2->{socket}, $data, 24),
392
};
393
is($bytesread, 0, "Read after quit.");
394
395
# Restore signal stuff.
396
alarm($oldalarmt);
397
}
398
399
# diag "Test protocol boundary overruns";
400
{
401
use List::Util qw[min];
402
# Attempting some protocol overruns by toying around with the edge
403
# of the data buffer at a few different sizes. This assumes the
404
# boundary is at or around 2048 bytes.
405
for (my $i = 1900; $i < 2100; $i++) {
406
my $k = "test_key_$i";
407
my $v = 'x' x $i;
408
# diag "Trying $i $k";
409
my $extra = pack "NN", 82, 0;
410
my $data = $mc->build_command(::CMD_SETQ, $k, $v, 0, $extra, 0);
411
$data .= $mc->build_command(::CMD_SETQ, "alt_$k", "blah", 0, $extra, 0);
412
if (length($data) > 2024) {
413
for (my $j = 2024; $j < min(2096, length($data)); $j++) {
414
$mc->{socket}->send(substr($data, 0, $j));
415
$mc->flush_socket;
416
sleep(0.001);
417
$mc->{socket}->send(substr($data, $j));
418
$mc->flush_socket;
419
}
420
} else {
421
$mc->{socket}->send($data);
422
}
423
$mc->flush_socket;
424
$check->($k, 82, $v);
425
$check->("alt_$k", 82, "blah");
426
}
427
}
428
429
# Along with the assertion added to the code to verify we're staying
430
# within bounds when we do a stats detail dump (detail turned on at
431
# the top).
432
my %stats = $mc->stats('detail dump');
433
434
# This test causes a disconnection.
435
{
436
# diag "Key too large.";
437
my $key = "x" x 365;
438
eval {
439
$mc->get($key, 'should die', 10, 10);
440
};
441
ok($@->einval, "Invalid key length");
442
}
443
444
# ######################################################################
445
# Test ends around here.
446
# ######################################################################
447
448
package MC::Client;
449
450
use strict;
451
use warnings;
452
use fields qw(socket);
453
use IO::Socket::INET;
454
455
sub new {
456
my $self = shift;
457
my ($s) = @_;
458
$s = $server unless defined $s;
459
my $sock = $s->sock;
460
$self = fields::new($self);
461
$self->{socket} = $sock;
462
return $self;
463
}
464
465
sub build_command {
466
my $self = shift;
467
die "Not enough args to send_command" unless @_ >= 4;
468
my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
469
470
$extra_header = '' unless defined $extra_header;
471
my $keylen = length($key);
472
my $vallen = length($val);
473
my $extralen = length($extra_header);
474
my $datatype = 0; # field for future use
475
my $reserved = 0; # field for future use
476
my $totallen = $keylen + $vallen + $extralen;
477
my $ident_hi = 0;
478
my $ident_lo = 0;
479
480
if ($cas) {
481
$ident_hi = int($cas / 2 ** 32);
482
$ident_lo = int($cas % 2 ** 32);
483
}
484
485
my $msg = pack(::REQ_PKT_FMT, ::REQ_MAGIC, $cmd, $keylen, $extralen,
486
$datatype, $reserved, $totallen, $opaque, $ident_hi,
487
$ident_lo);
488
my $full_msg = $msg . $extra_header . $key . $val;
489
return $full_msg;
490
}
491
492
sub send_command {
493
my $self = shift;
494
die "Not enough args to send_command" unless @_ >= 4;
495
my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
496
497
my $full_msg = $self->build_command($cmd, $key, $val, $opaque, $extra_header, $cas);
498
499
my $sent = $self->{socket}->send($full_msg);
500
die("Send failed: $!") unless $sent;
501
if($sent != length($full_msg)) {
502
die("only sent $sent of " . length($full_msg) . " bytes");
503
}
504
}
505
506
sub flush_socket {
507
my $self = shift;
508
$self->{socket}->flush;
509
}
510
511
# Send a silent command and ensure it doesn't respond.
512
sub send_silent {
513
my $self = shift;
514
die "Not enough args to send_silent" unless @_ >= 4;
515
my ($cmd, $key, $val, $opaque, $extra_header, $cas) = @_;
516
517
$self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
518
$self->send_command(::CMD_NOOP, '', '', $opaque + 1);
519
520
my ($ropaque, $data) = $self->_handle_single_response;
521
Test::More::is($ropaque, $opaque + 1);
522
}
523
524
sub silent_mutation {
525
my $self = shift;
526
my ($cmd, $key, $value) = @_;
527
528
$empty->($key);
529
my $extra = pack "NN", 82, 0;
530
$mc->send_silent($cmd, $key, $value, 7278552, $extra, 0);
531
$check->($key, 82, $value);
532
}
533
534
sub _handle_single_response {
535
my $self = shift;
536
my $myopaque = shift;
537
538
$self->{socket}->recv(my $response, ::MIN_RECV_BYTES);
539
Test::More::is(length($response), ::MIN_RECV_BYTES, "Expected read length");
540
541
my ($magic, $cmd, $keylen, $extralen, $datatype, $status, $remaining,
542
$opaque, $ident_hi, $ident_lo) = unpack(::RES_PKT_FMT, $response);
543
Test::More::is($magic, ::RES_MAGIC, "Got proper response magic");
544
545
my $cas = ($ident_hi * 2 ** 32) + $ident_lo;
546
547
return ($opaque, '', $cas, 0) if($remaining == 0);
548
549
# fetch the value
550
my $rv="";
551
while($remaining - length($rv) > 0) {
552
$self->{socket}->recv(my $buf, $remaining - length($rv));
553
$rv .= $buf;
554
}
555
if(length($rv) != $remaining) {
556
my $found = length($rv);
557
die("Expected $remaining bytes, got $found");
558
}
559
560
if (defined $myopaque) {
561
Test::More::is($opaque, $myopaque, "Expected opaque");
562
} else {
563
Test::More::pass("Implicit pass since myopaque is undefined");
564
}
565
566
if ($status) {
567
die MC::Error->new($status, $rv);
568
}
569
570
return ($opaque, $rv, $cas, $keylen);
571
}
572
573
sub _do_command {
574
my $self = shift;
575
die unless @_ >= 3;
576
my ($cmd, $key, $val, $extra_header, $cas) = @_;
577
578
$extra_header = '' unless defined $extra_header;
579
my $opaque = int(rand(2**32));
580
$self->send_command($cmd, $key, $val, $opaque, $extra_header, $cas);
581
my (undef, $rv, $rcas) = $self->_handle_single_response($opaque);
582
return ($rv, $rcas);
583
}
584
585
sub _incrdecr_header {
586
my $self = shift;
587
my ($amt, $init, $exp) = @_;
588
589
my $amt_hi = int($amt / 2 ** 32);
590
my $amt_lo = int($amt % 2 ** 32);
591
592
my $init_hi = int($init / 2 ** 32);
593
my $init_lo = int($init % 2 ** 32);
594
595
my $extra_header = pack(::INCRDECR_PKT_FMT, $amt_hi, $amt_lo, $init_hi,
596
$init_lo, $exp);
597
598
return $extra_header;
599
}
600
601
sub _incrdecr {
602
my $self = shift;
603
my ($cmd, $key, $amt, $init, $exp) = @_;
604
605
my ($data, undef) = $self->_do_command($cmd, $key, '',
606
$self->_incrdecr_header($amt, $init, $exp));
607
608
my $header = substr $data, 0, 8, '';
609
my ($resp_hi, $resp_lo) = unpack "NN", $header;
610
my $resp = ($resp_hi * 2 ** 32) + $resp_lo;
611
612
return $resp;
613
}
614
615
sub silent_incrdecr {
616
my $self = shift;
617
my ($cmd, $key, $amt, $init, $exp) = @_;
618
my $opaque = 8275753;
619
620
$mc->send_silent($cmd, $key, '', $opaque,
621
$mc->_incrdecr_header($amt, $init, $exp));
622
}
623
624
sub stats {
625
my $self = shift;
626
my $key = shift;
627
my $cas = 0;
628
my $opaque = int(rand(2**32));
629
$self->send_command(::CMD_STAT, $key, '', $opaque, '', $cas);
630
631
my %rv = ();
632
my $found_key = '';
633
my $found_val = '';
634
do {
635
my ($op, $data, $cas, $keylen) = $self->_handle_single_response($opaque);
636
if($keylen > 0) {
637
$found_key = substr($data, 0, $keylen);
638
$found_val = substr($data, $keylen);
639
$rv{$found_key} = $found_val;
640
} else {
641
$found_key = '';
642
}
643
} while($found_key ne '');
644
return %rv;
645
}
646
647
sub get {
648
my $self = shift;
649
my $key = shift;
650
my ($rv, $cas) = $self->_do_command(::CMD_GET, $key, '', '');
651
652
my $header = substr $rv, 0, 4, '';
653
my $flags = unpack("N", $header);
654
655
return ($flags, $rv, $cas);
656
}
657
658
sub get_multi {
659
my $self = shift;
660
my @keys = @_;
661
662
for (my $i = 0; $i < @keys; $i++) {
663
$self->send_command(::CMD_GETQ, $keys[$i], '', $i, '', 0);
664
}
665
666
my $terminal = @keys + 10;
667
$self->send_command(::CMD_NOOP, '', '', $terminal);
668
669
my %return;
670
while (1) {
671
my ($opaque, $data) = $self->_handle_single_response;
672
last if $opaque == $terminal;
673
674
my $header = substr $data, 0, 4, '';
675
my $flags = unpack("N", $header);
676
677
$return{$keys[$opaque]} = [$flags, $data];
678
}
679
680
return %return if wantarray;
681
return \%return;
682
}
683
684
sub version {
685
my $self = shift;
686
return $self->_do_command(::CMD_VERSION, '', '');
687
}
688
689
sub flush {
690
my $self = shift;
691
return $self->_do_command(::CMD_FLUSH, '', '');
692
}
693
694
sub add {
695
my $self = shift;
696
my ($key, $val, $flags, $expire) = @_;
697
my $extra_header = pack "NN", $flags, $expire;
698
my $cas = 0;
699
return $self->_do_command(::CMD_ADD, $key, $val, $extra_header, $cas);
700
}
701
702
sub set {
703
my $self = shift;
704
my ($key, $val, $flags, $expire, $cas) = @_;
705
my $extra_header = pack "NN", $flags, $expire;
706
return $self->_do_command(::CMD_SET, $key, $val, $extra_header, $cas);
707
}
708
709
sub _append_prepend {
710
my $self = shift;
711
my ($cmd, $key, $val, $cas) = @_;
712
return $self->_do_command($cmd, $key, $val, '', $cas);
713
}
714
715
sub replace {
716
my $self = shift;
717
my ($key, $val, $flags, $expire) = @_;
718
my $extra_header = pack "NN", $flags, $expire;
719
my $cas = 0;
720
return $self->_do_command(::CMD_REPLACE, $key, $val, $extra_header, $cas);
721
}
722
723
sub delete {
724
my $self = shift;
725
my ($key) = @_;
726
return $self->_do_command(::CMD_DELETE, $key, '');
727
}
728
729
sub incr {
730
my $self = shift;
731
my ($key, $amt, $init, $exp) = @_;
732
$amt = 1 unless defined $amt;
733
$init = 0 unless defined $init;
734
$exp = 0 unless defined $exp;
735
736
return $self->_incrdecr(::CMD_INCR, $key, $amt, $init, $exp);
737
}
738
739
sub decr {
740
my $self = shift;
741
my ($key, $amt, $init, $exp) = @_;
742
$amt = 1 unless defined $amt;
743
$init = 0 unless defined $init;
744
$exp = 0 unless defined $exp;
745
746
return $self->_incrdecr(::CMD_DECR, $key, $amt, $init, $exp);
747
}
748
749
sub noop {
750
my $self = shift;
751
return $self->_do_command(::CMD_NOOP, '', '');
752
}
753
754
package MC::Error;
755
756
use strict;
757
use warnings;
758
759
use constant ERR_UNKNOWN_CMD => 0x81;
760
use constant ERR_NOT_FOUND => 0x1;
761
use constant ERR_EXISTS => 0x2;
762
use constant ERR_TOO_BIG => 0x3;
763
use constant ERR_EINVAL => 0x4;
764
use constant ERR_NOT_STORED => 0x5;
765
use constant ERR_DELTA_BADVAL => 0x6;
766
767
use overload '""' => sub {
768
my $self = shift;
769
return "Memcache Error ($self->[0]): $self->[1]";
770
};
771
772
sub new {
773
my $class = shift;
774
my $error = [@_];
775
my $self = bless $error, (ref $class || $class);
776
777
return $self;
778
}
779
780
sub not_found {
781
my $self = shift;
782
return $self->[0] == ERR_NOT_FOUND;
783
}
784
785
sub exists {
786
my $self = shift;
787
return $self->[0] == ERR_EXISTS;
788
}
789
790
sub too_big {
791
my $self = shift;
792
return $self->[0] == ERR_TOO_BIG;
793
}
794
795
sub delta_badval {
796
my $self = shift;
797
return $self->[0] == ERR_DELTA_BADVAL;
798
}
799
800
sub einval {
801
my $self = shift;
802
return $self->[0] == ERR_EINVAL;
803
}
804
805
# vim: filetype=perl
806
Loggerhead is a web-based interface for Breezy
Version: 2.0.1