r11368 - in /branches/upstream/libcache-memcached-perl/current: ChangeLog MANIFEST META.yml lib/Cache/Memcached.pm t/01_use.t t/02_keys.t t/03_stats.t t/all.t t/use.t
jeremiah-guest at users.alioth.debian.org
jeremiah-guest at users.alioth.debian.org
Tue Dec 18 12:15:23 UTC 2007
Author: jeremiah-guest
Date: Tue Dec 18 12:15:23 2007
New Revision: 11368
URL: http://svn.debian.org/wsvn/?sc=1&rev=11368
Log:
[svn-upgrade] Integrating new upstream version, libcache-memcached-perl (1.24)
Added:
branches/upstream/libcache-memcached-perl/current/t/01_use.t
branches/upstream/libcache-memcached-perl/current/t/02_keys.t
branches/upstream/libcache-memcached-perl/current/t/03_stats.t
Removed:
branches/upstream/libcache-memcached-perl/current/t/all.t
branches/upstream/libcache-memcached-perl/current/t/use.t
Modified:
branches/upstream/libcache-memcached-perl/current/ChangeLog
branches/upstream/libcache-memcached-perl/current/MANIFEST
branches/upstream/libcache-memcached-perl/current/META.yml
branches/upstream/libcache-memcached-perl/current/lib/Cache/Memcached.pm
Modified: branches/upstream/libcache-memcached-perl/current/ChangeLog
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/ChangeLog?rev=11368&op=diff
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/ChangeLog (original)
+++ branches/upstream/libcache-memcached-perl/current/ChangeLog Tue Dec 18 12:15:23 2007
@@ -1,3 +1,34 @@
+2007-07-17: version 1.24
+
+ * update the stats method, including tests for it
+ (Ronald J Kimball <rkimball+memcached at pangeamedia.com>)
+
+ * arguments to 'new' constructor can be %hash or $hashref now
+ (previously was only $hashref)
+
+ * work around a Perl segfault (Matthieu PATOU <mp at oxado.com>)
+ see http://lists.danga.com/pipermail/memcached/2007-June/004511.html
+
+2007-06-19: version 1.23
+
+ * add 'remove' as an alias for 'delete' (Dave Cardwell <dave at davecardwell.co.uk>)
+
+2007-06-18: version 1.22
+
+ * lost connection handling broken due to wrong %sock_map indexing
+ http://rt.cpan.org/Public/Bug/Display.html?id=27181
+ fix from RHESA
+
+ * let parser_class be configured as a constructor option,
+ defaulting to XS if available, else regular. (unless
+ $ENV{NO_XS} is set, in which case the default is regular)
+
+2007-05-02: version 1.21
+
+ * new faster optional interface for GetParser subclasses. doing
+ this release so upcoming Cache::Memcached::GetParserXS can
+ depend on this. otherwise this release isn't interesting.
+
2007-04-16: version 1.20
* fix "Warning produced when flush_all called" from CDENT
Modified: branches/upstream/libcache-memcached-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/MANIFEST?rev=11368&op=diff
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/MANIFEST (original)
+++ branches/upstream/libcache-memcached-perl/current/MANIFEST Tue Dec 18 12:15:23 2007
@@ -6,6 +6,7 @@
MANIFEST
MANIFEST.SKIP
TODO
-t/use.t
-t/all.t
+t/01_use.t
+t/02_keys.t
+t/03_stats.t
META.yml Module meta-data (added by MakeMaker)
Modified: branches/upstream/libcache-memcached-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/META.yml?rev=11368&op=diff
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/META.yml (original)
+++ branches/upstream/libcache-memcached-perl/current/META.yml Tue Dec 18 12:15:23 2007
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Cache-Memcached
-version: 1.20
+version: 1.24
version_from: lib/Cache/Memcached.pm
installdirs: site
requires:
Modified: branches/upstream/libcache-memcached-perl/current/lib/Cache/Memcached.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/lib/Cache/Memcached.pm?rev=11368&op=diff
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/lib/Cache/Memcached.pm (original)
+++ branches/upstream/libcache-memcached-perl/current/lib/Cache/Memcached.pm Tue Dec 18 12:15:23 2007
@@ -1,4 +1,4 @@
-# $Id: Memcached.pm 517 2007-04-17 06:46:55Z bradfitz $
+# $Id: Memcached.pm 601 2007-07-17 17:47:33Z bradfitz $
#
# Copyright (c) 2003, 2004 Brad Fitzpatrick <brad at danga.com>
#
@@ -8,6 +8,8 @@
package Cache::Memcached;
use strict;
+use warnings;
+
no strict 'refs';
use Storable ();
use Socket qw( MSG_NOSIGNAL PF_INET PF_UNIX IPPROTO_TCP SOCK_STREAM );
@@ -16,20 +18,13 @@
use String::CRC32;
use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN );
use Cache::Memcached::GetParser;
-my $HAVE_XS = eval "use Cache::Memcached::GetParserXS; 1;";
-$HAVE_XS = 0 if $ENV{NO_XS};
-
-my $parser_class = $HAVE_XS ? "Cache::Memcached::GetParserXS" : "Cache::Memcached::GetParser";
-if ($ENV{XS_DEBUG}) {
- print "using parser: $parser_class\n";
-}
-
use fields qw{
debug no_rehash stats compress_threshold compress_enable stat_callback
readonly select_timeout namespace namespace_len servers active buckets
pref_ip
bucketcount _single_sock _stime
connect_timeout cb_connect_fail
+ parser_class
};
# flag definitions
@@ -40,10 +35,18 @@
use constant COMPRESS_SAVINGS => 0.20; # percent
use vars qw($VERSION $HAVE_ZLIB $FLAG_NOSIGNAL);
-$VERSION = "1.20";
+$VERSION = "1.24";
BEGIN {
$HAVE_ZLIB = eval "use Compress::Zlib (); 1;";
+}
+
+my $HAVE_XS = eval "use Cache::Memcached::GetParserXS; 1;";
+$HAVE_XS = 0 if $ENV{NO_XS};
+
+my $parser_class = $HAVE_XS ? "Cache::Memcached::GetParserXS" : "Cache::Memcached::GetParser";
+if ($ENV{XS_DEBUG}) {
+ print "using parser: $parser_class\n";
}
$FLAG_NOSIGNAL = 0;
@@ -61,7 +64,7 @@
my Cache::Memcached $self = shift;
$self = fields::new( $self ) unless ref $self;
- my ($args) = @_;
+ my $args = (@_ == 1) ? shift : { @_ }; # hashref-ify args
$self->set_servers($args->{'servers'});
$self->{'debug'} = $args->{'debug'} || 0;
@@ -72,6 +75,7 @@
$self->{'compress_enable'} = 1;
$self->{'stat_callback'} = $args->{'stat_callback'} || undef;
$self->{'readonly'} = $args->{'readonly'};
+ $self->{'parser_class'} = $args->{'parser_class'} || $parser_class;
# TODO: undocumented
$self->{'connect_timeout'} = $args->{'connect_timeout'} || 0.25;
@@ -156,16 +160,16 @@
$self->{'stat_callback'} = $stat_callback;
}
-my %sock_map; # scalaraddr -> "$ip:$port";
+my %sock_map; # stringified-$sock -> "$ip:$port"
sub _dead_sock {
my ($sock, $ret, $dead_for) = @_;
- if (my $ipport = $sock_map{\$sock}) {
+ if (my $ipport = $sock_map{$sock}) {
my $now = time();
$host_dead{$ipport} = $now + $dead_for
if $dead_for;
delete $cache_sock{$ipport};
- delete $sock_map{\$sock};
+ delete $sock_map{$sock};
}
@buck2sock = ();
return $ret; # 0 or undef, probably, depending on what caller wants
@@ -173,10 +177,10 @@
sub _close_sock {
my ($sock) = @_;
- if (my $ipport = $sock_map{\$sock}) {
+ if (my $ipport = $sock_map{$sock}) {
close $sock;
delete $cache_sock{$ipport};
- delete $sock_map{\$sock};
+ delete $sock_map{$sock};
}
@buck2sock = ();
}
@@ -398,7 +402,6 @@
return $ret;
}
-
sub delete {
my Cache::Memcached $self = shift;
my ($key, $time) = @_;
@@ -420,6 +423,7 @@
return $res eq "DELETED\r\n";
}
+*remove = \&delete;
sub add {
_set("add", @_);
@@ -544,7 +548,9 @@
if ($self->{'_single_sock'}) {
$sock = $self->sock_to_host($self->{'_single_sock'});
- return {} unless $sock;
+ unless ($sock) {
+ return {};
+ }
foreach my $key (@_) {
my $kval = ref $key ? $key->[1] : $key;
push @{$sock_keys{$sock}}, $kval;
@@ -561,8 +567,18 @@
my $tries;
while (1) {
my $bucket = $hv % $bcount;
- $sock = $buck2sock[$bucket] ||= $self->sock_to_host($self->{buckets}[ $bucket ])
- and last;
+
+ # this segfaults perl 5.8.4 (and others?) if sock_to_host returns undef... wtf?
+ #$sock = $buck2sock[$bucket] ||= $self->sock_to_host($self->{buckets}[ $bucket ])
+ # and last;
+
+ # but this variant doesn't crash:
+ $sock = $buck2sock[$bucket] || $self->sock_to_host($self->{buckets}[ $bucket ]);
+ if ($sock) {
+ $buck2sock[$bucket] = $sock;
+ last;
+ }
+
next KEY if $tries++ >= 20;
$hv += _hashfunc($tries . $real_key);
}
@@ -622,25 +638,31 @@
_dead_sock($sock);
};
+ # $finalize->($key, $flags)
+ # $finalize->({ $key => $flags, $key => $flags });
my $finalize = sub {
- my ($k, $flags) = @_;
-
- # 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};
+ 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};
+ }
}
}
};
@@ -656,7 +678,7 @@
$buf{$_} = join(" ", 'get', @{$sock_keys->{$_}}, "\r\n");
}
- $parser{$_} = $parser_class->new($ret, $self->{namespace_len}, $finalize);
+ $parser{$_} = $self->{parser_class}->new($ret, $self->{namespace_len}, $finalize);
}
my $read = sub {
@@ -808,9 +830,15 @@
$stats_hr->{'self'} = \%{ $self->{'stats'} };
}
+ my %misc_keys = map { $_ => 1 }
+ qw/ bytes bytes_read bytes_written
+ cmd_get cmd_set connection_structures curr_items
+ get_hits get_misses
+ total_connections total_items
+ /;
+
# Now handle the other types, passing each type to each host server.
my @hosts = @{$self->{'buckets'}};
- my %malloc_keys = ( );
HOST: foreach my $host (@hosts) {
my $sock = $self->sock_to_host($host);
TYPE: foreach my $typename (grep !/^self$/, @$types) {
@@ -840,7 +868,10 @@
if ($key) {
$stats_hr->{'hosts'}{$host}{$typename}{$key} = $value;
}
- $malloc_keys{$key} = 1 if $key && $typename eq 'malloc';
+ $stats_hr->{'total'}{$key} += $value
+ if $typename eq 'misc' && $key && $misc_keys{$key};
+ $stats_hr->{'total'}{"malloc_$key"} += $value
+ if $typename eq 'malloc' && $key;
}
} else {
# This stat is not key-value so just pull it
@@ -852,29 +883,6 @@
}
}
- # Now get the sum total of applicable values. First the misc values.
- foreach my $stat (qw(
- bytes bytes_read bytes_written
- cmd_get cmd_set connection_structures curr_items
- get_hits get_misses
- total_connections total_items
- )) {
- $stats_hr->{'total'}{$stat} = 0;
- foreach my $host (@hosts) {
- $stats_hr->{'total'}{$stat} +=
- $stats_hr->{'hosts'}{$host}{'misc'}{$stat};
- }
- }
-
- # Then all the malloc values, if any.
- foreach my $malloc_stat (keys %malloc_keys) {
- $stats_hr->{'total'}{"malloc_$malloc_stat"} = 0;
- foreach my $host (@hosts) {
- $stats_hr->{'total'}{"malloc_$malloc_stat"} +=
- $stats_hr->{'hosts'}{$host}{'malloc'}{$malloc_stat};
- }
- }
-
return $stats_hr;
}
@@ -892,8 +900,6 @@
}
return 1;
}
-
-
1;
__END__
@@ -1063,6 +1069,9 @@
(Sometimes useful as a hacky means to prevent races.) Returns true if key
was found and deleted, and false otherwise.
+You may also use the alternate method name B<remove>, so
+Cache::Memcached looks like the L<Cache::Cache> API.
+
=item C<incr>
$memd->incr($key[, $value]);
Added: branches/upstream/libcache-memcached-perl/current/t/01_use.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/t/01_use.t?rev=11368&op=file
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/t/01_use.t (added)
+++ branches/upstream/libcache-memcached-perl/current/t/01_use.t Tue Dec 18 12:15:23 2007
@@ -1,0 +1,7 @@
+#!/usr/bin/env perl -w
+use strict;
+use Test;
+BEGIN { plan tests => 1 }
+
+use Cache::Memcached; ok(1);
+exit;
Added: branches/upstream/libcache-memcached-perl/current/t/02_keys.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/t/02_keys.t?rev=11368&op=file
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/t/02_keys.t (added)
+++ branches/upstream/libcache-memcached-perl/current/t/02_keys.t Tue Dec 18 12:15:23 2007
@@ -1,0 +1,44 @@
+# -*-perl-*-
+
+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 => 10;
+} 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) . "/",
+});
+
+
+ok($memd->set("key1", "val1"), "set succeeded");
+
+is($memd->get("key1"), "val1", "get worked");
+ok(! $memd->add("key1", "val-replace"), "add properly failed");
+ok($memd->add("key2", "val2"), "add worked on key2");
+is($memd->get("key2"), "val2", "get worked");
+
+ok($memd->replace("key2", "val-replace"), "replace worked");
+ok(! $memd->replace("key-noexist", "bogus"), "replace failed");
+
+my $stats = $memd->stats;
+ok($stats, "got stats");
+is(ref $stats, "HASH", "is a hashref");
+
+
+# also make one without a hashref
+my $mem2 = Cache::Memcached->new(
+ servers => [ ],
+ debug => 1,
+ );
+ok($mem2->{debug}, "debug is set on alt constructed instance");
Added: branches/upstream/libcache-memcached-perl/current/t/03_stats.t
URL: http://svn.debian.org/wsvn/branches/upstream/libcache-memcached-perl/current/t/03_stats.t?rev=11368&op=file
==============================================================================
--- branches/upstream/libcache-memcached-perl/current/t/03_stats.t (added)
+++ branches/upstream/libcache-memcached-perl/current/t/03_stats.t Tue Dec 18 12:15:23 2007
@@ -1,0 +1,78 @@
+# -*-perl-*-
+
+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);
+
+my @misc_stats_keys = qw/ bytes bytes_read bytes_written
+ cmd_get cmd_set connection_structures curr_items
+ get_hits get_misses
+ total_connections total_items
+ /;
+
+if ($msock) {
+ plan tests => 24 + scalar(@misc_stats_keys);
+} 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) . "/",
+});
+
+my $misc_stats = $memd->stats('misc');
+ok($misc_stats, 'got misc stats');
+isa_ok($misc_stats, 'HASH', 'misc stats');
+isa_ok($misc_stats->{'total'}, 'HASH', 'misc stats total');
+isa_ok($misc_stats->{'hosts'}, 'HASH', 'misc stats hosts');
+isa_ok($misc_stats->{'hosts'}{$testaddr}, 'HASH',
+ "misc stats hosts $testaddr");
+
+foreach my $stat_key (@misc_stats_keys) {
+ ok(exists $misc_stats->{'total'}{$stat_key},
+ "misc stats total contains $stat_key");
+ ok(exists $misc_stats->{'hosts'}{$testaddr}{'misc'}{$stat_key},
+ "misc stats hosts $testaddr misc contains $stat_key");
+}
+
+my $got_malloc = 0;
+foreach my $stat_key (keys %{$misc_stats->{'total'}}) {
+ if ($stat_key =~ /^malloc/) {
+ $got_malloc = 1;
+ last;
+ }
+}
+ok(! $got_malloc, 'no malloc stats in misc stats');
+
+my $malloc_stats = $memd->stats('malloc');
+ok($malloc_stats, 'got malloc stats');
+isa_ok($malloc_stats, 'HASH', 'malloc stats');
+isa_ok($malloc_stats->{'total'}, 'HASH', 'malloc stats total');
+isa_ok($misc_stats->{'hosts'}, 'HASH', 'malloc stats hosts');
+isa_ok($misc_stats->{'hosts'}{$testaddr}, 'HASH',
+ "malloc stats host $testaddr");
+
+$got_malloc = 0;
+foreach my $stat_key (keys %{$malloc_stats->{'total'}}) {
+ if ($stat_key =~ /^malloc/) {
+ $got_malloc = 1;
+ last;
+ }
+}
+ok($got_malloc, 'malloc stats in malloc stats');
+
+my $got_misc = 0;
+foreach my $stat_key (@misc_stats_keys) {
+ if (exists $malloc_stats->{'total'}{$stat_key}) {
+ $got_misc = 1;
+ last;
+ }
+}
+ok(! $got_misc, 'no misc stats in malloc stats');
More information about the Pkg-perl-cvs-commits
mailing list