@@ -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,36 @@
Revision history for Redis
+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
@@ -9,6 +9,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 +21,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 +30,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
@@ -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: 0
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.972
@@ -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" => 0
},
- "VERSION" => "1.965",
+ "VERSION" => "1.972",
"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" => 0,
"Try::Tiny" => 0
);
@@ -1,7 +1,7 @@
This archive contains the distribution Redis,
-version 1.965:
+version 1.972:
Perl binding for Redis database
@@ -17,6 +17,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 +29,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 +48,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 = 0
+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.972';
}
# 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.972
=head1 DESCRIPTION
@@ -9,7 +9,7 @@
#
package Redis::List;
{
- $Redis::List::VERSION = '1.965';
+ $Redis::List::VERSION = '1.972';
}
# 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.972
=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.972';
+}
+
+# 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.972
+
+=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.972';
}
# ABSTRACT: Perl binding for Redis database
@@ -21,21 +21,36 @@ 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;
+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) = @_;
@@ -44,7 +59,7 @@ sub new {
$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 +71,107 @@ sub new {
}
}
- $args{password}
- and $self->{password} = $args{password};
-
- $args{on_connect}
- and $self->{on_connect} = $args{on_connect};
+ 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);
- 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;
}
@@ -157,7 +244,7 @@ sub __with_reconnect {
ref($_) eq 'Redis::X::Reconnect'
or die $_;
- $self->__connect;
+ $self->connect;
$cb->();
}
);
@@ -174,7 +261,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 +304,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 {
@@ -234,14 +321,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: $!");
+ close(delete $self->{sock}) || croak("Can't close socket: $!");
return 1;
}
@@ -250,7 +337,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};
@@ -349,7 +436,7 @@ sub wait_for_messages {
## timeout
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++;
}
@@ -375,7 +462,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 +513,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,13 +556,13 @@ 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};
@@ -508,13 +595,13 @@ 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}: $!");
if (exists $self->{password}) {
try { $self->auth($self->{password}) }
catch {
$self->{reconnect} = 0;
- confess("Redis server refused password");
+ croak("Redis server refused password");
};
}
@@ -541,20 +628,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 +657,7 @@ sub __send_command {
my $deb = $self->{debug};
if ($self->{pid} != $$) {
- $self->__connect;
+ $self->connect;
}
my $sock = $self->{sock}
@@ -609,7 +695,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 +703,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 +732,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), ";
}
}
@@ -662,7 +748,7 @@ sub __read_line {
my $sock = $self->{sock};
my $data = <$sock>;
- confess("Error while reading from Redis server: $!")
+ croak("Error while reading from Redis server: $!")
unless defined $data;
chomp $data;
@@ -679,9 +765,9 @@ sub __read_len {
my $offset = 0;
while ($len) {
my $bytes = read $self->{sock}, $data, $len, $offset;
- confess("Error while reading from Redis server: $!")
+ croak("Error while reading from Redis server: $!")
unless defined $bytes;
- confess("Redis server closed connection") unless $bytes;
+ croak("Redis server closed connection") unless $bytes;
$offset += $bytes;
$len -= $bytes;
@@ -736,6 +822,7 @@ sub __try_read_sock {
## * https://github.com/melo/perl-redis/issues/20
## * https://github.com/melo/perl-redis/pull/21
my $len;
+ local $! = 0;
if (WIN32) {
$len = sysread($sock, $data, 1);
}
@@ -752,11 +839,15 @@ sub __try_read_sock {
return 1;
}
## EOF according to the docs
+ ## (however FreeBSD seems to return $len = 0 when read fails)
elsif ($len == 0) {
+ if ($err and ($err == EWOULDBLOCK or $err == EAGAIN or $err == EINTR)) {
+ return 0;
+ }
return;
}
else {
- confess("read()/sysread() are really bonkers on $^O, return negative values ($len)");
+ croak("read()/sysread() are really bonkers on $^O, return negative values ($len)");
}
}
@@ -771,7 +862,7 @@ sub __try_read_sock {
return if $err == 0;
## For everything else, there is Mastercard...
- confess("Unexpected error condition $err/$^O, please report this as a bug");
+ croak("Unexpected error condition $err/$^O, please report this as a bug");
}
@@ -807,7 +898,7 @@ Redis - Perl binding for Redis database
=head1 VERSION
-version 1.965
+version 1.972
=head1 SYNOPSIS
@@ -838,6 +929,25 @@ version 1.965
## Try each 100ms upto 2 seconds (every is in milisecs)
my $redis = Redis->new(reconnect => 2, every => 100);
+ ## Enable connection timeout (in seconds)
+ my $redis = Redis->new(cnx_timeout => 60);
+
+ ## 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
## See http://redis.io/commands for full list
@@ -913,7 +1023,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 +1081,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 +1102,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,15 +1130,6 @@ 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
@@ -1022,6 +1141,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 +1178,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 +1211,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 +1473,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 +1494,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 +1577,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 +1595,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 +1609,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 +1620,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 +1638,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
@@ -1600,7 +1775,7 @@ The C<slowlog> command gives access to the server's slow log.
The following persons contributed to this project (alphabetical order):
-=over 4
+=over
=item *
@@ -1630,6 +1805,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
@@ -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'
);
};
@@ -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;