[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