[PATCH 2/2] Cache::Memcached: add delete_multi() method.
Tomash Brechko
tomash.brechko at gmail.com
Tue Nov 13 13:28:57 UTC 2007
delete_multi() uses the framework for get_multi(), and sends mdelete
command to the server.
---
trunk/api/perl/lib/Cache/Memcached.pm | 144 +++++++++++++++--------
trunk/api/perl/lib/Cache/Memcached/GetParser.pm | 81 +++++++++----
trunk/api/perl/t/05_delete_multi.t | 58 +++++++++
3 files changed, 209 insertions(+), 74 deletions(-)
create mode 100644 trunk/api/perl/t/05_delete_multi.t
diff --git a/trunk/api/perl/lib/Cache/Memcached.pm b/trunk/api/perl/lib/Cache/Memcached.pm
index 62bf609..e9194b6 100644
--- a/trunk/api/perl/lib/Cache/Memcached.pm
+++ b/trunk/api/perl/lib/Cache/Memcached.pm
@@ -555,11 +555,93 @@ sub get_multi {
$self->{'stats'}->{"get_multi"}++;
my %val; # what we'll be returning a reference to (realkey -> value)
+ my $sock_keys = $self->_dispatch_keys(@_);
+
+ $self->{'stats'}->{"get_keys"} += @_;
+ $self->{'stats'}->{"get_socks"} += keys %$sock_keys;
+
+ local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
+
+ # $finalize->($key, $flags)
+ my $finalize = sub {
+ my ($k, $flags) = @_;
+ my $ret = \%val;
+
+ # remove trailing \r\n
+ chop $ret->{$k}; chop $ret->{$k};
+
+ $ret->{$k} = Compress::Zlib::memGunzip($ret->{$k})
+ if $HAVE_ZLIB && $flags & F_COMPRESS;
+ if ($flags & F_STORABLE) {
+ # wrapped in eval in case a perl 5.6 Storable tries to
+ # unthaw data from a perl 5.8 Storable. (5.6 is stupid
+ # and dies if the version number changes at all. in 5.8
+ # they made it only die if it unencounters a new feature)
+ eval {
+ $ret->{$k} = Storable::thaw($ret->{$k});
+ };
+ # so if there was a problem, just treat it as a cache miss.
+ if ($@) {
+ delete $ret->{$k};
+ }
+ }
+ };
+
+ _load_multi($self, $sock_keys, \%val, 'get', $finalize,
+ sub { my $self = shift; $self->parse_get(@_) });
+
+ if ($self->{'debug'}) {
+ while (my ($k, $v) = each %val) {
+ print STDERR "MemCache: got $k = $v\n";
+ }
+ }
+ return \%val;
+}
+
+sub delete_multi {
+ my Cache::Memcached $self = shift;
+ return {} unless $self->{'active'};
+ $self->{'_stime'} = Time::HiRes::time() if $self->{'stat_callback'};
+ $self->{'stats'}->{"delete_multi"}++;
+
+ my @params = (0); # zero mdelete delay.
+ my $noreply = not defined wantarray;
+ push @params, ($noreply ? "noreply" : "reply");
+
+ my %val; # what we'll be returning a reference to (realkey -> value)
+ my $sock_keys = $self->_dispatch_keys(@_);
+
+ $self->{'stats'}->{"delete_keys"} += @_;
+ $self->{'stats'}->{"delete_socks"} += keys %$sock_keys;
+
+ local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
+
+ # $finalize->($key)
+ my $finalize = sub {
+ my $k = $_[0];
+ my $ret = \%val;
+
+ # remove trailing \r\n
+ $ret->{$k} =~ s/\r\n\Z//;
+ };
+
+ _load_multi($self, $sock_keys, \%val, "mdelete @params", $finalize,
+ sub { my $self = shift; $self->parse_mdelete(@_) }, $noreply);
+
+ if ($self->{'debug'}) {
+ while (my ($k, $v) = each %val) {
+ print STDERR "MemCache: got $k = $v\n";
+ }
+ }
+ return \%val unless $noreply;
+}
+
+sub _dispatch_keys {
+ my Cache::Memcached $self = shift;
my %sock_keys; # sockref_as_scalar -> [ realkeys ]
- my $sock;
if ($self->{'_single_sock'}) {
- $sock = $self->sock_to_host($self->{'_single_sock'});
+ my $sock = $self->sock_to_host($self->{'_single_sock'});
unless ($sock) {
return {};
}
@@ -599,27 +681,13 @@ sub get_multi {
}
}
- $self->{'stats'}->{"get_keys"} += @_;
- $self->{'stats'}->{"get_socks"} += keys %sock_keys;
-
- local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
-
- _load_multi($self, \%sock_keys, \%val);
-
- if ($self->{'debug'}) {
- while (my ($k, $v) = each %val) {
- print STDERR "MemCache: got $k = $v\n";
- }
- }
- return \%val;
+ return \%sock_keys;
}
sub _load_multi {
use bytes; # return bytes from length()
- my Cache::Memcached $self;
- my ($sock_keys, $ret);
-
- ($self, $sock_keys, $ret) = @_;
+ my Cache::Memcached $self = shift;
+ my ($sock_keys, $ret, $request, $finalize, $parse_method, $noreply) = @_;
# all keyed by $sockstr:
my %reading; # $sockstr -> $sock. bool, whether we're reading from this socket
@@ -650,47 +718,19 @@ sub _load_multi {
_dead_sock($sock);
};
- # $finalize->($key, $flags)
- # $finalize->({ $key => $flags, $key => $flags });
- my $finalize = sub {
- my $map = $_[0];
- $map = {@_} unless ref $map;
-
- while (my ($k, $flags) = each %$map) {
-
- # remove trailing \r\n
- chop $ret->{$k}; chop $ret->{$k};
-
- $ret->{$k} = Compress::Zlib::memGunzip($ret->{$k})
- if $HAVE_ZLIB && $flags & F_COMPRESS;
- if ($flags & F_STORABLE) {
- # wrapped in eval in case a perl 5.6 Storable tries to
- # unthaw data from a perl 5.8 Storable. (5.6 is stupid
- # and dies if the version number changes at all. in 5.8
- # they made it only die if it unencounters a new feature)
- eval {
- $ret->{$k} = Storable::thaw($ret->{$k});
- };
- # so if there was a problem, just treat it as a cache miss.
- if ($@) {
- delete $ret->{$k};
- }
- }
- }
- };
-
foreach (keys %$sock_keys) {
my $ipport = $sock_map{$_} or die "No map found matching for $_";
my $sock = $cache_sock{$ipport} or die "No sock found for $ipport";
print STDERR "processing socket $_\n" if $self->{'debug'} >= 2;
$writing{$_} = $sock;
if ($self->{namespace}) {
- $buf{$_} = join(" ", 'get', (map { "$self->{namespace}$_" } @{$sock_keys->{$_}}), "\r\n");
+ $buf{$_} = join(" ", $request, (map { "$self->{namespace}$_" } @{$sock_keys->{$_}}), "\r\n");
} else {
- $buf{$_} = join(" ", 'get', @{$sock_keys->{$_}}, "\r\n");
+ $buf{$_} = join(" ", $request, @{$sock_keys->{$_}}, "\r\n");
}
- $parser{$_} = $self->{parser_class}->new($ret, $self->{namespace_len}, $finalize);
+ $parser{$_} = $self->{parser_class}->new($ret, $self->{namespace_len},
+ $finalize, $parse_method);
}
my $read = sub {
@@ -724,7 +764,7 @@ sub _load_multi {
# switch the socket from writing to reading
delete $writing{$sockstr};
- $reading{$sockstr} = $sock;
+ $reading{$sockstr} = $sock unless $noreply;
return 1;
} else { # we only succeeded in sending some of it
substr($buf{$sockstr}, 0, $res, ''); # delete the part we sent
diff --git a/trunk/api/perl/lib/Cache/Memcached/GetParser.pm b/trunk/api/perl/lib/Cache/Memcached/GetParser.pm
index 71a7387..3e5ea8c 100644
--- a/trunk/api/perl/lib/Cache/Memcached/GetParser.pm
+++ b/trunk/api/perl/lib/Cache/Memcached/GetParser.pm
@@ -13,10 +13,12 @@ use constant STATE => 4; # 0 = waiting for a line, N = reading N bytes
use constant OFFSET => 5; # offsets to read into buffers
use constant FLAGS => 6;
use constant KEY => 7; # current key we're parsing (without the namespace prefix)
+use constant METHOD => 8; # method to be used for parsing
sub new {
- my ($class, $dest, $nslen, $on_item) = @_;
- return bless [$dest, $nslen, $on_item, '', 0, 0], $class;
+ my ($class, $dest, $nslen, $on_item, $parse_method) = @_;
+ return bless [$dest, $nslen, $on_item, '', 0, 0,
+ undef, undef, $parse_method], $class;
}
sub current_key {
@@ -83,26 +85,9 @@ sub parse_buffer {
return 1; # we're done successfully, return 1 to finish
}
- # do we have a complete VALUE line?
- if ($self->[BUF] =~ /^VALUE (\S+) (\d+) (\d+)\r\n/) {
- ($self->[KEY], $self->[FLAGS], $self->[STATE]) =
- (substr($1, $self->[NSLEN]), int($2), $3+2);
- # Note: we use $+[0] and not pos($self->[BUF]) because pos()
- # seems to have problems under perl's taint mode. nobody
- # on the list discovered why, but this seems a reasonable
- # work-around:
- my $p = $+[0];
- my $len = length($self->[BUF]);
- my $copy = $len-$p > $self->[STATE] ? $self->[STATE] : $len-$p;
- $ret->{$self->[KEY]} = substr($self->[BUF], $p, $copy)
- if $copy;
- $self->[OFFSET] = $copy;
- substr($self->[BUF], 0, $p+$copy, ''); # delete the stuff we used
-
- if ($self->[OFFSET] == $self->[STATE]) { # have it all?
- $self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]);
- $self->[OFFSET] = 0;
- $self->[STATE] = 0;
+ my $next = $self->[METHOD]($self, $ret);
+ if (defined $next) {
+ if ($next) {
next SEARCH; # look again
}
@@ -122,4 +107,56 @@ sub parse_buffer {
return 0;
}
+sub parse_get {
+ my ($self, $ret) = @_;
+
+ # do we have a complete VALUE line?
+ if ($self->[BUF] =~ /^VALUE (\S+) (\d+) (\d+)\r\n/) {
+ ($self->[KEY], $self->[FLAGS], $self->[STATE]) =
+ (substr($1, $self->[NSLEN]), int($2), $3+2);
+ # Note: we use $+[0] and not pos($self->[BUF]) because pos()
+ # seems to have problems under perl's taint mode. nobody
+ # on the list discovered why, but this seems a reasonable
+ # work-around:
+ my $p = $+[0];
+ my $len = length($self->[BUF]);
+ my $copy = $len-$p > $self->[STATE] ? $self->[STATE] : $len-$p;
+ $ret->{$self->[KEY]} = substr($self->[BUF], $p, $copy)
+ if $copy;
+ $self->[OFFSET] = $copy;
+ substr($self->[BUF], 0, $p+$copy, ''); # delete the stuff we used
+
+ if ($self->[OFFSET] == $self->[STATE]) { # have it all?
+ $self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]);
+ $self->[OFFSET] = 0;
+ $self->[STATE] = 0;
+ return 1;
+ }
+ return 0;
+ }
+
+ return undef;
+}
+
+sub parse_mdelete {
+ my ($self, $ret) = @_;
+
+ # do we have a complete VALUE line?
+ if ($self->[BUF] =~ s/^VALUE (\S+) (.+)\r\n//) {
+ $self->[KEY] = substr($1, $self->[NSLEN]);
+ my $res = \$ret->{$self->[KEY]};
+ # If there were duplicates in the key list, do not overwrite
+ # the result of the first occurrence with the subsequent one.
+ $$res = $2 unless defined $$res;
+ $self->[ON_ITEM]->($self->[KEY]);
+ $self->[OFFSET] = length($self->[BUF]);
+ $self->[OFFSET] = 0;
+ $self->[STATE] = 0;
+ return 1;
+ }
+
+ return undef;
+}
+
+
1;
diff --git a/trunk/api/perl/t/05_delete_multi.t b/trunk/api/perl/t/05_delete_multi.t
new file mode 100644
index 0000000..4a611d9
--- /dev/null
+++ b/trunk/api/perl/t/05_delete_multi.t
@@ -0,0 +1,58 @@
+#!/usr/bin/env perl -w
+
+use strict;
+use Test::More;
+use Cache::Memcached;
+use IO::Socket::INET;
+
+my $testaddr = "127.0.0.1:11211";
+my $msock = IO::Socket::INET->new(PeerAddr => $testaddr,
+ Timeout => 3);
+if ($msock) {
+ plan tests => 4;
+} else {
+ plan skip_all => "No memcached instance running at $testaddr\n";
+ exit 0;
+}
+
+my $memd = Cache::Memcached->new({
+ servers => [ $testaddr ],
+ namespace => "Cache::Memcached::t/$$/" . (time() % 100) . "/",
+});
+
+isa_ok($memd, 'Cache::Memcached');
+
+
+use constant count => 100;
+
+my @keys = ((map { "foo$_" } (1 .. count)), "foo");
+
+foreach my $key (@keys) {
+ $memd->set($key, 1);
+}
+# Test delete_multi() in void context.
+$memd->delete_multi(@keys);
+is($memd->get("foo"), undef);
+
+foreach my $key (@keys) {
+ $memd->set($key, 1);
+}
+push @keys, "foo", "x" x 251, "bar", "bar";
+
+# Test delete_multi() result format.
+my $ret = $memd->delete_multi(@keys);
+ok(keys %$ret == @keys - 2);
+
+my $ok;
+foreach my $key (@keys) {
+ my $res = $$ret{$key};
+ if ($res eq "DELETED") {
+ $ok = $key =~ /^foo(?:\d+)?$/;
+ } elsif ($res eq "NOT_FOUND") {
+ $ok = $key eq "bar";
+ } elsif ($res eq "CLIENT_ERROR key too long") {
+ $ok = length($key) > 250;
+ }
+ last unless $ok;
+}
+ok($ok);
--
1.5.3.5.529.ge3d6d
More information about the memcached
mailing list