@@ -1,69 +1,3 @@
-
-use strict;
-use warnings;
-
-use Module::Build 0.3601;
-
-
-my %module_build_args = (
- "build_requires" => {
- "Module::Build" => "0.3601"
- },
- "configure_requires" => {
- "ExtUtils::MakeMaker" => "6.63_03",
- "Module::Build" => "0.3601"
- },
- "dist_abstract" => "Perl binding for Redis database",
- "dist_author" => [
- "Pedro Melo <melo\@cpan.org>",
- "Damien Krotkine <dams\@cpan.org>"
- ],
- "dist_name" => "Redis",
- "dist_version" => "1.965",
- "license" => "artistic_2",
- "module_name" => "Redis",
- "recommends" => {},
- "recursive_test_files" => 1,
- "requires" => {
- "Try::Tiny" => 0,
- "perl" => "5.008"
- },
- "script_files" => [],
- "test_requires" => {
- "Digest::SHA" => 0,
- "File::Spec" => 0,
- "IO::Handle" => 0,
- "IO::String" => 0,
- "IPC::Cmd" => 0,
- "IPC::Open3" => 0,
- "Test::Deep" => 0,
- "Test::Fatal" => 0,
- "Test::More" => "0.98",
- "Test::SharedFork" => 0
- }
-);
-
-
-my %fallback_build_requires = (
- "Digest::SHA" => 0,
- "File::Spec" => 0,
- "IO::Handle" => 0,
- "IO::String" => 0,
- "IPC::Cmd" => 0,
- "IPC::Open3" => 0,
- "Module::Build" => "0.3601",
- "Test::Deep" => 0,
- "Test::Fatal" => 0,
- "Test::More" => "0.98",
- "Test::SharedFork" => 0
-);
-
-
-unless ( eval { Module::Build->VERSION(0.4004) } ) {
- delete $module_build_args{test_requires};
- $module_build_args{build_requires} = \%fallback_build_requires;
-}
-
-my $build = Module::Build->new(%module_build_args);
-
-$build->create_build_script;
+use 5.008;
+use Module::Build::Tiny 0.030;
+Build_PL();
@@ -1,5 +1,57 @@
Revision history for Redis
+1.974 2014-05-16 21:42:48 Europe/Amsterdam
+
+1.973_04 2014-05-12 22:53:06 Europe/Amsterdam
+
+ * release again, last one was screwed up.
+ * fix #85 (PR #86) reconnect during transaction
+
+1.973_03 2014-05-12 22:49:07 Europe/Amsterdam
+
+ * fix #85 (PR #86) reconnect during transaction
+
+1.973_02 2014-04-30 12:04:29 Europe/Amsterdam
+
+ * merge PR #84 optimize try read sock
+
+1.973_01 2014-04-26 18:00:31 Europe/Amsterdam
+
+ * use new network code from Ivan Kruglov
+ * fix sentinel tests
+ * fix #81: doc for 'every' option
+
+1.972 2014-02-18 00:54:01 Europe/Amsterdam
+ * Sentinel features (connections, timeouts, etc) support
+ * various bugfixes and testfixes
+ * fix network code for BSDs
+ * no_auto_connect_on_new
+
+1.971 2014-02-01 09:55:11 Europe/Paris
+
+ * skip some tests that fail on some platforms for now
+
+1.970 2014-01-30 15:07:42 Europe/Amsterdam
+
+ * fix tests breaking in some case
+
+1.969 2014-01-30 13:19:28 Europe/Amsterdam
+
+ * Clarification for (p)unsubscribe commands.
+ * use Test::TCP for testing
+
+1.968 2014-01-30 12:19:11 Europe/Amsterdam
+
+ * Add a no_auto_connect_on_new parameter to new() to allow users
+ to call $x = Redis->new and then $x->connect, instead of Redis
+ auto-connecting. Useful for tuning the cnx_timeout parameter.
+
+1.967 2013-12-28 22:58:55 Europe/Paris
+ * use new IO::Socket::Timeout with different API
+
+1.966 2013-12-17 13:58:33 Europe/Amsterdam
+ * fix tests for Redis 2.8
+
1.965 2013-11-29 09:28:36 Europe/Amsterdam
* fix #60: TEST_REQUIRES needs newer MakeMaker
@@ -2,6 +2,7 @@ Build.PL
Changes
LICENSE
MANIFEST
+META.json
META.yml
Makefile.PL
README
@@ -9,6 +10,7 @@ dist.ini
lib/Redis.pm
lib/Redis/Hash.pm
lib/Redis/List.pm
+lib/Redis/Sentinel.pm
scripts/publish.pl
scripts/redis-benchmark.pl
t/00-compile.t
@@ -20,8 +22,8 @@ t/05-nonblock.t
t/06-on-connect.t
t/07-reconnect.t
t/08-unix-socket.t
-t/09-env-redis-server.t
t/10-tie-list.t
+t/11-timeout.t
t/20-tie-hash.t
t/30-scripts.t
t/42-client_cmds.t
@@ -29,6 +31,7 @@ t/50-fork_safe.t
t/release-distmeta.t
t/release-pod-coverage.t
t/tlib/Test/SpawnRedisServer.pm
+t/tlib/Test/SpawnRedisTimeoutServer.pm
tools/benchmarks/read_vs_sysread.pl
tools/benchmarks/readline_vs_sysread_vs_recv/client-readline.pl
tools/benchmarks/readline_vs_sysread_vs_recv/client-recv.pl
@@ -0,0 +1,70 @@
+{
+ "abstract" : "Perl binding for Redis database",
+ "author" : [
+ "Pedro Melo <melo@cpan.org>",
+ "Damien Krotkine <dams@cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 5.005, CPAN::Meta::Converter version 2.132830",
+ "license" : [
+ "artistic_2"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Redis",
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.63_03",
+ "Module::Build::Tiny" : "0.030"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Pod::Coverage::TrustPod" : "0",
+ "Test::CPAN::Meta" : "0",
+ "Test::Pod::Coverage" : "1.08"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "IO::Socket::Timeout" : "0.22",
+ "Try::Tiny" : "0",
+ "perl" : "5.008"
+ }
+ },
+ "test" : {
+ "requires" : {
+ "Digest::SHA" : "0",
+ "File::Spec" : "0",
+ "IO::Handle" : "0",
+ "IO::String" : "0",
+ "IPC::Cmd" : "0",
+ "IPC::Open3" : "0",
+ "Pod::Coverage::TrustPod" : "0",
+ "Test::CPAN::Meta" : "0",
+ "Test::Deep" : "0",
+ "Test::Fatal" : "0",
+ "Test::More" : "0.98",
+ "Test::SharedFork" : "0",
+ "Test::TCP" : "1.19"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/PerlRedis/perl-redis/issues"
+ },
+ "homepage" : "https://github.com/PerlRedis/perl-redis",
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/PerlRedis/perl-redis.git",
+ "web" : "https://github.com/PerlRedis/perl-redis"
+ }
+ },
+ "version" : "1.974"
+}
+
@@ -10,14 +10,16 @@ build_requires:
IO::String: 0
IPC::Cmd: 0
IPC::Open3: 0
- Module::Build: 0.3601
+ Pod::Coverage::TrustPod: 0
+ Test::CPAN::Meta: 0
Test::Deep: 0
Test::Fatal: 0
Test::More: 0.98
Test::SharedFork: 0
+ Test::TCP: 1.19
configure_requires:
ExtUtils::MakeMaker: 6.63_03
- Module::Build: 0.3601
+ Module::Build::Tiny: 0.030
dynamic_config: 0
generated_by: 'Dist::Zilla version 5.005, CPAN::Meta::Converter version 2.132830'
license: artistic_2
@@ -26,10 +28,11 @@ meta-spec:
version: 1.4
name: Redis
requires:
+ IO::Socket::Timeout: 0.22
Try::Tiny: 0
perl: 5.008
resources:
bugtracker: https://github.com/PerlRedis/perl-redis/issues
homepage: https://github.com/PerlRedis/perl-redis
repository: https://github.com/PerlRedis/perl-redis.git
-version: 1.965
+version: 1.974
@@ -1,7 +1,66 @@
+# This Makefile.PL for Redis was generated by
+# Dist::Zilla::Plugin::MakeMaker::Fallback 0.005
+# and Dist::Zilla::Plugin::MakeMaker::Awesome 0.19.
+# Don't edit it but the dist.ini and plugins used to construct it.
use strict;
use warnings;
+BEGIN {
+my %configure_requires = (
+ 'Module::Build::Tiny' => '0.030',
+ 'ExtUtils::MakeMaker' => '6.63_03',
+);
+
+my @missing = grep {
+ ! eval "require $_; $_->VERSION($configure_requires{$_}); 1"
+} keys %configure_requires;
+
+if (not @missing)
+{
+ print "Congratulations, your toolchain understands 'configure_requires'!\n\n";
+}
+else
+{
+ $ENV{PERL_MM_FALLBACK_SILENCE_WARNING} or warn <<'EOW';
+*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***
+
+If you're seeing this warning, your toolchain is really, really old* and you'll
+almost certainly have problems installing CPAN modules from this century. But
+never fear, dear user, for we have the technology to fix this!
+
+If you're using CPAN.pm to install things, then you can upgrade it using:
+
+ cpan CPAN
+
+If you're using CPANPLUS to install things, then you can upgrade it using:
+
+ cpanp CPANPLUS
+
+If you're using cpanminus, you shouldn't be seeing this message in the first
+place, so please file an issue on github.
+
+If you're installing manually, please retrain your fingers to run Build.PL
+when present instead.
+
+This public service announcement was brought to you by the Perl Toolchain
+Gang, the irc.perl.org #toolchain IRC channel, and the number 42.
+
+----
+
+* Alternatively, you are doing something overly clever, in which case you
+should consider setting the 'prefer_installer' config option in CPAN.pm, or
+'prefer_makefile' in CPANPLUS, to 'mb" and '0' respectively.
+
+You can also silence this warning for future installations by setting the
+PERL_MM_FALLBACK_SILENCE_WARNING environment variable.
+
+EOW
+
+ sleep 10 if -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
+}
+}
+
use 5.008;
use ExtUtils::MakeMaker 6.63_03;
@@ -11,18 +70,17 @@ use ExtUtils::MakeMaker 6.63_03;
my %WriteMakefileArgs = (
"ABSTRACT" => "Perl binding for Redis database",
"AUTHOR" => "Pedro Melo <melo\@cpan.org>, Damien Krotkine <dams\@cpan.org>",
- "BUILD_REQUIRES" => {
- "Module::Build" => "0.3601"
- },
+ "BUILD_REQUIRES" => {},
"CONFIGURE_REQUIRES" => {
"ExtUtils::MakeMaker" => "6.63_03",
- "Module::Build" => "0.3601"
+ "Module::Build::Tiny" => "0.030"
},
"DISTNAME" => "Redis",
"EXE_FILES" => [],
"LICENSE" => "artistic_2",
"NAME" => "Redis",
"PREREQ_PM" => {
+ "IO::Socket::Timeout" => "0.22",
"Try::Tiny" => 0
},
"TEST_REQUIRES" => {
@@ -32,12 +90,15 @@ my %WriteMakefileArgs = (
"IO::String" => 0,
"IPC::Cmd" => 0,
"IPC::Open3" => 0,
+ "Pod::Coverage::TrustPod" => 0,
+ "Test::CPAN::Meta" => 0,
"Test::Deep" => 0,
"Test::Fatal" => 0,
"Test::More" => "0.98",
- "Test::SharedFork" => 0
+ "Test::SharedFork" => 0,
+ "Test::TCP" => "1.19"
},
- "VERSION" => "1.965",
+ "VERSION" => "1.974",
"test" => {
"TESTS" => "t/*.t"
}
@@ -48,14 +109,17 @@ my %FallbackPrereqs = (
"Digest::SHA" => 0,
"File::Spec" => 0,
"IO::Handle" => 0,
+ "IO::Socket::Timeout" => "0.22",
"IO::String" => 0,
"IPC::Cmd" => 0,
"IPC::Open3" => 0,
- "Module::Build" => "0.3601",
+ "Pod::Coverage::TrustPod" => 0,
+ "Test::CPAN::Meta" => 0,
"Test::Deep" => 0,
"Test::Fatal" => 0,
"Test::More" => "0.98",
"Test::SharedFork" => 0,
+ "Test::TCP" => "1.19",
"Try::Tiny" => 0
);
@@ -1,7 +1,7 @@
This archive contains the distribution Redis,
-version 1.965:
+version 1.974:
Perl binding for Redis database
@@ -6,9 +6,11 @@ copyright_holder = Pedro Melo, Damien Krotkine
copyright_year = 2013
; -- version from git
-[Git::NextVersion]
+version = 1.974
+;[Git::NextVersion]
first_version = 1.962
+[MetaJSON]
[MetaResources]
homepage = https://github.com/PerlRedis/perl-redis
bugtracker.web = https://github.com/PerlRedis/perl-redis/issues
@@ -17,6 +19,10 @@ repository.url = https://github.com/PerlRedis/perl-redis.git
repository.type = git
[GatherDir]
+exclude_match = redis-server-*
+exclude_match = t/redis-server-*
+exclude_match = sentinel-*
+exclude_match = t/sentinel-*
[PruneCruft]
[ManifestSkip]
[MetaYAML]
@@ -25,15 +31,15 @@ repository.type = git
[ExtraTests]
[ExecDir]
[ShareDir]
-[MakeMaker]
-eumm_version = 6.63_03
[Manifest]
[TestRelease]
[ConfirmRelease]
[UploadToCPAN]
-[ModuleBuild]
+[ModuleBuildTiny]
+[MakeMaker::Fallback]
+eumm_version = 6.63_03
[PkgVersion]
[PodWeaver]
[Prepender]
@@ -44,14 +50,18 @@ copyright = 1
[PodCoverageTests]
[Prereqs]
Try::Tiny = 0
+IO::Socket::Timeout = 0.22
[Prereqs / TestRequires]
Test::SharedFork = 0
-Digest::SHA = 0,
-IO::String = 0,
-IPC::Cmd = 0,
-Test::Deep = 0,
-Test::Fatal = 0,
-Test::More = 0.98,
+Digest::SHA = 0
+IO::String = 0
+IPC::Cmd = 0
+Test::Deep = 0
+Test::Fatal = 0
+Test::More = 0.98
+Test::TCP = 1.19
+Test::CPAN::Meta = 0
+Pod::Coverage::TrustPod = 0
; -- release
[NextRelease]
@@ -9,7 +9,7 @@
#
package Redis::Hash;
{
- $Redis::Hash::VERSION = '1.965';
+ $Redis::Hash::VERSION = '1.974';
}
# ABSTRACT: tie Perl hashes to Redis hashes
@@ -89,7 +89,7 @@ Redis::Hash - tie Perl hashes to Redis hashes
=head1 VERSION
-version 1.965
+version 1.974
=head1 DESCRIPTION
@@ -9,7 +9,7 @@
#
package Redis::List;
{
- $Redis::List::VERSION = '1.965';
+ $Redis::List::VERSION = '1.974';
}
# ABSTRACT: tie Perl arrays to Redis lists
@@ -109,7 +109,7 @@ Redis::List - tie Perl arrays to Redis lists
=head1 VERSION
-version 1.965
+version 1.974
=head1 SYNOPSYS
@@ -0,0 +1,118 @@
+#
+# This file is part of Redis
+#
+# This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine.
+#
+# This is free software, licensed under:
+#
+# The Artistic License 2.0 (GPL Compatible)
+#
+package Redis::Sentinel;
+{
+ $Redis::Sentinel::VERSION = '1.974';
+}
+
+# ABSTRACT: Redis Sentinel interface
+
+use warnings;
+use strict;
+
+use Carp;
+
+use base qw(Redis);
+
+sub new {
+ my ($class, %args) = @_;
+ # these args are not allowed when contacting a sentinel
+ delete @args{qw(sentinels service)};
+
+ $class->SUPER::new(%args);
+}
+
+sub get_service_address {
+ my ($self, $service) = @_;
+ my ($ip, $port) = $self->sentinel('get-master-addr-by-name', $service);
+ defined $ip
+ or return;
+ $ip eq 'IDONTKNOW'
+ and return $ip;
+ return "$ip:$port";
+}
+
+sub get_masters {
+ map { +{ @$_ }; } @{ shift->sentinel('masters') || [] };
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Redis::Sentinel - Redis Sentinel interface
+
+=head1 VERSION
+
+version 1.974
+
+=head1 SYNOPSIS
+
+ my $sentinel = Redis::Sentinel->new( ... );
+ my $service_address = $sentinel->get_service_address('mymaster');
+ my @masters = $sentinel->get_masters;
+
+=head1 DESCRIPTION
+
+This is a subclass of the Redis module, specialized into connecting to a
+Sentinel instance. Inherits from the C<Redis> package;
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+See C<new> in L<Redis.pm>. All parameters are supported, except C<sentinels>
+and C<service>, which are silently ignored.
+
+=head1 METHODS
+
+All the methods of the C<Redis> package are supported, plus the aditional following methods:
+
+=head2 get_service_address
+
+Takes the name of a service as parameter, and returns either void (emptly list)
+if the master couldn't be found, the string 'IDONTKNOW' if the service is in
+the sentinel config but cannot be reached, or the string C<"$ip:$port"> if the
+service were found.
+
+=head2 get_masters
+
+Returns a list of HashRefs representing all the master redis instances that
+this sentinel monitors.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Pedro Melo <melo@cpan.org>
+
+=item *
+
+Damien Krotkine <dams@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine.
+
+This is free software, licensed under:
+
+ The Artistic License 2.0 (GPL Compatible)
+
+=cut
@@ -9,7 +9,7 @@
#
package Redis;
{
- $Redis::VERSION = '1.965';
+ $Redis::VERSION = '1.974';
}
# ABSTRACT: Perl binding for Redis database
@@ -21,30 +21,47 @@ use strict;
use IO::Socket::INET;
use IO::Socket::UNIX;
+use IO::Socket::Timeout;
use IO::Select;
use IO::Handle;
use Fcntl qw( O_NONBLOCK F_SETFL );
use Errno ();
use Data::Dumper;
-use Carp qw/confess/;
+use Carp;
use Encode;
use Try::Tiny;
use Scalar::Util ();
+use Redis::Sentinel;
+
use constant WIN32 => $^O =~ /mswin32/i;
use constant EWOULDBLOCK => eval {Errno::EWOULDBLOCK} || -1E9;
use constant EAGAIN => eval {Errno::EAGAIN} || -1E9;
use constant EINTR => eval {Errno::EINTR} || -1E9;
-
+use constant BUFSIZE => 4096;
+
+sub _maybe_enable_timeouts {
+ my ($self, $socket) = @_;
+ $socket or return;
+ exists $self->{read_timeout} || exists $self->{write_timeout}
+ or return $socket;
+ IO::Socket::Timeout->enable_timeouts_on($socket);
+ defined $self->{read_timeout}
+ and $socket->read_timeout($self->{read_timeout});
+ defined $self->{write_timeout}
+ and $socket->write_timeout($self->{write_timeout});
+ $socket;
+}
sub new {
my ($class, %args) = @_;
- my $self = bless {}, $class;
+ my $self = bless {}, $class;
+ $self->{__buf} = '';
$self->{debug} = $args{debug} || $ENV{REDIS_DEBUG};
## Deal with REDIS_SERVER ENV
- if ($ENV{REDIS_SERVER} && !$args{sock} && !$args{server}) {
+ if ($ENV{REDIS_SERVER} && ! exists $args{sock} && ! exists $args{server} && ! exists $args{sentinel}) {
if ($ENV{REDIS_SERVER} =~ m!^/!) {
$args{sock} = $ENV{REDIS_SERVER};
}
@@ -56,35 +73,107 @@ sub new {
}
}
- $args{password}
- and $self->{password} = $args{password};
+ defined $args{$_}
+ and $self->{$_} = $args{$_} for
+ qw(password on_connect name no_auto_connect_on_new cnx_timeout
+ write_timeout read_timeout sentinels_cnx_timeout sentinels_write_timeout
+ sentinels_read_timeout no_sentinels_list_update);
- $args{on_connect}
- and $self->{on_connect} = $args{on_connect};
-
- defined $args{name}
- and $self->{name} = $args{name};
+ $self->{reconnect} = $args{reconnect} || 0;
+ $self->{every} = $args{every} || 1000;
- if ($args{sock}) {
+ if (exists $args{sock}) {
$self->{server} = $args{sock};
- $self->{builder} = sub { IO::Socket::UNIX->new($_[0]->{server}) };
- }
- else {
- $self->{server} = $args{server} || '127.0.0.1:6379';
$self->{builder} = sub {
- IO::Socket::INET->new(
- PeerAddr => $_[0]->{server},
- Proto => 'tcp',
- );
+ my ($self) = @_;
+ $self->_maybe_enable_timeouts(
+ IO::Socket::UNIX->new(
+ Peer => $self->{server},
+ ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ): () ),
+ )
+ );
+ };
+ } elsif ($args{sentinels}) {
+ $self->{sentinels} = $args{sentinels};
+
+ ref $self->{sentinels} eq 'ARRAY'
+ or croak("'sentinels' param must be an ArrayRef");
+
+ defined($self->{service} = $args{service})
+ or croak("Need 'service' name when using 'sentinels'!");
+
+ $self->{builder} = sub {
+ my ($self) = @_;
+ # try to connect to a sentinel
+ my $status;
+ foreach my $sentinel_address (@{$self->{sentinels}}) {
+ my $sentinel = eval {
+ Redis::Sentinel->new(
+ server => $sentinel_address,
+ cnx_timeout => ( exists $self->{sentinels_cnx_timeout}
+ ? $self->{sentinels_cnx_timeout} : 0.1),
+ read_timeout => ( exists $self->{sentinels_read_timeout}
+ ? $self->{sentinels_read_timeout} : 1 ),
+ write_timeout => ( exists $self->{sentinels_write_timeout}
+ ? $self->{sentinels_write_timeout} : 1 ),
+ )
+ } or next;
+ my $server_address = $sentinel->get_service_address($self->{service});
+ defined $server_address
+ or $status ||= "Sentinels don't know this service",
+ next;
+ $server_address eq 'IDONTKNOW'
+ and $status = "service is configured in one Sentinel, but was never reached",
+ next;
+
+ # we found the service, set the server
+ $self->{server} = $server_address;
+
+ if (! $self->{no_sentinels_list_update} ) {
+ # move the elected sentinel at the front of the list and add
+ # additional sentinels
+ my $idx = 2;
+ my %h = ( ( map { $_ => $idx++ } @{$self->{sentinels}}),
+ $sentinel_address => 1,
+ );
+ $self->{sentinels} = [
+ ( sort { $h{$a} <=> $h{$b} } keys %h ), # sorted existing sentinels,
+ grep { ! $h{$_}; } # list of unknown
+ map { +{ @$_ }->{name}; } # names of
+ $sentinel->sentinel( # sentinels
+ sentinels => $self->{service} # for this service
+ )
+ ];
+ }
+
+ return $self->_maybe_enable_timeouts(
+ IO::Socket::INET->new(
+ PeerAddr => $server_address,
+ Proto => 'tcp',
+ ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ),
+ )
+ );
+ }
+ croak($status || "failed to connect to any of the sentinels");
+ };
+ } else {
+ $self->{server} = exists $args{server} ? $args{server} : '127.0.0.1:6379';
+ $self->{builder} = sub {
+ my ($self) = @_;
+ $self->_maybe_enable_timeouts(
+ IO::Socket::INET->new(
+ PeerAddr => $self->{server},
+ Proto => 'tcp',
+ ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ),
+ )
+ );
};
}
$self->{is_subscriber} = 0;
$self->{subscribers} = {};
- $self->{reconnect} = $args{reconnect} || 0;
- $self->{every} = $args{every} || 1000;
- $self->__connect;
+ $self->connect unless $args{no_auto_connect_on_new};
return $self;
}
@@ -130,7 +219,19 @@ sub __std_cmd {
# If this is an EXEC command, in pipelined mode, and one of the commands
# executed in the transaction yields an error, we must collect all errors
# from that command, rather than throwing an exception immediately.
- my $collect_errors = $cb && uc($command) eq 'EXEC';
+ my $uc_command = uc($command);
+ my $collect_errors = $cb && $uc_command eq 'EXEC';
+
+ if ($uc_command eq 'MULTI') {
+ $self->{__inside_transaction} = 1;
+ } elsif ($uc_command eq 'EXEC' || $uc_command eq 'DISCARD') {
+ delete $self->{__inside_transaction};
+ delete $self->{__inside_watch};
+ } elsif ($uc_command eq 'WATCH') {
+ $self->{__inside_watch} = 1;
+ } elsif ($uc_command eq 'UNWATCH') {
+ delete $self->{__inside_watch};
+ }
## Fast path, no reconnect;
$self->{reconnect}
@@ -157,7 +258,10 @@ sub __with_reconnect {
ref($_) eq 'Redis::X::Reconnect'
or die $_;
- $self->__connect;
+ $self->{__inside_transaction} || $self->{__inside_watch}
+ and croak("reconnect disabled inside transaction or watch");
+
+ $self->connect;
$cb->();
}
);
@@ -174,7 +278,7 @@ sub __run_cmd {
}
: $cb || sub {
my ($reply, $error) = @_;
- confess "[$command] $error, " if defined $error;
+ croak "[$command] $error, " if defined $error;
$ret = $reply;
};
@@ -217,7 +321,7 @@ sub quit {
my ($self) = @_;
return unless $self->{sock};
- confess "[quit] only works in synchronous mode, "
+ croak "[quit] only works in synchronous mode, "
if @_ && ref $_[-1] eq 'CODE';
try {
@@ -225,7 +329,7 @@ sub quit {
$self->__send_command('QUIT');
};
- close(delete $self->{sock}) if $self->{sock};
+ $self->__close_sock() if $self->{sock};
return 1;
}
@@ -234,14 +338,14 @@ sub shutdown {
my ($self) = @_;
$self->__is_valid_command('SHUTDOWN');
- confess "[shutdown] only works in synchronous mode, "
+ croak "[shutdown] only works in synchronous mode, "
if @_ && ref $_[-1] eq 'CODE';
return unless $self->{sock};
$self->wait_all_responses;
$self->__send_command('SHUTDOWN');
- close(delete $self->{sock}) || confess("Can't close socket: $!");
+ $self->__close_sock() || croak("Can't close socket: $!");
return 1;
}
@@ -250,7 +354,7 @@ sub ping {
my $self = shift;
$self->__is_valid_command('PING');
- confess "[ping] only works in synchronous mode, "
+ croak "[ping] only works in synchronous mode, "
if @_ && ref $_[-1] eq 'CODE';
return unless exists $self->{sock};
@@ -260,7 +364,7 @@ sub ping {
$self->__std_cmd('PING');
}
catch {
- close(delete $self->{sock});
+ $self->__close_sock();
return;
};
}
@@ -337,22 +441,21 @@ sub wait_for_messages {
$s->add($sock);
while ($s->can_read($timeout)) {
- my $has_stuff = __try_read_sock($sock);
+ my $has_stuff = $self->__try_read_sock($sock);
# If the socket is ready to read but there is nothing to read, ( so
# it's an EOF ), try to reconnect.
defined $has_stuff
or $self->__throw_reconnect('EOF from server');
- while (1) {
- my $has_stuff = __try_read_sock($sock);
- $has_stuff
- or last ; ## no data ( or socket became EOF), back to select until
- ## timeout
-
+
+ do {
my ($reply, $error) = $self->__read_response('WAIT_FOR_MESSAGES');
- confess "[WAIT_FOR_MESSAGES] $error, " if defined $error;
+ croak "[WAIT_FOR_MESSAGES] $error, " if defined $error;
$self->__process_pubsub_msg($reply);
$count++;
- }
+
+ # if __try_read_sock() return 0 (no data)
+ # or undef ( socket became EOF), back to select until timeout
+ } while ($self->{__buf} || $self->__try_read_sock($sock));
}
});
@@ -375,7 +478,7 @@ sub __subscription_cmd {
my $command = shift;
my $cb = pop;
- confess("Missing required callback in call to $command(), ")
+ croak("Missing required callback in call to $command(), ")
unless ref($cb) eq 'CODE';
$self->wait_all_responses;
@@ -426,7 +529,7 @@ sub __process_subscription_changes {
while (%$expected) {
my ($m, $error) = $self->__read_response($cmd);
- confess "[$cmd] $error, " if defined $error;
+ croak "[$cmd] $error, " if defined $error;
## Deal with pending PUBLISH'ed messages
if ($m->[0] =~ /^p?message$/) {
@@ -469,15 +572,17 @@ sub __process_pubsub_msg {
sub __is_valid_command {
my ($self, $cmd) = @_;
- confess("Cannot use command '$cmd' while in SUBSCRIBE mode, ")
+ croak("Cannot use command '$cmd' while in SUBSCRIBE mode, ")
if $self->{is_subscriber};
}
### Socket operations
-sub __connect {
+sub connect {
my ($self) = @_;
delete $self->{sock};
+ delete $self->{__inside_watch};
+ delete $self->{__inside_transaction};
# Suppose we have at least one command response pending, but we're about
# to reconnect. The new connection will never get a response to any of
@@ -508,13 +613,15 @@ sub __build_sock {
my ($self) = @_;
$self->{sock} = $self->{builder}->($self)
- || confess("Could not connect to Redis server at $self->{server}: $!");
+ || croak("Could not connect to Redis server at $self->{server}: $!");
+
+ $self->{__buf} = '';
if (exists $self->{password}) {
try { $self->auth($self->{password}) }
catch {
$self->{reconnect} = 0;
- confess("Redis server refused password");
+ croak("Redis server refused password");
};
}
@@ -523,6 +630,14 @@ sub __build_sock {
return;
}
+sub __close_sock {
+ my ($self) = @_;
+ $self->{__buf} = '';
+ delete $self->{__inside_watch};
+ delete $self->{__inside_transaction};
+ return close(delete $self->{sock});
+}
+
sub __on_connection {
my ($self) = @_;
@@ -541,20 +656,19 @@ sub __on_connection {
and $self->select($self->{current_database});
}
- # TODO: don't use each
- while (my ($topic, $cbs) = each %{$self->{subscribers}}) {
+ foreach my $topic (CORE::keys(%{$self->{subscribers}})) {
if ($topic =~ /(p?message):(.*)$/ ) {
my ($key, $channel) = ($1, $2);
if ($key eq 'message') {
$self->__send_command('subscribe', $channel);
my (undef, $error) = $self->__read_response('subscribe');
defined $error
- and confess "[subscribe] $error";
+ and croak "[subscribe] $error";
} else {
$self->__send_command('psubscribe', $channel);
my (undef, $error) = $self->__read_response('psubscribe');
defined $error
- and confess "[psubscribe] $error";
+ and croak "[psubscribe] $error";
}
}
}
@@ -571,7 +685,7 @@ sub __send_command {
my $deb = $self->{debug};
if ($self->{pid} != $$) {
- $self->__connect;
+ $self->connect;
}
my $sock = $self->{sock}
@@ -590,7 +704,7 @@ sub __send_command {
}
## Check to see if socket was closed: reconnect on EOF
- my $status = __try_read_sock($sock);
+ my $status = $self->__try_read_sock($sock);
$self->__throw_reconnect('Not connected to any server')
unless defined $status;
@@ -609,7 +723,7 @@ sub __send_command {
sub __read_response {
my ($self, $cmd, $collect_errors) = @_;
- confess("Not connected to any server") unless $self->{sock};
+ croak("Not connected to any server") unless $self->{sock};
local $/ = "\r\n";
@@ -617,7 +731,7 @@ sub __read_response {
return $self->__read_response_r($cmd, $collect_errors) unless $self->{debug};
my ($result, $error) = $self->__read_response_r($cmd, $collect_errors);
- warn "[RECV] $cmd ", Dumper($result, $error) if $self->{debug};
+ warn "[RECV] $cmd ", Dumper($result, $error);
return $result, $error;
}
@@ -646,14 +760,14 @@ sub __read_response_r {
push @list, \@nested;
}
else {
- confess "[$command] $nested[1], " if defined $nested[1];
+ croak "[$command] $nested[1], " if defined $nested[1];
push @list, $nested[0];
}
}
return \@list, undef;
}
else {
- confess "unknown answer type: $type ($result), ";
+ croak "unknown answer type: $type ($result), ";
}
}
@@ -661,8 +775,8 @@ sub __read_line {
my $self = $_[0];
my $sock = $self->{sock};
- my $data = <$sock>;
- confess("Error while reading from Redis server: $!")
+ my $data = $self->__read_line_raw;
+ croak("Error while reading from Redis server: $!")
unless defined $data;
chomp $data;
@@ -672,116 +786,99 @@ sub __read_line {
return ($type, $data);
}
-sub __read_len {
- my ($self, $len) = @_;
+sub __read_line_raw {
+ my $self = $_[0];
+ my $sock = $self->{sock};
+ my $buf = \$self->{__buf};
- my $data = '';
- my $offset = 0;
- while ($len) {
- my $bytes = read $self->{sock}, $data, $len, $offset;
- confess("Error while reading from Redis server: $!")
- unless defined $bytes;
- confess("Redis server closed connection") unless $bytes;
+ if (length $$buf) {
+ my $idx = index($$buf, "\r\n");
+ $idx >= 0 and return substr($$buf, 0, $idx + 2, '');
+ }
- $offset += $bytes;
- $len -= $bytes;
+ while (1) {
+ my $bytes = sysread($sock, $$buf, BUFSIZE, length($$buf));
+ next if !defined $bytes && $! == EINTR;
+ return unless defined $bytes && $bytes;
+
+ # start looking for \r\n where we stopped last time
+ # extracting one is required to handle corner case
+ # where \r\n are split and therefore read by two conseqent sysreads
+ my $idx = index($$buf, "\r\n", length($$buf) - $bytes - 1);
+ $idx >= 0 and return substr($$buf, 0, $idx + 2, '');
}
+}
+sub __read_len {
+ my ($self, $len) = @_;
+ my $buf = \$self->{__buf};
+ my $buflen = length($$buf);
+
+ if ($buflen < $len) {
+ my $to_read = $len - $buflen;
+ while ($to_read > 0) {
+ my $bytes = sysread($self->{sock}, $$buf, BUFSIZE, length($$buf));
+ next if !defined $bytes && $! == EINTR;
+ croak("Error while reading from Redis server: $!") unless defined $bytes;
+ croak("Redis server closed connection") unless $bytes;
+ $to_read -= $bytes;
+ }
+ }
+
+ my $data = substr($$buf, 0, $len, '');
chomp $data;
warn "[RECV RAW] '$data'" if $self->{debug};
return $data;
}
-
-#
-# The reason for this code:
-#
-# IO::Select and buffered reads like <$sock> and read() don't mix
-# For example, if I receive two MESSAGE messages (from Redis PubSub),
-# the first read for the first message will probably empty to socket
-# buffer and move the data to the perl IO buffer.
-#
-# This means that IO::Select->can_read will return false (after all
-# the socket buffer is empty) but from the application point of view
-# there is still data to be read and process
-#
-# Hence this code. We try to do a non-blocking read() of 1 byte, and if
-# we succeed, we put it back and signal "yes, Virginia, there is still
-# stuff out there"
-#
-# We could just use sysread and leave the socket buffer with the second
-# message, and then use IO::Select as intended, and previous versions of
-# this code did that (check the git history for this file), but
-# performance suffers, about 20/30% slower, mostly because we do a lot
-# of "read one line", where <$sock> beats the crap of anything you can
-# write on Perl-land.
-#
sub __try_read_sock {
- my $sock = shift;
+ my ($self, $sock) = @_;
my $data = '';
- __fh_nonblocking($sock, 1);
-
- ## Lots of problems with Windows here. This is a temporary fix until I
- ## figure out what is happening there. It looks like the wrong fix
- ## because we should not mix sysread (unbuffered I/O) with ungetc()
- ## below (buffered I/O), so I do expect to revert this soon.
- ## Call it a run through the CPAN Testers Gautlet fix. If I had to
- ## guess (and until my Windows box has a new power supply I do have to
- ## guess), I would say that the problems lies with the call
- ## __fh_nonblocking(), where on Windows we don't end up with a non-
- ## blocking socket.
- ## See
- ## * https://github.com/melo/perl-redis/issues/20
- ## * https://github.com/melo/perl-redis/pull/21
- my $len;
- if (WIN32) {
- $len = sysread($sock, $data, 1);
- }
- else {
- $len = read($sock, $data, 1);
- }
- my $err = 0 + $!;
- __fh_nonblocking($sock, 0);
-
- if (defined($len)) {
- ## Have stuff
- if ($len > 0) {
- $sock->ungetc(ord($data));
- return 1;
- }
- ## EOF according to the docs
- elsif ($len == 0) {
- return;
- }
- else {
- confess("read()/sysread() are really bonkers on $^O, return negative values ($len)");
- }
- }
+ while (1) {
+ # WIN32 doesn't support MSG_DONTWAIT,
+ # need to swith fh to nonblockng mode manually.
+ # For Unix still use MSG_DONTWAIT because of fewer syscalls
+ my ($res, $err);
+ if (WIN32) {
+ __fh_nonblocking_win32($sock, 1);
+ $res = recv($sock, $data, BUFSIZE, 0);
+ $err = 0 + $!;
+ __fh_nonblocking_win32($sock, 0);
+ } else {
+ $res = recv($sock, $data, BUFSIZE, MSG_DONTWAIT);
+ $err = 0 + $!;
+ }
+
+ if (defined $res) {
+ ## have read some data
+ if (length($data)) {
+ $self->{__buf} .= $data;
+ return 1;
+ }
- ## Keep going if nothing there, but socket is alive
- return 0 if $err and ($err == EWOULDBLOCK or $err == EAGAIN or $err == EINTR);
+ ## no data but also no error means EOF
+ return;
+ }
- ## No errno, but result is undef?? This happens sometimes on my tests
- ## when the server timesout the client. I traced the system calls and
- ## I see the read() system call return 0 for EOF, but on this side of
- ## perl, we get undef... We should see the 0 return code for EOF, I
- ## suspect the fact that we are in non-blocking mode is the culprit
- return if $err == 0;
+ next if $err && $err == EINTR;
- ## For everything else, there is Mastercard...
- confess("Unexpected error condition $err/$^O, please report this as a bug");
-}
+ ## Keep going if nothing there, but socket is alive
+ return 0 if $err and ($err == EWOULDBLOCK or $err == EAGAIN);
+ ## result is undef but err is 0? should never happen
+ return if $err == 0;
-### Copied from AnyEvent::Util
-BEGIN {
- *__fh_nonblocking = (WIN32)
- ? sub($$) { ioctl $_[0], 0x8004667e, pack "L", $_[1]; } # FIONBIO
- : sub($$) { fcntl $_[0], F_SETFL, $_[1] ? O_NONBLOCK : 0; };
+ ## For everything else, there is Mastercard...
+ croak("Unexpected error condition $err/$^O, please report this as a bug");
+ }
}
+## Copied from AnyEvent::Util
+sub __fh_nonblocking_win32 {
+ ioctl $_[0], 0x8004667e, pack "L", $_[1];
+}
##########################
# I take exception to that
@@ -807,7 +904,7 @@ Redis - Perl binding for Redis database
=head1 VERSION
-version 1.965
+version 1.974
=head1 SYNOPSIS
@@ -833,10 +930,29 @@ version 1.965
## Enable auto-reconnect
## Try to reconnect every 1s up to 60 seconds until success
## Die if you can't after that
- my $redis = Redis->new(reconnect => 60);
+ my $redis = Redis->new(reconnect => 60, every => 1000);
+
+ ## Try each 100ms upto 2 seconds (every is in nanosecond)
+ my $redis = Redis->new(reconnect => 2, every => 100_000);
+
+ ## Enable connection timeout (in seconds)
+ my $redis = Redis->new(cnx_timeout => 60);
- ## Try each 100ms upto 2 seconds (every is in milisecs)
- my $redis = Redis->new(reconnect => 2, every => 100);
+ ## Enable read timeout (in seconds)
+ my $redis = Redis->new(read_timeout => 0.5);
+
+ ## Enable write timeout (in seconds)
+ my $redis = Redis->new(write_timeout => 1.2);
+
+ ## Connect via a list of Sentinels to a given service
+ my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster');
+
+ ## Same, but with connection, read and write timeout on the sentinel hosts
+ my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster',
+ sentinels_cnx_timeout => 0.1,
+ sentinels_read_timeout => 1,
+ sentinels_write_timeout => 1,
+ );
## Use all the regular Redis commands, they all accept a list of
## arguments
@@ -913,7 +1029,7 @@ method call:
Pending responses to pipelined commands are processed in a single batch, as
soon as at least one of the following conditions holds:
-=over 4
+=over
=item *
@@ -971,6 +1087,19 @@ So, do you pre-encoding or post-decoding operation yourself if needed !
my $r = Redis->new( name => 'my_connection_name' );
my $r = Redis->new( name => sub { "cache-for-$$" });
+ my $redis = Redis->new(sentinels => [ '127.0.0.1:12345', '127.0.0.1:23456' ],
+ service => 'mymaster');
+
+ ## Connect via a list of Sentinels to a given service
+ my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster');
+
+ ## Same, but with connection, read and write timeout on the sentinel hosts
+ my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster',
+ sentinels_cnx_timeout => 0.1,
+ sentinels_read_timeout => 1,
+ sentinels_write_timeout => 1,
+ );
+
The C<< server >> parameter specifies the Redis server we should connect to,
via TCP. Use the 'IP:PORT' format. If no C<< server >> option is present, we
will attempt to use the C<< REDIS_SERVER >> environment variable. If neither of
@@ -979,10 +1108,15 @@ those options are present, it defaults to '127.0.0.1:6379'.
Alternatively you can use the C<< sock >> parameter to specify the path of the
UNIX domain socket where the Redis server is listening.
+Alternatively you can use the C<< sentinels >> parameter and the C<< service >>
+parameter to specify a list of sentinels to contact and try to get the address
+of the given service name. C<< sentinels >> must be an ArrayRef and C<< service
+>> an Str.
+
The C<< REDIS_SERVER >> can be used for UNIX domain sockets too. The following
formats are supported:
-=over 4
+=over
=item *
@@ -1002,18 +1136,9 @@ tcp:127.0.0.1:11011
=back
-The C<< encoding >> parameter specifies the encoding we will use to decode all
-the data we receive and encode all the data sent to the redis server. Due to
-backwards-compatibility we default to C<< utf8 >>. To disable all this
-encoding/decoding, you must use C<< encoding => undef >>. B<< This is the
-recommended option >>.
-
-B<< Warning >>: this option has several problems and it is B<deprecated>. A
-future version might add other filtering options though.
-
The C<< reconnect >> option enables auto-reconnection mode. If we cannot
connect to the Redis server, or if a network write fails, we enter retry mode.
-We will try a new connection every C<< every >> milliseconds (1000ms by
+We will try a new connection every C<< every >> nanoseconds (1 ms by
default), up-to C<< reconnect >> seconds.
Be aware that read errors will always thrown an exception, and will not trigger
@@ -1022,6 +1147,33 @@ a retry until the new command is sent.
If we cannot re-establish a connection after C<< reconnect >> seconds, an
exception will be thrown.
+The C<< cnx_timeout >> option enables connection timeout. The Redis client will
+wait at most that number of seconds (can be fractional) before giving up
+connecting to a server.
+
+The C<< sentinels_cnx_timeout >> option enables sentinel connection timeout.
+When using the sentinels feature, Redis client will wait at most that number of
+seconds (can be fractional) before giving up connecting to a sentinel.
+B<Default>: 0.1
+
+The C<< read_timeout >> option enables read timeout. The Redis client will wait
+at most that number of seconds (can be fractional) before giving up when
+reading from the server.
+
+The C<< sentinels_read_timeout >> option enables sentinel read timeout. When
+using the sentinels feature, the Redis client will wait at most that number of
+seconds (can be fractional) before giving up when reading from a sentinel
+server. B<Default>: 1
+
+The C<< write_timeout >> option enables write timeout. The Redis client will wait
+at most that number of seconds (can be fractional) before giving up when
+reading from the server.
+
+The C<< sentinels_write_timeout >> option enables sentinel write timeout. When
+using the sentinels feature, the Redis client will wait at most that number of
+seconds (can be fractional) before giving up when reading from a sentinel
+server. B<Default>: 1
+
If your Redis server requires authentication, you can use the C<< password >>
attribute. After each established connection (at the start or when
reconnecting), the Redis C<< AUTH >> command will be send to the server. If the
@@ -1032,6 +1184,19 @@ successful connection. The C<< on_connect >> attribute is used to provide the
code reference, and it will be called with the first parameter being the Redis
object.
+You can also provide C<< no_auto_connect_on_new >> in which case C<<
+new >> won't call C<< $obj->connect >> for you implicitly, you'll have
+to do that yourself. This is useful for figuring out how long
+connection setup takes so you can configure the C<< cnx_timeout >>
+appropriately.
+
+You can also provide C<< no_sentinels_list_update >>. By default (that is,
+without this option), when successfully contacting a sentinel server, the Redis
+client will ask it for the list of sentinels known for the given service, and
+merge it with its list of sentinels (in the C<< sentinels >> attribute). You
+can disable this behavior by setting C<< no_sentinels_list_update >> to a true
+value.
+
You can also set a name for each connection. This can be very useful for
debugging purposes, using the C<< CLIENT LIST >> command. To set a connection
name, use the C<< name >> parameter. You can use both a scalar value or a
@@ -1052,6 +1217,14 @@ environment variable.
=head2 Connection Handling
+=head3 connect
+
+ $r->connect();
+
+Connects to the Redis server. This is done by default when the obect is
+constructed using C<new()>, unless C<no_auto_connect_on_new> has been set. See
+this option in the C<new()> constructor.
+
=head3 quit
$r->quit;
@@ -1306,6 +1479,7 @@ of this module t/01-basic.t
=head3 hset
Sets the value to a key in a hash.
+
$r->hset('hashname', $key => $value); ## returns true on success
=head3 hget
@@ -1326,6 +1500,7 @@ Gets the value to a key in a hash.
=head3 hdel
Deletes a key from a hash
+
if($r->hdel('hashname', $key)) {
## key is deleted
}
@@ -1408,7 +1583,7 @@ objects, one dedicated to PubSub and the other for regular commands.
All Pub/Sub commands receive a callback as the last parameter. This callback
receives three arguments:
-=over 4
+=over
=item *
@@ -1426,7 +1601,7 @@ tells you the pattern that matched.
=back
-See the L<Pub/Sub notes|http://redis.io/topics/pubsub> for more information
+See the L<Pub-Sub notes|http://redis.io/topics/pubsub> for more information
about the messages you will receive on your callbacks after each L</subscribe>,
L</unsubscribe>, L</psubscribe> and L</punsubscribe>.
@@ -1440,7 +1615,7 @@ Publishes the C<< $message >> to the C<< $topic >>.
$r->subscribe(
@topics_to_subscribe_to,
- sub {
+ my $savecallback = sub {
my ($message, $topic, $subscribed_topic) = @_;
...
},
@@ -1451,14 +1626,17 @@ received by Redis, and the specified callback will be executed.
=head3 unsubscribe
- $r->unsubscribe(@topic_list, sub { my ($m, $t, $s) = @_; ... });
+ $r->unsubscribe(@topic_list, $savecallback);
-Stops receiving messages for all the topics in C<@topic_list>.
+Stops receiving messages via C<$savecallback> for all the topics in
+C<@topic_list>. B<WARNING:> it is important that you give the same calleback
+that you used for subscribtion. The value of the CodeRef must be the same, as
+this is how internally the code identifies it.
=head3 psubscribe
my @topic_matches = ('prefix1.*', 'prefix2.*');
- $r->psubscribe(@topic_matches, sub { my ($m, $t, $s) = @_; ... });
+ $r->psubscribe(@topic_matches, my $savecallback = sub { my ($m, $t, $s) = @_; ... });
Subscribes a pattern of topics. All messages to topics that match the pattern
will be delivered to the callback.
@@ -1466,9 +1644,12 @@ will be delivered to the callback.
=head3 punsubscribe
my @topic_matches = ('prefix1.*', 'prefix2.*');
- $r->punsubscribe(@topic_matches, sub { my ($m, $t, $s) = @_; ... });
+ $r->punsubscribe(@topic_matches, $savecallback);
-Stops receiving messages for all the topics pattern matches in C<@topic_list>.
+Stops receiving messages via C<$savecallback> for all the topics pattern
+matches in C<@topic_list>. B<WARNING:> it is important that you give the same
+calleback that you used for subscribtion. The value of the CodeRef must be the
+same, as this is how internally the code identifies it.
=head3 is_subscriber
@@ -1598,9 +1779,9 @@ The C<slowlog> command gives access to the server's slow log.
=head1 ACKNOWLEDGEMENTS
-The following persons contributed to this project (alphabetical order):
+The following persons contributed to this project (random order):
-=over 4
+=over
=item *
@@ -1630,6 +1811,14 @@ Thiago Berlitz Rondon
Ulrich Habel
+=item *
+
+Ivan Kruglov
+
+=item *
+
+Steffen Mueller <smueller@cpan.org>
+
=back
=head1 AUTHORS
@@ -3,14 +3,15 @@ use warnings;
# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.037
-use Test::More tests => 3 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
+use Test::More tests => 4 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
my @module_files = (
'Redis.pm',
'Redis/Hash.pm',
- 'Redis/List.pm'
+ 'Redis/List.pm',
+ 'Redis/Sentinel.pm'
);
@@ -20,6 +20,14 @@ use Test::SpawnRedisServer;
my ($c, $srv) = redis();
END { $c->() if $c }
+my $n;
+is(
+ exception { $n = Redis->new(server => $srv, name => 'no_auto_connect', no_auto_connect_on_new => 1) },
+ undef, 'Got an unconnected object',
+);
+ok(!$n->ping, "ping doesn't work yet");
+$n->connect;
+ok($n->ping, "ping works after connection");
my $o;
is(
@@ -108,7 +116,7 @@ ok(my $nr_keys = $o->dbsize, 'dbsize');
like(
exception { $o->lpush('foo', 'bar') },
- qr/\[lpush\] ERR Operation against a key holding the wrong kind of value,/,
+ qr/\[lpush\] (?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value,/,
'Error responses throw exception'
);
@@ -219,11 +227,15 @@ is($o->zscore($zset, 'foo'), 2);
ok($o->zincrby($zset, 1, 'bar'));
is($o->zscore($zset, 'bar'), 1); # bar was new, so its score got set to the increment
+SKIP: {
+eval { $o->zrank($zset, 'bar') };
+skip "zrank not implemented in this redis", 4 if $@ && $@ =~ /unknown command/;
is($o->zrank($zset, 'bar'), 0);
is($o->zrank($zset, 'foo'), 1);
is($o->zrevrank($zset, 'bar'), 1);
is($o->zrevrank($zset, 'foo'), 0);
+}
ok($o->zadd($zset, 2.1, 'baz')); # we now have bar foo baz
@@ -243,7 +255,11 @@ is_deeply($rounded_withscores, { baz => 2.1, foo => 2 });
is_deeply([$o->zrangebyscore($zset, 2, 3)], [qw/foo baz/]);
+SKIP: {
+eval { $o->zcount($zset, 2, 3) };
+skip "zcount not implemented in this redis", 1 if $@ && $@ =~ /unknown command/;
is($o->zcount($zset, 2, 3), 2);
+}
is($o->zcard($zset), 3);
@@ -255,7 +271,10 @@ my @zkeys = (qw/foo bar baz qux quux quuux quuuux quuuuux/);
ok($o->zadd($zset, $score++, $_)) for @zkeys;
is_deeply([$o->zrangebyscore($zset, 0, 8)], \@zkeys);
-is($o->zremrangebyrank($zset, 5, 8), 3); # remove quux and up
+SKIP: {
+my $retval = eval { $o->zremrangebyrank($zset, 5, 8) };
+skip "zremrangebyrank not implemented in this redis", 5 if $@ && $@ =~ /unknown command/;
+is($retval, 3); # remove quux and up
is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]);
is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar
@@ -263,6 +282,7 @@ is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[2 .. 4]]);
# only left with 3
is($o->zcard($zset), 3);
+}
ok($o->del($zset)); # cleanup
@@ -272,7 +292,10 @@ ok($o->del($zset)); # cleanup
my $hash = 'test-hash';
$o->del($hash);
-ok($o->hset($hash, foo => 'bar'));
+SKIP: {
+my $retval = eval { $o->hset($hash, foo => 'bar') };
+skip "hset not implemented in this redis", 20 if $@ && $@ =~ /unknown command/;
+ok($retval);
is($o->hget($hash, 'foo'), 'bar');
ok($o->hexists($hash, 'foo'));
ok($o->hdel($hash, 'foo'));
@@ -302,7 +325,7 @@ is_deeply([$o->hvals($hash)], [qw/1 2 3 4/]);
is_deeply({ $o->hgetall($hash) }, { foo => 1, bar => 2, baz => 3, qux => 4 });
ok($o->del($hash)); # remove entire hash
-
+}
## Multiple databases handling commands
@@ -27,6 +27,7 @@ ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server');
sub r {
$r->{sock} = IO::String->new(join('', map {"$_\r\n"} @_));
+ $r->{__buf} = '';
}
## -ERR responses
@@ -20,6 +20,11 @@ use Test::SpawnRedisServer qw( redis reap );
my ($c, $srv) = redis();
END { $c->() if $c }
+{
+my $r = Redis->new(server => $srv);
+eval { $r->publish( 'aa', 'v1' ) };
+plan 'skip_all' => "pubsub not implemented on this redis server" if $@ && $@ =~ /unknown command/;
+}
my ($another_kill_switch, $yet_another_kill_switch);
END { $_ and $_->() for($another_kill_switch, $yet_another_kill_switch) }
@@ -20,6 +20,12 @@ use Test::Deep;
my ($c, $srv) = redis();
END { $c->() if $c }
+{
+my $r = Redis->new(server => $srv);
+eval { $r->multi( ); };
+plan 'skip_all' => "multi without arguments not implemented on this redis server" if $@ && $@ =~ /unknown command/;
+}
+
ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server');
@@ -71,16 +77,28 @@ subtest 'synchronous request with pending pipeline' => sub {
is($clunk, 'eth', 'synchronous request processes pending ones');
};
-pipeline_ok 'transaction',
- (
- [multi => [], 'OK'],
- [set => ['clunk' => 'eth'], 'QUEUED'],
- [rpush => ['clunk' => 'oops'], 'QUEUED'],
- [get => ['clunk'], 'QUEUED'],
- [ exec => [],
- [['OK', undef], [undef, 'ERR Operation against a key holding the wrong kind of value'], ['eth', undef],]
- ],
- );
+subtest 'transaction with error and pipeline' => sub {
+ my @responses;
+ my $s = sub { push @responses, [@_] };
+ $r->multi($s);
+ $r->set(clunk => 'eth', $s);
+ $r->rpush(clunk => 'oops', $s);
+ $r->get('clunk', $s);
+ $r->exec($s);
+ $r->wait_all_responses;
+
+ is(shift(@responses)->[0], 'OK' , 'multi started' );
+ is(shift(@responses)->[0], 'QUEUED', 'queued');
+ is(shift(@responses)->[0], 'QUEUED', 'queued');
+ is(shift(@responses)->[0], 'QUEUED', 'queued');
+ my $resp = shift @responses;
+ is ($resp->[0]->[0]->[0], 'OK', 'set');
+ is ($resp->[0]->[1]->[0], undef, 'bad rpush value should be undef');
+ like ($resp->[0]->[1]->[1],
+ qr/(?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value/,
+ 'bad rpush should give an error');
+ is ($resp->[0]->[2]->[0], 'eth', 'get should work');
+};
subtest 'transaction with error and no pipeline' => sub {
is($r->multi, 'OK', 'multi');
@@ -89,7 +107,7 @@ subtest 'transaction with error and no pipeline' => sub {
is($r->get('clunk'), 'QUEUED', 'transactional GET');
like(
exception { $r->exec },
- qr{\[exec\] ERR Operation against a key holding the wrong kind of value,},
+ qr{\[exec\] (?:WRONGTYPE|ERR) Operation against a key holding the wrong kind of value,},
'synchronous EXEC dies for intervening error'
);
};
@@ -26,7 +26,7 @@ subtest 'non-block TCP' => sub {
## But kill if we block
local $SIG{ALRM} = sub { kill 9, $$ };
alarm(2);
- ok(!Redis::__try_read_sock($r->{sock}), "Nothing to read, didn't block");
+ ok(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block");
alarm(0);
};
@@ -17,6 +17,7 @@ use Time::HiRes qw(gettimeofday tv_interval);
use Redis;
use lib 't/tlib';
use Test::SpawnRedisServer;
+use Net::EmptyPort qw(empty_port);
my ($c, $srv) = redis(timeout => 1);
END { $c->() if $c }
@@ -108,6 +109,63 @@ subtest "Reconnect gives up after timeout" => sub {
ok(tv_interval($t0) > 3, '... minimum value for the reconnect reached');
};
+subtest "Reconnect during transaction" => sub {
+ $c->(); ## Make previous server is dead
+
+ my $port = empty_port();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port");
+ ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server');
+
+ ok($r->multi(), 'start transacion');
+ ok($r->set('reconnect_1' => 1), 'set first key');
+
+ $c->();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port");
+
+ like(exception { $r->set('reconnect_2' => 2) }, qr{reconnect disabled inside transaction}, 'set second key');
+
+ $r->connect(); #reconnect
+ is($r->exists('reconnect_1'), 0, 'key "reconnect_1" should not exist');
+ is($r->exists('reconnect_2'), 0, 'key "reconnect_2" should not exist');
+};
+
+subtest "Reconnect works after WATCH + MULTI + EXEC" => sub {
+ $c->(); ## Make previous server is dead
+
+ my $port = empty_port();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port");
+ ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server');
+
+ ok($r->set('watch' => 'watch'), 'set watch key');
+ ok($r->watch('watch'), 'start watching key');
+ ok($r->multi(), 'start transacion');
+ ok($r->set('reconnect' => 1), 'set key');
+ ok($r->exec(), 'execute transaction');
+
+ $c->();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port");
+
+ ok($r->set('reconnect' => 1), 'setting key should not fail');
+};
+
+subtest "Reconnect works after WATCH + MULTI + DISCARD" => sub {
+ $c->(); ## Make previous server is dead
+
+ my $port = empty_port();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port");
+ ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server');
+
+ ok($r->set('watch' => 'watch'), 'set watch key');
+ ok($r->watch('watch'), 'start watching key');
+ ok($r->multi(), 'start transacion');
+ ok($r->set('reconnect' => 1), 'set key');
+ ok($r->discard(), 'dscard transaction');
+
+ $c->();
+ ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port");
+
+ ok($r->set('reconnect' => 1), 'setting second key should not fail');
+};
done_testing();
@@ -1,57 +0,0 @@
-#!perl
-#
-# This file is part of Redis
-#
-# This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine.
-#
-# This is free software, licensed under:
-#
-# The Artistic License 2.0 (GPL Compatible)
-#
-
-use warnings;
-use strict;
-use Test::More;
-use Test::Fatal;
-use Redis;
-use lib 't/tlib';
-use Test::SpawnRedisServer;
-
-my ($c, $srv) = redis();
-END { $c->() if $c }
-
-subtest 'REDIS_SERVER TCP' => sub {
- my $n = time();
- my $r = Redis->new(server => $srv);
- $r->set($$ => $n);
-
- local $ENV{REDIS_SERVER} = $srv;
- is(exception { $r = Redis->new }, undef, "Direct IP/Port address on REDIS_SERVER works ($srv)",);
- is($r->get($$), $n, '... connected to the expected server');
-
- $ENV{REDIS_SERVER} = "tcp:$srv";
- is(exception { $r = Redis->new }, undef, 'Direct IP/Port address (with tcp prefix) on REDIS_SERVER works',);
- is($r->get($$), $n, '... connected to the expected server');
-};
-
-
-subtest 'REDIS_SERVER UNIX' => sub {
- my $srv = $ENV{TEST_REDIS_SERVER_SOCK_PATH};
- plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support'
- unless $srv;
-
- my $n = time();
- my $r = Redis->new(sock => $srv);
- $r->set($$ => $n);
-
- local $ENV{REDIS_SERVER} = $srv;
- is(exception { $r = Redis->new }, undef, 'UNIX path on REDIS_SERVER works',);
- is($r->get($$), $n, '... connected to the expected server');
-
- $ENV{REDIS_SERVER} = "unix:$srv";
- is(exception { $r = Redis->new }, undef, 'UNIX path (with unix prefix) on REDIS_SERVER works',);
- is($r->get($$), $n, '... connected to the expected server');
-};
-
-
-done_testing();
@@ -0,0 +1,71 @@
+#!perl
+#
+# This file is part of Redis
+#
+# This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine.
+#
+# This is free software, licensed under:
+#
+# The Artistic License 2.0 (GPL Compatible)
+#
+
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+use Redis;
+use lib 't/tlib';
+use Test::SpawnRedisTimeoutServer;
+use Errno qw(ETIMEDOUT EWOULDBLOCK);
+use POSIX qw(strerror);
+use Carp;
+use IO::Socket::INET;
+use Test::TCP;
+
+subtest 'server replies quickly enough' => sub {
+ my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(0);
+ my $redis = Redis->new(server => '127.0.0.1:' . $server->port, read_timeout => 1);
+ ok($redis);
+ my $res = $redis->get('foo');;
+ is $res, 42;
+};
+
+subtest "server doesn't replies quickly enough" => sub {
+ my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(10);
+ my $redis = Redis->new(server => '127.0.0.1:' . $server->port, read_timeout => 1);
+ ok($redis);
+ my $msg1 = "Error while reading from Redis server: " . strerror(ETIMEDOUT);
+ my $msg2 = "Error while reading from Redis server: " . strerror(EWOULDBLOCK);
+ like(
+ exception { $redis->get('foo'); },
+ qr/$msg1|$msg2/,
+ "the code died as expected",
+ );
+};
+
+subtest "server doesn't respond at connection (cnx_timeout)" => sub {
+ SKIP: {
+ skip "This subtest is failing on some platforms", 4;
+ my $server = Test::TCP->new(code => sub {
+ my $port = shift;
+ my $sock = IO::Socket::INET->new(Listen => 1, LocalPort => $port, Proto => 'tcp', LocalAddr => '127.0.0.1') or croak "fail to listen on port $port";
+ while(1) {
+ sleep(1);
+ };
+ });
+
+ my $redis;
+ my $start_time = time;
+ isnt(
+ exception { $redis = Redis->new(server => '127.0.0.1:' . $server->port, cnx_timeout => 1); },
+ undef,
+ "the code died",
+ );
+ ok(time - $start_time >= 1, "gave up late enough");
+ ok(time - $start_time < 5, "gave up soon enough");
+ ok(!$redis, 'redis was not set');
+ }
+};
+
+done_testing;
+
@@ -18,11 +18,10 @@ use IPC::Cmd qw(can_run);
use POSIX ":sys_wait_h";
use base qw( Exporter );
-our @EXPORT = qw( redis );
-our @EXPORT_OK = qw( redis reap );
+use Net::EmptyPort qw(empty_port);
-## FIXME: for the love of $Deity... move to Test::TCP, will you??
-my $port = 11011 + ($$ % 127);
+our @EXPORT = qw( redis sentinel );
+our @EXPORT_OK = qw( redis reap );
sub redis {
my %params = (
@@ -32,7 +31,7 @@ sub redis {
my ($fh, $fn) = File::Temp::tempfile();
- $port++;
+ my $port = empty_port();
my $local_port = $port;
$params{port}
@@ -89,6 +88,72 @@ sub redis {
return ($c, $addr, $ver, split(/[.]/, $ver), $local_port);
}
+sub sentinel {
+ my %params = (
+ timeout => 120,
+ @_,
+ );
+
+ my ($fh, $fn) = File::Temp::tempfile();
+
+ my $port = empty_port();
+
+ my $local_port = $port;
+ $params{port}
+ and $local_port = $params{port};
+
+ my $redis_port = $params{redis_port}
+ or die "need a redis port";
+
+ my $addr = "127.0.0.1:$local_port";
+
+ unlink("redis-sentinel-$addr.log");
+
+ $fh->print("
+ port $local_port
+
+ sentinel monitor mymaster 127.0.0.1 $redis_port 2
+ sentinel down-after-milliseconds mymaster 2000
+ sentinel failover-timeout mymaster 4000
+
+ logfile sentinel-$addr.log
+
+ ");
+ $fh->flush;
+
+ my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server';
+ if (!can_run($redis_server_path)) {
+ Test::More::plan skip_all => "Could not find binary redis-server";
+ return;
+ }
+
+ my ($ver, $c);
+ eval { ($ver, $c) = spawn_server($redis_server_path, $fn, '--sentinel', $addr) };
+ if (my $e = $@) {
+ reap();
+ Test::More::plan skip_all => "Could not start redis-sentinel: $@";
+ return;
+ }
+
+ if (my $rvs = $params{requires_version}) {
+ if (!defined $ver) {
+ $c->();
+ Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version";
+ return;
+ }
+
+ my ($v1, $v2, $v3) = split(/[.]/, $ver);
+ my ($r1, $r2, $r3) = split(/[.]/, $rvs);
+ if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) {
+ $c->();
+ Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver";
+ return;
+ }
+ }
+
+ return ($c, $addr, $ver, split(/[.]/, $ver), $local_port);
+}
+
sub spawn_server {
my $addr = pop;
my $pid = fork();
@@ -111,6 +176,7 @@ sub spawn_server {
Test::More::diag("Failed to kill server at $pid")
if $ENV{REDIS_DEBUG} and $failed;
unlink("redis-server-$addr.log");
+ unlink("redis-sentinel-$addr.log");
unlink('dump.rdb');
$alive = 0;
@@ -134,6 +200,7 @@ sub reap {
$limit = 3 unless $limit;
my $try = 0;
+ local $?;
while ($try++ < $limit) {
my $ok = waitpid($pid, WNOHANG);
$try = 0, last if $ok > 0;
@@ -0,0 +1,42 @@
+#
+# This file is part of Redis
+#
+# This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine.
+#
+# This is free software, licensed under:
+#
+# The Artistic License 2.0 (GPL Compatible)
+#
+package # Hide from PAUSE
+ Test::SpawnRedisTimeoutServer;
+
+use strict;
+use warnings;
+use Test::TCP;
+
+sub create_server_with_timeout {
+ my $timeout = shift;
+
+ Test::TCP->new(
+ code => sub {
+ my $port = shift;
+ my $socket = IO::Socket::INET->new(
+ Listen => 5,
+ Timeout => 1,
+ Reuse => 1,
+ Blocking => 1,
+ LocalPort => $port
+ ) or die "failed to connect to RedisTimeoutServer: $!";
+
+ my $buffer;
+ while (1) {
+ my $client = $socket->accept();
+ if (defined (my $got = <$client>)) {
+ sleep $timeout;
+ $client->print("+42\r\n");
+ }
+ }
+ },
+ );
+}
+1;