Redis-1.967000755000765000024 012257644644 12034 5ustar00damsstaff000000000000README100644000765000024 37612257644644 12763 0ustar00damsstaff000000000000Redis-1.967 This archive contains the distribution Redis, version 1.967: Perl binding for Redis database This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) Changes100644000765000024 1177612257644644 13444 0ustar00damsstaff000000000000Redis-1.967Revision history for Redis 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 * fix #34: perl-redis doesn't receive subcribed message if server restart * fix #38: select new database doesn't survive after reconnect * minor documentation fixes 1.964 2013-11-14 15:45:08 Europe/Amsterdam * minor fix to dist.ini to fix github url 1.963 2013-11-13 22:44:29 Europe/Paris * Add documentation for the slowlog command PR #44 (rgs) * doc fix, duplicate spop PR #48 (nightlord) * Redis client is now fork safe PR #51 (songmu) * rewrite dist.ini 1.962 2013-10-16T14:58:30Z * merge #54 (fix for broken test) * Parameter name to new() can be a CodeRef, dynamic connection names * admin: added co-maintainer Damien Krotkine 1.961 2013-01-23T15:09:47Z * Add wait_one_response() for better pipeline management 1.960 2013-01-23T11:28:40Z * Make the new() name parameter safe to use with all redis- server versions 1.959 2013-01-22T14:46:42Z * __try_read_sock: test error conditions more thoroughly (issue #31) * Improve Test::SpawnRedisServer: multi-server support * tidyall the code and docs 1.958 2013-01-15T16:54:40Z * Support for name constructor parameter, set connection name * Add documentation for CLIENT * commands * Improve reliability of Test::SpawnRedisServer 1.957 2013-01-15T13:18:07Z * Fix minimum Perl version 1.956 2013-01-15T10:35:10Z * Add on_connect callback to Redis constructor (issue 28) * Make sure quit() doesn't die when the socket is already dead (issue 30); * Switch to Digest::SHA, one less non-core dep RT#81841 * Try and make Travis-CI more useful, ask for a redis-server * Update SUPPORT section, moving bugtracker to GitHub issues 1.955 2012-10-10T11:43:44Z * Skip 30-scripts.t if the redis-server found lacks script support 1.954 2012-10-10T11:16:22Z * Support for multi-word commands such as "SCRIPT LOAD". * Try another fix for Windows non-blocking reads 1.953 2012-09-05T00:49:11Z * Tweak travis.ci setup 1.952 2012-09-04T11:22:18Z * Added automatic authentication after connection establishment * Support Redis 2.6: Aaron Crane * Attempt to fix non-blocking read on Windows * Enable travis.ci support on the repository 1.951 2012-03-13T10:17:09Z * Remove Tie::StdHash from our dependencies list, its part of core and it creates problems with some CPAN clients 1.950 2012-03-12T13:54:10Z * DEPRECATED: the encoding attribute to new() - we will not support automatic decoding after 2.000, so please test your code with encoding => undef now. * Add pipeline support: Aaron Crane arc@github++! * Cache AUTOLOAD calls: improves performance a bit, fixes #2 * Fix: apply reconnect logic to KEYS and INFO * Fix: forbid PING and SHUTDOWN in SUBSCRIBE mode * Updated docs covering pipelining and multi/exec * Updated docs to point users to Github for code and issues 1.926 Wed Jan 11 15:48:11 UTC 2012 * Fix auto-reconnect when the server is dead or a client timeout. See https://github.com/melo/perl-redis/issues/1#issuecomment-3444989 1.925 Tue Jan 10 16:02:04 UTC 2012 * Implemented auto-reconnect * Add support for UNIX domain sockets * Make REDIS_SERVER work with both TCP and UNIX domain sockets * Make the test suite workaround a missing redis-server binary * Assorted small bug fixes * Improve documentation 1.904 Sat Mar 5 23:10:48 UTC 2011 * Fix bug with NIL multi-bulk replies (Case 42) RT#64040 1.903 Tue Feb 22 13:04:24 UTC 2011 * remove the Guard dependency 1.902 Sat Feb 5 12:38:57 UTC 2011 * fix: ping() no longer dies (RT #62489) * fix: shutdown() no longer dies 1.901 Sat Feb 5 11:15:04 UTC 2011 * Released 1.900_01 as latest version 1.900_01 Sun Jan 30 06:03:14 UTC 2011 * admin: change of maintainer to Pedro Melo * feature: full support for Redis 2.x multi-bulk protocol * feature: support for Redis PUBLISH/SUBSCRIBE commands * feature: automatic encoding can be turned off, use encoding => undef on new() (performance++) * performance: substantial performance improvements, specially with large responses * fix: add POP method to our List Tie interface 1.2001 Wed Mar 17 17:22:01 CET 2010 * feadure: Redis protocol 1.2 support by Jeremy Zawodny CPAN RT #54841 * Version bump to be in-sync with Redis version * bug: Correctly round-trip utf-8 encoded characters 0.08 Tue Mar 24 22:38:59 CET 2009 * This version supports new protocol introduced in beta 8 * Version bump to be in-sync with Redis version 0.01 Sun Mar 22 19:02:17 CET 2009 * First version, tracking git://github.com/antirez/redis LICENSE100644000765000024 2154012257644644 13144 0ustar00damsstaff000000000000Redis-1.967This software is Copyright (c) 2013 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dist.ini100644000765000024 224612257644644 13565 0ustar00damsstaff000000000000Redis-1.967name = Redis author = Pedro Melo author = Damien Krotkine license = Artistic_2_0 copyright_holder = Pedro Melo, Damien Krotkine copyright_year = 2013 ; -- version from git [Git::NextVersion] first_version = 1.962 [MetaResources] homepage = https://github.com/PerlRedis/perl-redis bugtracker.web = https://github.com/PerlRedis/perl-redis/issues repository.web = https://github.com/PerlRedis/perl-redis repository.url = https://github.com/PerlRedis/perl-redis.git repository.type = git [GatherDir] exclude_match = redis-server-* [PruneCruft] [ManifestSkip] [MetaYAML] [License] [Readme] [ExtraTests] [ExecDir] [ShareDir] [Manifest] [TestRelease] [ConfirmRelease] [UploadToCPAN] [ModuleBuildTiny] [MakeMaker::Fallback] eumm_version = 6.63_03 [PkgVersion] [PodWeaver] [Prepender] copyright = 1 [MinimumPerl] [Test::Compile] [MetaTests] [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 ; -- release [NextRelease] [CheckChangeLog] [Git::Tag] [Git::Check] [Git::Commit] [Git::Push] META.yml100644000765000024 156012257644644 13370 0ustar00damsstaff000000000000Redis-1.967--- abstract: 'Perl binding for Redis database' author: - 'Pedro Melo ' - 'Damien Krotkine ' build_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 configure_requires: ExtUtils::MakeMaker: 6.63_03 Module::Build::Tiny: 0.030 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300039, CPAN::Meta::Converter version 2.132830' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html 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.967 MANIFEST100644000765000024 154212257644644 13250 0ustar00damsstaff000000000000Redis-1.967Build.PL Changes LICENSE MANIFEST META.yml Makefile.PL README dist.ini lib/Redis.pm lib/Redis/Hash.pm lib/Redis/List.pm scripts/publish.pl scripts/redis-benchmark.pl t/00-compile.t t/01-basic.t t/02-responses.t t/03-pubsub.t t/04-pipeline.t t/05-nonblock.t t/06-on-connect.t t/07-reconnect.t t/08-unix-socket.t t/10-tie-list.t t/11-timeout.t t/20-tie-hash.t t/30-scripts.t t/42-client_cmds.t 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 tools/benchmarks/readline_vs_sysread_vs_recv/client-sysread.pl tools/benchmarks/readline_vs_sysread_vs_recv/run.pl tools/benchmarks/readline_vs_sysread_vs_recv/server-generator.pl Build.PL100644000765000024 6612257644644 13353 0ustar00damsstaff000000000000Redis-1.967use 5.008; use Module::Build::Tiny 0.030; Build_PL(); Makefile.PL100644000765000024 671512257644644 14100 0ustar00damsstaff000000000000Redis-1.967# This Makefile.PL for Redis was generated by # Dist::Zilla::Plugin::MakeMaker::Fallback 0.005. # Don't edit it but the dist.ini 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; my %WriteMakefileArgs = ( "ABSTRACT" => "Perl binding for Redis database", "AUTHOR" => "Pedro Melo , Damien Krotkine ", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.63_03", "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" => { "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 }, "VERSION" => "1.967", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; my $br = $WriteMakefileArgs{BUILD_REQUIRES}; for my $mod ( keys %$tr ) { if ( exists $br->{$mod} ) { $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; } else { $br->{$mod} = $tr->{$mod}; } } } unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); lib000755000765000024 012257644644 12523 5ustar00damsstaff000000000000Redis-1.967Redis.pm100644000765000024 12313012257644644 14327 0ustar00damsstaff000000000000Redis-1.967/lib# # 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; { $Redis::VERSION = '1.967'; } # ABSTRACT: Perl binding for Redis database # VERSION # AUTHORITY use warnings; 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 Encode; use Try::Tiny; use Scalar::Util (); 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 new { my ($class, %args) = @_; my $self = bless {}, $class; $self->{debug} = $args{debug} || $ENV{REDIS_DEBUG}; ## Deal with REDIS_SERVER ENV if ($ENV{REDIS_SERVER} && !$args{sock} && !$args{server}) { if ($ENV{REDIS_SERVER} =~ m!^/!) { $args{sock} = $ENV{REDIS_SERVER}; } elsif ($ENV{REDIS_SERVER} =~ m!^unix:(.+)!) { $args{sock} = $1; } elsif ($ENV{REDIS_SERVER} =~ m!^(?:tcp:)?(.+)!) { $args{server} = $1; } } $args{password} and $self->{password} = $args{password}; $args{on_connect} and $self->{on_connect} = $args{on_connect}; defined $args{name} and $self->{name} = $args{name}; $self->{cnx_timeout} = $args{cnx_timeout}; $self->{write_timeout} = $args{write_timeout}; $self->{read_timeout} = $args{read_timeout}; $self->{reconnect} = $args{reconnect} || 0; $self->{every} = $args{every} || 1000; if ($args{sock}) { $self->{server} = $args{sock}; $self->{builder} = sub { my ($self) = @_; if (exists $self->{read_timeout} || exists $self->{write_timeout}) { my $socket = IO::Socket::UNIX->new( Peer => $self->{server}, ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ); IO::Socket::Timeout->enable_timeouts_on($socket); $self->{read_timeout} and $socket->read_timeout($self->{read_timeout}); $self->{write_timeout} and $socket->write_timeout($self->{write_timeout}); $socket; } else { IO::Socket::UNIX->new( Peer => $self->{server}, ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ): () ), ); } }; } else { $self->{server} = $args{server} || '127.0.0.1:6379'; $self->{builder} = sub { my ($self) = @_; if (exists $self->{read_timeout} || exists $self->{write_timeout}) { my $socket = IO::Socket::INET->new( PeerAddr => $self->{server}, Proto => 'tcp', ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ); IO::Socket::Timeout->enable_timeouts_on($socket); $self->{read_timeout} and $socket->read_timeout($self->{read_timeout}); $self->{write_timeout} and $socket->write_timeout($self->{write_timeout}); $socket; } else { IO::Socket::INET->new( PeerAddr => $self->{server}, Proto => 'tcp', ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ); } }; } $self->{is_subscriber} = 0; $self->{subscribers} = {}; $self->__connect; return $self; } sub is_subscriber { $_[0]{is_subscriber} } sub select { my $self = shift; my $database = shift; my $ret = $self->__std_cmd('select', $database, @_); $self->{current_database} = $database; $ret; } ### we don't want DESTROY to fallback into AUTOLOAD sub DESTROY { } ### Deal with common, general case, Redis commands our $AUTOLOAD; sub AUTOLOAD { my $command = $AUTOLOAD; $command =~ s/.*://; my $method = sub { shift->__std_cmd($command, @_) }; # Save this method for future calls no strict 'refs'; *$AUTOLOAD = $method; goto $method; } sub __std_cmd { my $self = shift; my $command = shift; $self->__is_valid_command($command); my $cb = @_ && ref $_[-1] eq 'CODE' ? pop : undef; # 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'; ## Fast path, no reconnect; $self->{reconnect} or return $self->__run_cmd($command, $collect_errors, undef, $cb, @_); my @cmd_args = @_; $self->__with_reconnect( sub { $self->__run_cmd($command, $collect_errors, undef, $cb, @cmd_args); } ); } sub __with_reconnect { my ($self, $cb) = @_; ## Fast path, no reconnect $self->{reconnect} or return $cb->(); return &try( $cb, catch { ref($_) eq 'Redis::X::Reconnect' or die $_; $self->__connect; $cb->(); } ); } sub __run_cmd { my ($self, $command, $collect_errors, $custom_decode, $cb, @args) = @_; my $ret; my $wrapper = $cb && $custom_decode ? sub { my ($reply, $error) = @_; $cb->(scalar $custom_decode->($reply), $error); } : $cb || sub { my ($reply, $error) = @_; confess "[$command] $error, " if defined $error; $ret = $reply; }; $self->__send_command($command, @args); push @{ $self->{queue} }, [$command, $wrapper, $collect_errors]; return 1 if $cb; $self->wait_all_responses; return $custom_decode ? $custom_decode->($ret, !wantarray) : wantarray && ref $ret eq 'ARRAY' ? @$ret : $ret; } sub wait_all_responses { my ($self) = @_; my $queue = $self->{queue}; $self->wait_one_response while @$queue; return; } sub wait_one_response { my ($self) = @_; my $handler = shift @{ $self->{queue} }; return unless $handler; my ($command, $cb, $collect_errors) = @$handler; $cb->($self->__read_response($command, $collect_errors)); return; } ### Commands with extra logic sub quit { my ($self) = @_; return unless $self->{sock}; confess "[quit] only works in synchronous mode, " if @_ && ref $_[-1] eq 'CODE'; try { $self->wait_all_responses; $self->__send_command('QUIT'); }; close(delete $self->{sock}) if $self->{sock}; return 1; } sub shutdown { my ($self) = @_; $self->__is_valid_command('SHUTDOWN'); confess "[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: $!"); return 1; } sub ping { my $self = shift; $self->__is_valid_command('PING'); confess "[ping] only works in synchronous mode, " if @_ && ref $_[-1] eq 'CODE'; return unless exists $self->{sock}; $self->wait_all_responses; return scalar try { $self->__std_cmd('PING'); } catch { close(delete $self->{sock}); return; }; } sub info { my $self = shift; $self->__is_valid_command('INFO'); my $custom_decode = sub { my ($reply) = @_; return $reply if !defined $reply || ref $reply; return { map { split(/:/, $_, 2) } grep {/^[^#]/} split(/\r\n/, $reply) }; }; my $cb = @_ && ref $_[-1] eq 'CODE' ? pop : undef; ## Fast path, no reconnect return $self->__run_cmd('INFO', 0, $custom_decode, $cb, @_) unless $self->{reconnect}; my @cmd_args = @_; $self->__with_reconnect( sub { $self->__run_cmd('INFO', 0, $custom_decode, $cb, @cmd_args); } ); } sub keys { my $self = shift; $self->__is_valid_command('KEYS'); my $custom_decode = sub { my ($reply, $synchronous_scalar) = @_; ## Support redis <= 1.2.6 $reply = [split(/\s/, $reply)] if defined $reply && !ref $reply; return ref $reply && ($synchronous_scalar || wantarray) ? @$reply : $reply; }; my $cb = @_ && ref $_[-1] eq 'CODE' ? pop : undef; ## Fast path, no reconnect return $self->__run_cmd('KEYS', 0, $custom_decode, $cb, @_) unless $self->{reconnect}; my @cmd_args = @_; $self->__with_reconnect( sub { $self->__run_cmd('KEYS', 0, $custom_decode, $cb, @cmd_args); } ); } ### PubSub sub wait_for_messages { my ($self, $timeout) = @_; my $s = IO::Select->new; my $count = 0; my $e; try { $self->__with_reconnect( sub { # the socket can be changed due to reconnection, so get it each time my $sock = $self->{sock}; $s->remove($s->handles); $s->add($sock); while ($s->can_read($timeout)) { my $has_stuff = __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 my ($reply, $error) = $self->__read_response('WAIT_FOR_MESSAGES'); confess "[WAIT_FOR_MESSAGES] $error, " if defined $error; $self->__process_pubsub_msg($reply); $count++; } } }); } catch { $e = $_; }; # if We had an error and it was not an EOF, die defined $e && $e ne 'EOF from server' and die $e; return $count; } sub __subscription_cmd { my $self = shift; my $pr = shift; my $unsub = shift; my $command = shift; my $cb = pop; confess("Missing required callback in call to $command(), ") unless ref($cb) eq 'CODE'; $self->wait_all_responses; my @subs = @_; $self->__with_reconnect( sub { $self->__throw_reconnect('Not connected to any server') unless $self->{sock}; @subs = $self->__process_unsubscribe_requests($cb, $pr, @subs) if $unsub; return unless @subs; $self->__send_command($command, @subs); my %cbs = map { ("${pr}message:$_" => $cb) } @subs; return $self->__process_subscription_changes($command, \%cbs); } ); } sub subscribe { shift->__subscription_cmd('', 0, subscribe => @_) } sub psubscribe { shift->__subscription_cmd('p', 0, psubscribe => @_) } sub unsubscribe { shift->__subscription_cmd('', 1, unsubscribe => @_) } sub punsubscribe { shift->__subscription_cmd('p', 1, punsubscribe => @_) } sub __process_unsubscribe_requests { my ($self, $cb, $pr, @unsubs) = @_; my $subs = $self->{subscribers}; my @subs_to_unsubscribe; for my $sub (@unsubs) { my $key = "${pr}message:$sub"; my $cbs = $subs->{$key} = [grep { $_ ne $cb } @{ $subs->{$key} }]; next if @$cbs; delete $subs->{$key}; push @subs_to_unsubscribe, $sub; } return @subs_to_unsubscribe; } sub __process_subscription_changes { my ($self, $cmd, $expected) = @_; my $subs = $self->{subscribers}; while (%$expected) { my ($m, $error) = $self->__read_response($cmd); confess "[$cmd] $error, " if defined $error; ## Deal with pending PUBLISH'ed messages if ($m->[0] =~ /^p?message$/) { $self->__process_pubsub_msg($m); next; } my ($key, $unsub) = $m->[0] =~ m/^(p)?(un)?subscribe$/; $key .= "message:$m->[1]"; my $cb = delete $expected->{$key}; push @{ $subs->{$key} }, $cb unless $unsub; $self->{is_subscriber} = $m->[2]; } } sub __process_pubsub_msg { my ($self, $m) = @_; my $subs = $self->{subscribers}; my $sub = $m->[1]; my $cbid = "$m->[0]:$sub"; my $data = pop @$m; my $topic = $m->[2] || $sub; if (!exists $subs->{$cbid}) { warn "Message for topic '$topic' ($cbid) without expected callback, "; return; } $_->($data, $topic, $sub) for @{ $subs->{$cbid} }; return 1; } ### Mode validation sub __is_valid_command { my ($self, $cmd) = @_; confess("Cannot use command '$cmd' while in SUBSCRIBE mode, ") if $self->{is_subscriber}; } ### Socket operations sub __connect { my ($self) = @_; delete $self->{sock}; # 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 # the pending commands, so delete all those pending responses now. $self->{queue} = []; $self->{pid} = $$; ## Fast path, no reconnect return $self->__build_sock() unless $self->{reconnect}; ## Use precise timers on reconnections require Time::HiRes; my $t0 = [Time::HiRes::gettimeofday()]; ## Reconnect... while (1) { eval { $self->__build_sock }; last unless $@; ## Connected! die if Time::HiRes::tv_interval($t0) > $self->{reconnect}; ## Timeout Time::HiRes::usleep($self->{every}); ## Retry in... } return; } sub __build_sock { my ($self) = @_; $self->{sock} = $self->{builder}->($self) || confess("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"); }; } $self->__on_connection; return; } sub __on_connection { my ($self) = @_; # If we are in PubSub mode we shouldn't perform any command besides # (p)(un)subscribe if (! $self->{is_subscriber}) { defined $self->{name} and try { my $n = $self->{name}; $n = $n->($self) if ref($n) eq 'CODE'; $self->client_setname($n) if defined $n; }; defined $self->{current_database} and $self->select($self->{current_database}); } # TODO: don't use each while (my ($topic, $cbs) = each %{$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"; } else { $self->__send_command('psubscribe', $channel); my (undef, $error) = $self->__read_response('psubscribe'); defined $error and confess "[psubscribe] $error"; } } } defined $self->{on_connect} and $self->{on_connect}->($self); } sub __send_command { my $self = shift; my $cmd = uc(shift); my $deb = $self->{debug}; if ($self->{pid} != $$) { $self->__connect; } my $sock = $self->{sock} || $self->__throw_reconnect('Not connected to any server'); warn "[SEND] $cmd ", Dumper([@_]) if $deb; ## Encode command using multi-bulk format my @cmd = split /_/, $cmd; my $n_elems = scalar(@_) + scalar(@cmd); my $buf = "\*$n_elems\r\n"; for my $bin (@cmd, @_) { # force to consider inputs as bytes strings. Encode::_utf8_off($bin); $buf .= defined($bin) ? '$' . length($bin) . "\r\n$bin\r\n" : "\$-1\r\n"; } ## Check to see if socket was closed: reconnect on EOF my $status = __try_read_sock($sock); $self->__throw_reconnect('Not connected to any server') unless defined $status; ## Send command, take care for partial writes warn "[SEND RAW] $buf" if $deb; while ($buf) { my $len = syswrite $sock, $buf, length $buf; $self->__throw_reconnect("Could not write to Redis server: $!") unless defined $len; substr $buf, 0, $len, ""; } return; } sub __read_response { my ($self, $cmd, $collect_errors) = @_; confess("Not connected to any server") unless $self->{sock}; local $/ = "\r\n"; ## no debug => fast path 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}; return $result, $error; } sub __read_response_r { my ($self, $command, $collect_errors) = @_; my ($type, $result) = $self->__read_line; if ($type eq '-') { return undef, $result; } elsif ($type eq '+' || $type eq ':') { return $result, undef; } elsif ($type eq '$') { return undef, undef if $result < 0; return $self->__read_len($result + 2), undef; } elsif ($type eq '*') { return undef, undef if $result < 0; my @list; while ($result--) { my @nested = $self->__read_response_r($command, $collect_errors); if ($collect_errors) { push @list, \@nested; } else { confess "[$command] $nested[1], " if defined $nested[1]; push @list, $nested[0]; } } return \@list, undef; } else { confess "unknown answer type: $type ($result), "; } } sub __read_line { my $self = $_[0]; my $sock = $self->{sock}; my $data = <$sock>; confess("Error while reading from Redis server: $!") unless defined $data; chomp $data; warn "[RECV RAW] '$data'" if $self->{debug}; my $type = substr($data, 0, 1, ''); return ($type, $data); } sub __read_len { my ($self, $len) = @_; 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; $offset += $bytes; $len -= $bytes; } 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 $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)"); } } ## Keep going if nothing there, but socket is alive return 0 if $err and ($err == EWOULDBLOCK or $err == EAGAIN or $err == EINTR); ## 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; ## For everything else, there is Mastercard... confess("Unexpected error condition $err/$^O, please report this as a bug"); } ### 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; }; } ########################## # I take exception to that sub __throw_reconnect { my ($self, $m) = @_; die bless(\$m, 'Redis::X::Reconnect') if $self->{reconnect}; die $m; } 1; # End of Redis.pm __END__ =pod =head1 NAME Redis - Perl binding for Redis database =head1 VERSION version 1.967 =head1 SYNOPSIS ## Defaults to $ENV{REDIS_SERVER} or 127.0.0.1:6379 my $redis = Redis->new; my $redis = Redis->new(server => 'redis.example.com:8080'); ## Set the connection name (requires Redis 2.6.9) my $redis = Redis->new( server => 'redis.example.com:8080', name => 'my_connection_name', ); my $generation = 0; my $redis = Redis->new( server => 'redis.example.com:8080', name => sub { "cache-$$-".++$generation }, ); ## Use UNIX domain socket my $redis = Redis->new(sock => '/path/to/socket'); ## 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); ## 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); ## Use all the regular Redis commands, they all accept a list of ## arguments ## See http://redis.io/commands for full list $redis->get('key'); $redis->set('key' => 'value'); $redis->sort('list', 'DESC'); $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}); ## Add a coderef argument to run a command in the background $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}, sub { my ($reply, $error) = @_; die "Oops, got an error: $error\n" if defined $error; print "$_\n" for @$reply; }); long_computation(); $redis->wait_all_responses; ## or $redis->wait_one_response(); ## Or run a large batch of commands in a pipeline my %hash = _get_large_batch_of_commands(); $redis->hset('h', $_, $hash{$_}, sub {}) for keys %hash; $redis->wait_all_responses; ## Publish/Subscribe $redis->subscribe( 'topic_1', 'topic_2', sub { my ($message, $topic, $subscribed_topic) = @_ ## $subscribed_topic can be different from topic if ## you use psubscribe() with wildcards } ); $redis->psubscribe('nasdaq.*', sub {...}); ## Blocks and waits for messages, calls subscribe() callbacks ## ... forever my $timeout = 10; $redis->wait_for_messages($timeout) while 1; ## ... until some condition my $keep_going = 1; ## other code will set to false to quit $redis->wait_for_messages($timeout) while $keep_going; $redis->publish('topic_1', 'message'); =head1 DESCRIPTION Pure perl bindings for L This version supports protocol 2.x (multi-bulk) or later of Redis available at L. This documentation lists commands which are exercised in test suite, but additional commands will work correctly since protocol specifies enough information to support almost all commands with same piece of code with a little help of C. =head1 PIPELINING Usually, running a command will wait for a response. However, if you're doing large numbers of requests, it can be more efficient to use what Redis calls I: send multiple commands to Redis without waiting for a response, then wait for the responses that come in. To use pipelining, add a coderef argument as the last argument to a command method call: $r->set('foo', 'bar', sub {}); Pending responses to pipelined commands are processed in a single batch, as soon as at least one of the following conditions holds: =over =item * A non-pipelined (synchronous) command is called on the same connection =item * A pub/sub subscription command (one of C, C, C, or C) is about to be called on the same connection. =item * One of L or L methods is called explicitly. =back The coderef you supply to a pipelined command method is invoked once the response is available. It takes two arguments, C<$reply> and C<$error>. If C<$error> is defined, it contains the text of an error reply sent by the Redis server. Otherwise, C<$reply> is the non-error reply. For almost all commands, that means it's C, or a defined but non-reference scalar, or an array ref of any of those; but see L, L, and L. Note the contrast with synchronous commands, which throw an exception on receipt of an error reply, or return a non-error reply directly. The fact that pipelined commands never throw an exception can be particularly useful for Redis transactions; see L. =head1 ENCODING There is no encoding feature anymore, it has been deprecated and finally removed. This module consider that any data sent to the Redis server is a raw octets string, even if it has utf8 flag set. And it doesn't do anything when getting data from the Redis server. So, do you pre-encoding or post-decoding operation yourself if needed ! =head1 METHODS =head2 Constructors =head3 new my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379 my $r = Redis->new( server => '192.168.0.1:6379', debug => 0 ); my $r = Redis->new( server => '192.168.0.1:6379', encoding => undef ); my $r = Redis->new( sock => '/path/to/sock' ); my $r = Redis->new( reconnect => 60, every => 5000 ); my $r = Redis->new( password => 'boo' ); my $r = Redis->new( on_connect => sub { my ($redis) = @_; ... } ); my $r = Redis->new( name => 'my_connection_name' ); my $r = Redis->new( name => sub { "cache-for-$$" }); 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 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. The C<< REDIS_SERVER >> can be used for UNIX domain sockets too. The following formats are supported: =over =item * /path/to/sock =item * unix:/path/to/sock =item * 127.0.0.1:11011 =item * tcp:127.0.0.1:11011 =back 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 default), up-to C<< reconnect >> seconds. Be aware that read errors will always thrown an exception, and will not trigger 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<< 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<< 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. 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 password is wrong, an exception will be thrown and reconnect will be disabled. You can also provide a code reference that will be immediately after each 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 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 CodeRef. If the latter, it will be called after each connection, with the Redis object, and it should return the connection name to use. If it returns a undefined value, Redis will not set the connection name. Please note that there are restrictions on the name you can set, the most important of which is, no spaces. See the L for all the juicy details. This feature is safe to use with all versions of Redis servers. If C<< CLIENT SETNAME >> support is not available (Redis servers 2.6.9 and above only), the name parameter is ignored. The C<< debug >> parameter enables debug information to STDERR, including all interactions with the server. You can also enable debug with the C environment variable. =head2 Connection Handling =head3 quit $r->quit; Closes the connection to the server. The C method does not support pipelined operation. =head3 ping $r->ping || die "no server?"; The C method does not support pipelined operation. =head3 client_list @clients = $r->client_list; Returns list of clients connected to the server. See L<< CLIENT LIST documentation|http://redis.io/commands/client-list >> for a description of the fields and their meaning. =head3 client_getname my $connection_name = $r->client_getname; Returns the name associated with this connection. See L or the C<< name >> parameter to L for ways to set this name. =head3 client_setname $r->client_setname('my_connection_name'); Sets this connection name. See the L for restrictions on the connection name string. The most important one: no spaces. =head2 Pipeline management =head3 wait_all_responses Waits until all pending pipelined responses have been received, and invokes the pipeline callback for each one. See L. =head3 wait_one_response Waits until the first pending pipelined response has been received, and invokes its callback. See L. =head2 Transaction-handling commands B the behaviour of these commands when combined with pipelining is still under discussion, and you should B use them at the same time just now. You can L. =head3 multi $r->multi; =head3 discard $r->discard; =head3 exec my @individual_replies = $r->exec; C has special behaviour when run in a pipeline: the C<$reply> argument to the pipeline callback is an array ref whose elements are themselves C<[$reply, $error]> pairs. This means that you can accurately detect errors yielded by any command in the transaction, and without any exceptions being thrown. =head2 Commands operating on string values =head3 set $r->set( foo => 'bar' ); $r->setnx( foo => 42 ); =head3 get my $value = $r->get( 'foo' ); =head3 mget my @values = $r->mget( 'foo', 'bar', 'baz' ); =head3 incr $r->incr('counter'); $r->incrby('tripplets', 3); =head3 decr $r->decr('counter'); $r->decrby('tripplets', 3); =head3 exists $r->exists( 'key' ) && print "got key!"; =head3 del $r->del( 'key' ) || warn "key doesn't exist"; =head3 type $r->type( 'key' ); # = string =head2 Commands operating on the key space =head3 keys my @keys = $r->keys( '*glob_pattern*' ); my $keys = $r->keys( '*glob_pattern*' ); # count of matching keys Note that synchronous C calls in a scalar context return the number of matching keys (not an array ref of matching keys as you might expect). This does not apply in pipelined mode: assuming the server returns a list of keys, as expected, it is always passed to the pipeline callback as an array ref. =head3 randomkey my $key = $r->randomkey; =head3 rename my $ok = $r->rename( 'old-key', 'new-key', $new ); =head3 dbsize my $nr_keys = $r->dbsize; =head2 Commands operating on lists See also L for tie interface. =head3 rpush $r->rpush( $key, $value ); =head3 lpush $r->lpush( $key, $value ); =head3 llen $r->llen( $key ); =head3 lrange my @list = $r->lrange( $key, $start, $end ); =head3 ltrim my $ok = $r->ltrim( $key, $start, $end ); =head3 lindex $r->lindex( $key, $index ); =head3 lset $r->lset( $key, $index, $value ); =head3 lrem my $modified_count = $r->lrem( $key, $count, $value ); =head3 lpop my $value = $r->lpop( $key ); =head3 rpop my $value = $r->rpop( $key ); =head2 Commands operating on sets =head3 sadd my $ok = $r->sadd( $key, $member ); =head3 scard my $n_elements = $r->scard( $key ); =head3 sdiff my @elements = $r->sdiff( $key1, $key2, ... ); my $elements = $r->sdiff( $key1, $key2, ... ); # ARRAY ref =head3 sdiffstore my $ok = $r->sdiffstore( $dstkey, $key1, $key2, ... ); =head3 sinter my @elements = $r->sinter( $key1, $key2, ... ); my $elements = $r->sinter( $key1, $key2, ... ); # ARRAY ref =head3 sinterstore my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... ); =head3 sismember my $bool = $r->sismember( $key, $member ); =head3 smembers my @elements = $r->smembers( $key ); my $elements = $r->smembers( $key ); # ARRAY ref =head3 smove my $ok = $r->smove( $srckey, $dstkey, $element ); =head3 spop my $element = $r->spop( $key ); =head3 srandmemeber my $element = $r->srandmember( $key ); =head3 srem $r->srem( $key, $member ); =head3 sunion my @elements = $r->sunion( $key1, $key2, ... ); my $elements = $r->sunion( $key1, $key2, ... ); # ARRAY ref =head3 sunionstore my $ok = $r->sunionstore( $dstkey, $key1, $key2, ... ); =head2 Commands operating on hashes Hashes in Redis cannot be nested as in perl, if you want to store a nested hash, you need to serialize the hash first. If you want to have a named hash, you can use Redis-hashes. You will find an example in the tests 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 Gets the value to a key in a hash. my $value = $r->hget('hashname', $key); =head3 hexists if($r->hexists('hashname', $key) { ## do something, the key exists } else { ## the key does not exist } =head3 hdel Deletes a key from a hash if($r->hdel('hashname', $key)) { ## key is deleted } else { ## oops } =head3 hincrby Adds an integer to a value. The integer is signed, so a negative integer decrements. my $key = 'testkey'; $r->hset('hashname', $key => 1); ## value -> 1 my $increment = 1; ## has to be an integer $r->hincrby('hashname', $key => $increment); ## value -> 2 $increment = 5; $r->hincrby('hashname', $key => $increment); ## value -> 7 $increment = -1; $r->hincrby('hashname', $key => $increment); ## value -> 6 =head3 hsetnx Adds a key to a hash unless it is not already set. my $key = 'testnx'; $r->hsetnx('hashname', $key => 1); ## returns true $r->hsetnx('hashname', $key => 2); ## returns false because key already exists =head3 hmset Adds multiple keys to a hash. $r->hmset('hashname', 'key1' => 'value1', 'key2' => 'value2'); ## returns true on success =head3 hmget Returns multiple keys of a hash. my @values = $r->hmget('hashname', 'key1', 'key2'); =head3 hgetall Returns the whole hash. my %hash = $r->hgetall('hashname'); =head3 hkeys Returns the keys of a hash. my @keys = $r->hkeys('hashname'); =head3 hvals Returns the values of a hash. my @values = $r->hvals('hashname'); =head3 hlen Returns the count of keys in a hash. my $keycount = $r->hlen('hashname'); =head2 Sorting =head3 sort $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA'); =head2 Publish/Subscribe commands When one of L or L is used, the Redis object will enter I mode. When in I mode only commands in this section, plus L, will be accepted. If you plan on using PubSub and other Redis functions, you should use two Redis 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 =item * The published message. =item * The topic over which the message was sent. =item * The subscribed topic that matched the topic for the message. With L these last two are the same, always. But with L, this parameter tells you the pattern that matched. =back See the L for more information about the messages you will receive on your callbacks after each L, L, L and L. =head3 publish $r->publish($topic, $message); Publishes the C<< $message >> to the C<< $topic >>. =head3 subscribe $r->subscribe( @topics_to_subscribe_to, sub { my ($message, $topic, $subscribed_topic) = @_; ... }, ); Subscribe one or more topics. Messages published into one of them will be received by Redis, and the specified callback will be executed. =head3 unsubscribe $r->unsubscribe(@topic_list, sub { my ($m, $t, $s) = @_; ... }); Stops receiving messages for all the topics in C<@topic_list>. =head3 psubscribe my @topic_matches = ('prefix1.*', 'prefix2.*'); $r->psubscribe(@topic_matches, sub { my ($m, $t, $s) = @_; ... }); Subscribes a pattern of topics. All messages to topics that match the pattern will be delivered to the callback. =head3 punsubscribe my @topic_matches = ('prefix1.*', 'prefix2.*'); $r->punsubscribe(@topic_matches, sub { my ($m, $t, $s) = @_; ... }); Stops receiving messages for all the topics pattern matches in C<@topic_list>. =head3 is_subscriber if ($r->is_subscriber) { say "We are in Pub/Sub mode!" } Returns true if we are in I mode. =head3 wait_for_messages my $keep_going = 1; ## Set to false somewhere to leave the loop my $timeout = 5; $r->wait_for_messages($timeout) while $keep_going; Blocks, waits for incoming messages and delivers them to the appropriate callbacks. Requires a single parameter, the number of seconds to wait for messages. Use 0 to wait for ever. If a positive non-zero value is used, it will return after that amount of seconds without a single notification. Please note that the timeout is not a commitment to return control to the caller at most each C seconds, but more a idle timeout, were control will return to the caller if Redis is idle (as in no messages were received during the timeout period) for more than C seconds. The L call returns the number of messages processed during the run. =head2 Persistence control commands =head3 save $r->save; =head3 bgsave $r->bgsave; =head3 lastsave $r->lastsave; =head2 Scripting commands =head3 eval $r->eval($lua_script, $num_keys, $key1, ..., $arg1, $arg2); Executes a Lua script server side. Note that this commands sends the Lua script every time you call it. See L and L for an alternative. =head3 evalsha $r->eval($lua_script_sha1, $num_keys, $key1, ..., $arg1, $arg2); Executes a Lua script cached on the server side by its SHA1 digest. See L. =head3 script_load my ($sha1) = $r->script_load($lua_script); Cache Lua script, returns SHA1 digest that can be used with L. =head3 script_exists my ($exists1, $exists2, ...) = $r->script_exists($scrip1_sha, $script2_sha, ...); Given a list of SHA1 digests, returns a list of booleans, one for each SHA1, that report the existence of each script in the server cache. =head3 script_kill $r->script_kill; Kills the currently running script. =head3 script_flush $r->script_flush; Flush the Lua scripts cache. =head2 Remote server control commands =head3 info my $info_hash = $r->info; The C method is unique in that it decodes the server's response into a hashref, if possible. This decoding happens in both synchronous and pipelined modes. =head3 shutdown $r->shutdown; The C method does not support pipelined operation. =head3 slowlog my $nr_items = $r->slowlog("len"); my @last_ten_items = $r->slowlog("get", 10); The C command gives access to the server's slow log. =head2 Multiple databases handling commands =head3 select $r->select( $dbindex ); # 0 for new clients =head3 move $r->move( $key, $dbindex ); =head3 flushdb $r->flushdb; =head3 flushall $r->flushall; =head1 ACKNOWLEDGEMENTS The following persons contributed to this project (alphabetical order): =over =item * Aaron Crane (pipelining and AUTOLOAD caching support) =item * Dirk Vleugels =item * Flavio Poletti =item * Jeremy Zawodny =item * sunnavy at bestpractical.com =item * Thiago Berlitz Rondon =item * Ulrich Habel =item * Ivan Kruglov =back =head1 AUTHORS =over 4 =item * Pedro Melo =item * Damien Krotkine =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 t000755000765000024 012257644644 12220 5ustar00damsstaff000000000000Redis-1.96701-basic.t100755000765000024 2447412257644644 14102 0ustar00damsstaff000000000000Redis-1.967/t#!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 } my $o; is( exception { $o = Redis->new(server => $srv, name => 'my_name_is_glorious') }, undef, 'connected to our test redis-server', ); ok($o->ping, 'ping'); ## Commands operating on string values ok($o->set(foo => 'bar'), 'set foo => bar'); ok(!$o->setnx(foo => 'bar'), 'setnx foo => bar fails'); cmp_ok($o->get('foo'), 'eq', 'bar', 'get foo = bar'); ok($o->set(foo => ''), 'set foo => ""'); cmp_ok($o->get('foo'), 'eq', '', 'get foo = ""'); ok($o->set(foo => 'baz'), 'set foo => baz'); cmp_ok($o->get('foo'), 'eq', 'baz', 'get foo = baz'); my $euro = "\x{20ac}"; ok($o->set(utf8 => $euro), 'set utf8'); use Encode; cmp_ok(Encode::decode_utf8($o->get('utf8')), 'eq', $euro, 'get utf8'); ok($o->set('test-undef' => 42), 'set test-undef'); ok($o->exists('test-undef'), 'exists undef'); # Big sized keys for my $size (10_000, 100_000, 500_000, 1_000_000, 2_500_000) { my $v = 'a' x $size; ok($o->set('big_key', $v), "set with value size $size ok"); is($o->get('big_key'), $v, "... and get was ok to"); } $o->del('non-existant'); ok(!$o->exists('non-existant'), 'exists non-existant'); ok(!defined $o->get('non-existant'), 'get non-existant'); my $key_next = 3; ok($o->set('key-next' => 0), 'key-next = 0'); ok($o->set('key-left' => $key_next), 'key-left'); is_deeply([$o->mget('foo', 'key-next', 'key-left')], ['baz', 0, 3], 'mget'); my @keys; foreach my $id (0 .. $key_next) { my $key = 'key-' . $id; push @keys, $key; ok($o->set($key => $id), "set $key"); ok($o->exists($key), "exists $key"); is($o->get($key), $id, "get $key"); cmp_ok($o->incr('key-next'), '==', $id + 1, 'incr'); cmp_ok($o->decr('key-left'), '==', $key_next - $id - 1, 'decr'); } is($o->get('key-next'), $key_next + 1, 'key-next'); ok($o->set('test-incrby', 0), 'test-incrby'); ok($o->set('test-decrby', 0), 'test-decry'); foreach (1 .. 3) { is($o->incrby('test-incrby', 3), $_ * 3, 'incrby 3'); is($o->decrby('test-decrby', 7), -($_ * 7), 'decrby 7'); } ok($o->del($_), "del $_") foreach map {"key-$_"} ('next', 'left'); ok(!$o->del('non-existing'), 'del non-existing'); cmp_ok($o->type('foo'), 'eq', 'string', 'type'); is($o->keys('key-*'), $key_next + 1, 'key-*'); is_deeply([sort $o->keys('key-*')], [sort @keys], 'keys'); ok(my $key = $o->randomkey, 'randomkey'); ok($o->rename('test-incrby', 'test-renamed'), 'rename'); ok($o->exists('test-renamed'), 'exists test-renamed'); eval { $o->rename('test-decrby', 'test-renamed', 1) }; ok($@, 'rename to existing key'); ok(my $nr_keys = $o->dbsize, 'dbsize'); like( exception { $o->lpush('foo', 'bar') }, qr/\[lpush\] (?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value,/, 'Error responses throw exception' ); ## Commands operating on lists my $list = 'test-list'; $o->del($list); ok($o->rpush($list => "r$_"), 'rpush') foreach (1 .. 3); ok($o->lpush($list => "l$_"), 'lpush') foreach (1 .. 2); cmp_ok($o->type($list), 'eq', 'list', 'type'); cmp_ok($o->llen($list), '==', 5, 'llen'); is_deeply([$o->lrange($list, 0, 1)], ['l2', 'l1'], 'lrange'); ok($o->ltrim($list, 1, 2), 'ltrim'); cmp_ok($o->llen($list), '==', 2, 'llen after ltrim'); cmp_ok($o->lindex($list, 0), 'eq', 'l1', 'lindex'); cmp_ok($o->lindex($list, 1), 'eq', 'r1', 'lindex'); ok($o->lset($list, 0, 'foo'), 'lset'); cmp_ok($o->lindex($list, 0), 'eq', 'foo', 'verified'); ok($o->lrem($list, 1, 'foo'), 'lrem'); cmp_ok($o->llen($list), '==', 1, 'llen after lrem'); cmp_ok($o->lpop($list), 'eq', 'r1', 'lpop'); ok(!$o->rpop($list), 'rpop'); ## Commands operating on sets my $set = 'test-set'; $o->del($set); ok($o->sadd($set, 'foo'), 'sadd'); ok(!$o->sadd($set, 'foo'), 'sadd'); cmp_ok($o->scard($set), '==', 1, 'scard'); ok($o->sismember($set, 'foo'), 'sismember'); cmp_ok($o->type($set), 'eq', 'set', 'type is set'); ok($o->srem($set, 'foo'), 'srem'); ok(!$o->srem($set, 'foo'), 'srem again'); cmp_ok($o->scard($set), '==', 0, 'scard'); $o->del($_) foreach qw( test-set1 test-set2 ); $o->sadd('test-set1', $_) foreach ('foo', 'bar', 'baz'); $o->sadd('test-set2', $_) foreach ('foo', 'baz', 'xxx'); my $inter = [sort('foo', 'baz')]; is_deeply([sort $o->sinter('test-set1', 'test-set2')], $inter, 'sinter'); ok($o->sinterstore('test-set-inter', 'test-set1', 'test-set2'), 'sinterstore'); cmp_ok($o->scard('test-set-inter'), '==', $#$inter + 1, 'cardinality of intersection'); is_deeply([$o->sdiff('test-set1', 'test-set2')], ['bar'], 'sdiff'); ok($o->sdiffstore(qw( test-set-diff test-set1 test-set2 )), 'sdiffstore'); is($o->scard('test-set-diff'), 1, 'cardinality of diff'); my @union = sort qw( foo bar baz xxx ); is_deeply([sort $o->sunion(qw( test-set1 test-set2 ))], \@union, 'sunion'); ok($o->sunionstore(qw( test-set-union test-set1 test-set2 )), 'sunionstore'); is($o->scard('test-set-union'), scalar(@union), 'cardinality of union'); my $first_rand = $o->srandmember('test-set-union'); ok(defined $first_rand, 'srandmember result is defined'); ok(scalar grep { $_ eq $first_rand } @union, 'srandmember'); my $second_rand = $o->spop('test-set-union'); ok(defined $first_rand, 'spop result is defined'); ok(scalar grep { $_ eq $second_rand } @union, 'spop'); is($o->scard('test-set-union'), scalar(@union) - 1, 'new cardinality of union'); $o->del('test_set3'); my @test_set3 = sort qw( foo bar baz ); $o->sadd('test-set3', $_) foreach @test_set3; is_deeply([sort $o->smembers('test-set3')], \@test_set3, 'smembers'); $o->del('test-set4'); $o->smove(qw( test-set3 test-set4 ), $_) foreach @test_set3; is($o->scard('test-set3'), 0, 'repeated smove depleted source'); is($o->scard('test-set4'), scalar(@test_set3), 'repeated smove populated destination'); is_deeply([sort $o->smembers('test-set4')], \@test_set3, 'smembers'); ## Commands operating on zsets (sorted sets) # TODO: ZUNIONSTORE, ZINTERSTORE, SORT, tests w/multiple values having the same score my $zset = 'test-zset'; $o->del($zset); ok($o->zadd($zset, 0, 'foo')); ok(!$o->zadd($zset, 1, 'foo')); # 0 returned because foo is already in the set is($o->zscore($zset, 'foo'), 1); ok($o->zincrby($zset, 1, 'foo')); 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 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 is_deeply([$o->zrange($zset, 0, 1)], [qw/bar foo/]); is_deeply([$o->zrevrange($zset, 0, 1)], [qw/baz foo/]); my $withscores = { $o->zrevrange($zset, 0, 1, 'WITHSCORES') }; # this uglyness gets around floating point weirdness in the return (I.E. 2.1000000000000001); my $rounded_withscores = { map { $_ => 0 + sprintf("%0.5f", $withscores->{$_}) } keys %$withscores }; is_deeply($rounded_withscores, { baz => 2.1, foo => 2 }); is_deeply([$o->zrangebyscore($zset, 2, 3)], [qw/foo baz/]); is($o->zcount($zset, 2, 3), 2); is($o->zcard($zset), 3); ok($o->del($zset)); # cleanup my $score = 0.1; 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 is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]); is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[2 .. 4]]); # only left with 3 is($o->zcard($zset), 3); ok($o->del($zset)); # cleanup ## Commands operating on hashes my $hash = 'test-hash'; $o->del($hash); ok($o->hset($hash, foo => 'bar')); is($o->hget($hash, 'foo'), 'bar'); ok($o->hexists($hash, 'foo')); ok($o->hdel($hash, 'foo')); ok(!$o->hexists($hash, 'foo')); ok($o->hincrby($hash, incrtest => 1)); is($o->hget($hash, 'incrtest'), 1); is($o->hincrby($hash, incrtest => -1), 0); is($o->hget($hash, 'incrtest'), 0); ok($o->hdel($hash, 'incrtest')); #cleanup ok($o->hsetnx($hash, setnxtest => 'baz')); ok(!$o->hsetnx($hash, setnxtest => 'baz')); # already exists, 0 returned ok($o->hdel($hash, 'setnxtest')); #cleanup ok($o->hmset($hash, foo => 1, bar => 2, baz => 3, qux => 4)); is_deeply([$o->hmget($hash, qw/foo bar baz/)], [1, 2, 3]); is($o->hlen($hash), 4); is_deeply([$o->hkeys($hash)], [qw/foo bar baz qux/]); 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 ok($o->select(1), 'select'); ok($o->select(0), 'select'); ok($o->move('foo', 1), 'move'); ok(!$o->exists('foo'), 'gone'); ok($o->select(1), 'select'); ok($o->exists('foo'), 'exists'); ok($o->flushdb, 'flushdb'); cmp_ok($o->dbsize, '==', 0, 'empty'); ## Sorting ok($o->lpush('test-sort', $_), "put $_") foreach (1 .. 4); cmp_ok($o->llen('test-sort'), '==', 4, 'llen'); is_deeply([$o->sort('test-sort')], [1, 2, 3, 4], 'sort'); is_deeply([$o->sort('test-sort', 'DESC')], [4, 3, 2, 1], 'sort DESC'); ## "Persistence control commands" ok($o->save, 'save'); ok($o->bgsave, 'bgsave'); ok($o->lastsave, 'lastsave'); #ok( $o->shutdown, 'shutdown' ); ## Remote server control commands ok(my $info = $o->info, 'info'); isa_ok($info, 'HASH', '... yields a hash'); ok(keys %$info, '... nonempty'); unlike(join("\n", keys %$info), qr/#/, '... with no comments in the keys'); unlike(join("\n", keys %$info), qr/\n\n|\A\n|\n\z/, '... with no blank lines in the keys'); ## Connection handling ok($o->ping, 'ping() is true'); ok($o->quit, 'quit'); ok(!$o->quit, 'quit again, ok'); ok(!$o->ping, '... but after quit() returns false'); $o = Redis->new(server => $srv); ok($o->shutdown(), 'shutdown() once is ok'); ok(!$o->shutdown(), '... twice also lives, but returns false'); ok(!$o->ping(), 'ping() will be false after shutdown()'); sleep(1); like( exception { Redis->new(server => $srv) }, qr/Could not connect to Redis server at $srv/, 'Failed connection throws exception' ); ## All done done_testing(); 03-pubsub.t100755000765000024 2165212257644644 14316 0ustar00damsstaff000000000000Redis-1.967/t#!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 Test::Deep; use Redis; use lib 't/tlib'; use Test::SpawnRedisServer qw( redis reap ); my ($c, $srv) = redis(); END { $c->() if $c } my ($another_kill_switch, $yet_another_kill_switch); END { $_ and $_->() for($another_kill_switch, $yet_another_kill_switch) } subtest 'basics' => sub { my %got; ok(my $pub = Redis->new(server => $srv), 'connected to our test redis-server (pub)'); ok(my $sub = Redis->new(server => $srv), 'connected to our test redis-server (sub)'); is($pub->publish('aa', 'v1'), 0, "No subscribers to 'aa' topic"); my $db_size = -1; $sub->dbsize(sub { $db_size = $_[0] }); ## Basic pubsub my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; $sub->subscribe('aa', 'bb', $sub_cb); is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); is($db_size, 0, 'subscribing processes pending queued commands'); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'aa' => 'v1:aa' }, "... for the expected topic, 'aa'"); my $sub_cb2 = sub { my ($v, $t, $s) = @_; $got{"2$s"} = uc("$v:$t") }; $sub->subscribe('aa', $sub_cb2); is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'aa' => 'v1:aa', '2aa' => 'V1:AA' }, "... for the expected topic, 'aa', with two handlers"); ## Trick subscribe with other messages my $psub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; %got = (); is($pub->publish('aa', 'v2'), 1, "Delivered to 1 subscriber of topic 'aa'"); $sub->psubscribe('a*', 'c*', $psub_cb); cmp_deeply( \%got, { 'aa' => 'v2:aa', '2aa' => 'V2:AA' }, '... received message while processing psubscribe(), two handlers' ); is($pub->publish('aa', 'v3'), 2, "Delivered to 2 subscriber of topic 'aa'"); is($sub->wait_for_messages(1), 2, '... yep, got the expected 2 messages'); cmp_deeply( \%got, { 'aa' => 'v3:aa', 'a*' => 'v3:aa', '2aa' => 'V3:AA' }, "... for the expected subs, 'aa' and 'a*', three handlers total" ); ## Test subscribe/psubscribe diffs %got = (); is($pub->publish('aaa', 'v4'), 1, "Delivered to 1 subscriber of topic 'aaa'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*' => 'v4:aaa' }, "... for the expected sub, 'a*'"); ## Subscriber mode status is($sub->is_subscriber, 4, 'Current subscriber has 4 subscriptions active'); is($pub->is_subscriber, 0, '... the publisher has none'); ## Unsubscribe $sub->unsubscribe('xx', sub { }); is($sub->is_subscriber, 4, "No match to our subscriptions, unsubscribe doesn't change active count"); $sub->unsubscribe('aa', $sub_cb); is($sub->is_subscriber, 4, "unsubscribe ok, active count is still 4, another handler is alive"); $sub->unsubscribe('aa', $sub_cb2); is($sub->is_subscriber, 3, "unsubscribe done, active count is now 3, both handlers are done"); $pub->publish('aa', 'v5'); %got = (); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*', 'v5:aa' }, "... for the expected key, 'a*'"); $sub->unsubscribe('a*', $psub_cb); is($sub->is_subscriber, 3, "unsubscribe with topic wildcard failed, active count is now 3"); $pub->publish('aa', 'v6'); %got = (); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*', 'v6:aa' }, "... for the expected key, 'a*'"); $sub->unsubscribe('bb', $sub_cb); is($sub->is_subscriber, 2, "unsubscribe with 'bb' ok, active count is now 2"); $sub->punsubscribe('a*', $psub_cb); is($sub->is_subscriber, 1, "punsubscribe with 'a*' ok, active count is now 1"); is($pub->publish('aa', 'v6'), 0, "Publish to 'aa' now gives 0 deliveries"); %got = (); is($sub->wait_for_messages(1), 0, '... yep, no messages delivered'); cmp_deeply(\%got, {}, '... and an empty messages recorded set'); is($sub->is_subscriber, 1, 'Still some pending subcriptions active'); for my $cmd (qw) { like( exception { $sub->$cmd }, qr/Cannot use command '(?i:$cmd)' while in SUBSCRIBE mode/, ".. still an error to try \U$cmd\E while in SUBSCRIBE mode" ); } $sub->punsubscribe('c*', $psub_cb); is($sub->is_subscriber, 0, '... but none anymore'); is(exception { $sub->info }, undef, 'Other commands ok after we leave subscriber_mode'); }; subtest 'server is killed while waiting for subscribe' => sub { my ($another_kill_switch, $another_server) = redis(); my $pid = fork(); BAIL_OUT("Fork failed, aborting") unless defined $pid; if ($pid) { ## parent, we'll wait for the child to die quickly ok(my $sync = Redis->new(server => $srv), 'connected to our test redis-server (sync parent)'); BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); ok($another_kill_switch->(), "pub/sub redis server killed"); diag("parent killed pub/sub redis server, signal child to proceed"); $sync->lpush('wake_up_child', 'the redis-server is dead, do your thing'); diag("parent waiting for child $pid..."); my $failed = reap($pid, 5); if ($failed) { fail("wait_for_messages() hangs when the server goes away..."); kill(9, $pid); reap($pid) and fail('... failed to reap the dead child'); } else { pass("wait_for_messages() properly detects a server that dies"); } } else { ## child my $sync = Redis->new(server => $srv); my $sub = Redis->new(server => $another_server); $sub->subscribe('chan', sub { }); diag("child is ready to test, signal parent to kill our server"); $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); ## This is the test, next wait_for_messages() should not block diag("now, check wait_for_messages(), should die..."); like( exception { $sub->wait_for_messages(0) }, qr/EOF from server/, "properly died with EOF" ); exit(0); } }; subtest 'server is restarted while waiting for subscribe' => sub { my @ret = redis(); my ($another_kill_switch, $another_server) = @ret; my $port = pop @ret; my $pid = fork(); BAIL_OUT("Fork failed, aborting") unless defined $pid; if ($pid) { ## parent, we'll wait for the child to die quickly ok(my $sync = Redis->new(server => $srv), 'PARENT: connected to our test redis-server (sync parent)'); BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); ok($another_kill_switch->(), "PARENT: pub/sub redis server killed"); diag("PARENT: killed pub/sub redis server, signal child to proceed"); $sync->lpush('wake_up_child', 'the redis-server is dead, waiting before respawning it'); sleep 5; # relaunch it on the same port my ($yet_another_kill_switch) = redis(port => $port); my $pub = Redis->new(server => $another_server); diag("PARENT: has relaunched the server..."); sleep 5; is($pub->publish('chan', 'v1'), 1, "PARENT: published and the child is subscribed"); diag("PARENT: waiting for child $pid..."); my $failed = reap($pid, 5); if ($failed) { fail("PARENT: wait_for_messages() hangs when the server goes away..."); kill(9, $pid); reap($pid) and fail('PARENT: ... failed to reap the dead child'); } else { pass("PARENT: child has properly quit after wait_for_messages()"); } ok($yet_another_kill_switch->(), "PARENT: pub/sub redis server killed"); } else { ## child my $sync = Redis->new(server => $srv); my $sub = Redis->new(server => $another_server, reconnect => 10, on_connect => sub { diag "CHILD: reconnected (with a 10s timeout)"; } ); my %got; $sub->subscribe('chan', sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }); diag("CHILD: is ready to test, signal parent to restart our server"); $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); ## This is the test, wait_for_messages() should reconnect to the respawned server while (1) { diag("CHILD: launch wait_for_messages(2), with reconnect..."); my $r = $sub->wait_for_messages(2); $r and last; diag("CHILD: after 2 sec, nothing yet, retrying"); } diag("CHILD: child received the message"); cmp_deeply(\%got, { 'chan' => 'v1:chan' }, "CHILD: the message is what we want"); exit(0); } }; ## And we are done done_testing(); 11-timeout.t100644000765000024 231112257644644 14447 0ustar00damsstaff000000000000Redis-1.967/t#!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); 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", ); }; done_testing; 30-scripts.t100755000765000024 240412257644644 14457 0ustar00damsstaff000000000000Redis-1.967/t#!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 Redis; use lib 't/tlib'; use Test::SpawnRedisServer; use Digest::SHA qw(sha1_hex); my ($c, $srv) = redis(); END { $c->() if $c } my $o = Redis->new(server => $srv); ## Make sure SCRIPT commands are available eval { $o->script_flush }; if ($@ && $@ =~ /ERR unknown command 'SCRIPT',/) { $c->(); plan skip_all => 'This redis-server lacks scripting support'; } ## Commands related to Lua scripting # Specifically, these commands test multi-word commands ok($o->set(foo => 'bar'), 'set foo => bar'); my $script = "return 1"; my $script_sha = sha1_hex($script); my @ret = $o->script_exists($script_sha); ok(@ret && $ret[0] == 0, "script exists returns false"); @ret = $o->script_load($script); ok(@ret && $ret[0] eq $script_sha, "script load returns the sha1 of the script"); ok($o->script_exists($script_sha), "script exists returns true after loading"); ok($o->evalsha($script_sha, 0), "evalsha returns true with the sha1 of the script"); ok($o->eval($script, 0), "eval returns true"); ## All done done_testing(); 00-compile.t100644000765000024 175412257644644 14421 0ustar00damsstaff000000000000Redis-1.967/tuse strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.037 use Test::More tests => 3 + ($ENV{AUTHOR_TESTING} ? 1 : 0); my @module_files = ( 'Redis.pm', 'Redis/Hash.pm', 'Redis/List.pm' ); # no fake home requested my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; use File::Spec; use IPC::Open3; use IO::Handle; my @warnings; for my $lib (@module_files) { # see L open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my $stderr = IO::Handle->new; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') if $ENV{AUTHOR_TESTING}; 04-pipeline.t100755000765000024 1047712257644644 14627 0ustar00damsstaff000000000000Redis-1.967/t#!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; use Test::Deep; my ($c, $srv) = redis(); END { $c->() if $c } ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); sub pipeline_ok { my ($desc, @commands) = @_; my (@responses, @expected_responses); for my $cmd (@commands) { my ($method, $args, $expected, $expected_err) = @$cmd; push @expected_responses, [$expected, $expected_err]; $r->$method(@$args, sub { push @responses, [@_] }); } $r->wait_all_responses; cmp_deeply(\@responses, \@expected_responses, $desc); } pipeline_ok 'single-command pipeline', ([set => [foo => 'bar'], 'OK'],); pipeline_ok 'pipeline with embedded error', ([set => [clunk => 'eth'], 'OK'], [oops => [], undef, q[ERR unknown command 'OOPS']], [get => ['clunk'], 'eth'],); pipeline_ok 'keys in pipelined mode', ([keys => ['*'], bag(qw)], [keys => [], undef, q[ERR wrong number of arguments for 'keys' command]],); pipeline_ok 'info in pipelined mode', ( [info => [], code(sub { ref $_[0] eq 'HASH' && keys %{ $_[0] } })], [ info => [qw], undef, re(qr{^ERR (?:syntax error|wrong number of arguments for 'info' command)$}) ], ); pipeline_ok 'pipeline with multi-bulk reply', ([hmset => [kapow => (a => 1, b => 2, c => 3)], 'OK'], [hmget => [kapow => qw], [3, 2, 1]],); pipeline_ok 'large pipeline', ( (map { [hset => [zzapp => $_ => -$_], 1] } 1 .. 5000), [hmget => [zzapp => (1 .. 5000)], [reverse -5000 .. -1]], [del => ['zzapp'], 1], ); subtest 'synchronous request with pending pipeline' => sub { my $clunk; is($r->get('clunk', sub { $clunk = $_[0] }), 1, 'queue a request'); is($r->set('kapow', 'zzapp', sub { }), 1, 'queue another request'); is($r->get('kapow'), 'zzapp', 'synchronous request has expected return'); is($clunk, 'eth', 'synchronous request processes pending ones'); }; 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'); is($r->set('clunk', 'eth'), 'QUEUED', 'transactional SET'); is($r->rpush('clunk', 'oops'), 'QUEUED', 'transactional bad RPUSH'); is($r->get('clunk'), 'QUEUED', 'transactional GET'); like( exception { $r->exec }, qr{\[exec\] (?:WRONGTYPE|ERR) Operation against a key holding the wrong kind of value,}, 'synchronous EXEC dies for intervening error' ); }; subtest 'wait_one_response' => sub { my $first; my $second; $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->wait_one_response(); is($first, 1, 'after first wait_one_response(), first callback called'); is($second, undef, '... but not the second one'); $r->wait_one_response(); is($first, 1, 'after second wait_one_response(), first callback was not called again'); is($second, 1, '... but the second one was called'); $r->wait_all_responses(); is($first, 2, 'after final wait_all_responses(), first callback was called again'); is($second, 2, '... the second one was also called'); $r->wait_one_response(); is($first, 2, 'after final wait_one_response(), first callback was not called again'); is($second, 2, '... nor was the second one'); }; done_testing(); 05-nonblock.t100644000765000024 233712257644644 14601 0ustar00damsstaff000000000000Redis-1.967/t#!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 Redis; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } subtest 'non-block TCP' => sub { ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server via TCP'); ## Try to read from server (nothing sent, so nothing to read) ## 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"); alarm(0); }; subtest 'non-block UNIX' => sub { plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' unless $ENV{TEST_REDIS_SERVER_SOCK_PATH}; ok(my $r = Redis->new(sock => $ENV{TEST_REDIS_SERVER_SOCK_PATH}), 'connected to our test redis-server via UNIX'); ## Try to read from server (nothing sent, so nothing to read) ## 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"); alarm(0); }; done_testing(); 10-tie-list.t100755000765000024 354312257644644 14525 0ustar00damsstaff000000000000Redis-1.967/t#!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 Redis::List; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ## Setup my @my_list; ok(my $redis = tie(@my_list, 'Redis::List', 'my_list', server => $srv), 'tied to our test redis-server'); ok($redis->ping, 'pinged fine'); isa_ok($redis, 'Redis::List'); ## Direct access subtest 'direct access' => sub { @my_list = (); is_deeply(\@my_list, [], 'empty list ok'); @my_list = ('foo', 'bar', 'baz'); is_deeply(\@my_list, ['foo', 'bar', 'baz'], 'Set multiple values ok'); $my_list[1] = 'BAR'; is_deeply(\@my_list, ['foo', 'BAR', 'baz'], 'Set single value ok'); is($my_list[2]++, 'baz', 'get single value ok'); is(++$my_list[2], 'bbb', '... even with post/pre-increments'); }; ## List functions subtest 'list functions' => sub { my $v; ok($v = shift(@my_list), 'shift ok'); is($v, 'foo', '... expected value'); is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); ok(push(@my_list, $v), 'push ok'); is_deeply(\@my_list, ['BAR', 'bbb', 'foo'], '... resulting list as expected'); ok($v = pop(@my_list), 'pop ok'); is($v, 'foo', '... expected value'); is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); ok(unshift(@my_list, $v), 'unshift ok'); is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... resulting list as expected'); ok(my @s = splice(@my_list, 1, 2), 'splice ok'); is_deeply([@s], ['BAR', 'bbb'], '... resulting list as expected'); is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... original list as expected'); }; ## Cleanup @my_list = (); is_deeply(\@my_list, [], 'empty list ok'); done_testing(); 20-tie-hash.t100755000765000024 304212257644644 14470 0ustar00damsstaff000000000000Redis-1.967/t#!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::Deep; use Redis::Hash; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ## Setup my %my_hash; ok(my $redis = tie(%my_hash, 'Redis::Hash', 'my_hash', server => $srv), 'tied to our test redis-server'); ok($redis->ping, 'pinged fine'); isa_ok($redis, 'Redis::Hash'); ## Direct access subtest 'direct access' => sub { %my_hash = (); cmp_deeply(\%my_hash, {}, 'empty list ok'); %my_hash = (a => 'foo', b => 'bar', c => 'baz'); cmp_deeply(\%my_hash, { a => 'foo', b => 'bar', c => 'baz' }, 'Set multiple values ok'); $my_hash{b} = 'BAR'; cmp_deeply(\%my_hash, { a => 'foo', b => 'BAR', c => 'baz' }, 'Set single value ok'); is($my_hash{c}++, 'baz', 'get single value ok'); is(++$my_hash{c}, 'bbb', '... even with post/pre-increments'); }; ## Hash functions subtest 'hash functions' => sub { ok(my @keys = keys(%my_hash), 'keys ok'); cmp_deeply(\@keys, bag(qw( a b c )), '... resulting list as expected'); ok(my @values = values(%my_hash), 'values ok'); cmp_deeply(\@values, bag(qw( foo BAR bbb )), '... resulting list as expected'); %my_hash = reverse %my_hash; cmp_deeply(\%my_hash, { foo => 'a', BAR => 'b', bbb => 'c' }, 'reverse() worked'); }; ## Cleanup %my_hash = (); cmp_deeply(\%my_hash, {}, 'empty list ok'); done_testing(); 02-responses.t100755000765000024 462112257644644 15013 0ustar00damsstaff000000000000Redis-1.967/t#!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 Test::Deep; use IO::String; use Redis; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); sub r { $r->{sock} = IO::String->new(join('', map {"$_\r\n"} @_)); } ## -ERR responses r('-you must die!!'); is_deeply([$r->__read_response('cmd')], [undef, 'you must die!!'], 'Error response detected'); ## +TEXT responses my $m; r('+all your text are belong to us'); is_deeply([$r->__read_response('cmd')], ['all your text are belong to us', undef], 'Text response ok'); ## :NUMBER responses r(':234'); is_deeply([$r->__read_response('cmd')], [234, undef], 'Integer response ok'); ## $SIZE PAYLOAD responses r('$19', "Redis\r\nis\r\ngreat!\r\n"); is_deeply([$r->__read_response('cmd')], ["Redis\r\nis\r\ngreat!\r\n", undef], 'Size+payload response ok'); r('$0', ""); is_deeply([$r->__read_response('cmd')], ['', undef], 'Zero-size+payload response ok'); r('$-1'); is_deeply([$r->__read_response('cmd')], [undef, undef], 'Negative-size+payload response ok'); ## Multi-bulk responses my @m; r('*4', '$5', 'Redis', ':42', '$-1', '+Cool stuff'); cmp_deeply([$r->__read_response('cmd')], [['Redis', 42, undef, 'Cool stuff'], undef], 'Simple multi-bulk response ok'); ## Nested Multi-bulk responses r('*5', '$5', 'Redis', ':42', '*4', ':1', ':2', '$4', 'hope', '*2', ':4', ':5', '$-1', '+Cool stuff'); cmp_deeply( [$r->__read_response('cmd')], [['Redis', 42, [1, 2, 'hope', [4, 5]], undef, 'Cool stuff'], undef], 'Nested multi-bulk response ok' ); ## Nil multi-bulk responses r('*-1'); is_deeply([$r->__read_response('cmd')], [undef, undef], 'Read a NIL multi-bulk response'); ## Multi-bulk responses with nested error r('*3', '$5', 'Redis', '-you must die!!', ':42'); like( exception { $r->__read_response('cmd') }, qr/\[cmd\] you must die!!/, 'Nested errors must usually throw exceptions' ); r('*3', '$5', 'Redis', '-you must die!!', ':42'); is_deeply( [$r->__read_response('cmd', 1)], [[['Redis', undef], [undef, 'you must die!!'], [42, undef]], undef,], 'Nested errors must be collected in collect-errors mode' ); done_testing(); 07-reconnect.t100755000765000024 735012257644644 14761 0ustar00damsstaff000000000000Redis-1.967/t#!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 Time::HiRes qw(gettimeofday tv_interval); use Redis; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(timeout => 1); END { $c->() if $c } subtest 'Command without connection, no reconnect' => sub { ok(my $r = Redis->new(reconnect => 0, server => $srv), 'connected to our test redis-server'); ok($r->quit, 'close connection to the server'); like(exception { $r->set(reconnect => 1) }, qr{Not connected to any server}, 'send ping without reconnect',); }; subtest 'Command without connection or timeout, with database change, with reconnect' => sub { ok(my $r = Redis->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->select(4), 'send command with reconnect'); ok($r->set(reconnect => $$), 'send command with reconnect'); ok($r->quit, 'close connection to the server'); is($r->get('reconnect'), $$, 'reconnect with read errors before write'); }; subtest 'Reconnection discards pending commands' => sub { ok(my $r = Redis->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); my $processed_pending = 0; $r->dbsize(sub { $processed_pending++ }); ok(close(delete $r->{sock}), 'evilly close connection to the server'); ok($r->set(foo => 'bar'), 'send command with reconnect'); is($processed_pending, 0, 'pending command discarded on reconnect'); }; subtest 'INFO commands with extra logic triggers reconnect' => sub { ok(my $r = Redis->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->quit, 'close connection to the server'); my $info = $r->info; is(ref $info, 'HASH', 'reconnect on INFO command'); }; subtest 'KEYS commands with extra logic triggers reconnect' => sub { ok(my $r = Redis->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->flushdb, 'delete all keys'); ok($r->set(reconnect => $$), 'set known key'); ok($r->quit, 'close connection to the server'); my @keys = $r->keys('*'); is_deeply(\@keys, ['reconnect'], 'reconnect on KEYS command'); }; subtest "Bad commands don't trigger reconnect" => sub { ok(my $r = Redis->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); my $prev_sock = "$r->{sock}"; like( exception { $r->set(bad => reconnect => 1) }, qr{ERR wrong number of arguments for 'set' command|ERR syntax error}, 'Bad commands still die', ); is("$r->{sock}", $prev_sock, "... and don't trigger a reconnect"); }; subtest 'Reconnect code clears sockect ASAP' => sub { ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); _wait_for_redis_timeout(); is(exception { $r->quit }, undef, "Quit doesn't die if we are already disconnected"); }; subtest "Reconnect gives up after timeout" => sub { ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); $c->(); ## Make sure the server is dead my $t0 = [gettimeofday]; like( exception { $r->set(reconnect => 1) }, qr{Could not connect to Redis server at}, 'Eventually it gives up and dies', ); ok(tv_interval($t0) > 3, '... minimum value for the reconnect reached'); }; done_testing(); sub _wait_for_redis_timeout { ## Redis will timeout clients after 100 internal server loops, at ## least 10 seconds (even with a timeout 1 on the config) so we sleep ## a bit more hoping the timeout did happen. Not perfect, patches ## welcome diag('Sleeping 11 seconds, waiting for Redis to timeout...'); sleep(11); } 50-fork_safe.t100644000765000024 135112257644644 14726 0ustar00damsstaff000000000000Redis-1.967/tuse strict; use warnings; use Test::More; use Redis; use lib 't/tlib'; use Test::SpawnRedisServer; use Test::SharedFork; my ($c, $srv) = redis(); END { $c->() if $c } my $o = Redis->new(server => $srv, name => 'my_name_is_glorious'); is $o->info->{connected_clients}, 1; my $localport = $o->{sock}->sockport; note "fork safe"; { if (my $pid = fork) { $o->incr("test-fork"); is $o->{sock}->sockport, $localport, "same port on parent"; waitpid($pid, 0); } else { $o->incr("test-fork"); isnt $o->{sock}->sockport, $localport, "different port on child"; is $o->info->{connected_clients}, 2, "2 clients connected"; exit 0; } is $o->get('test-fork'), 2; }; done_testing; Redis000755000765000024 012257644644 13571 5ustar00damsstaff000000000000Redis-1.967/libHash.pm100644000765000024 465212257644644 15161 0ustar00damsstaff000000000000Redis-1.967/lib/Redis# # 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::Hash; { $Redis::Hash::VERSION = '1.967'; } # ABSTRACT: tie Perl hashes to Redis hashes # VERSION # AUTHORITY use strict; use warnings; use Tie::Hash; use base qw/Redis Tie::StdHash/; sub TIEHASH { my ($class, $prefix, @rest) = @_; my $self = $class->new(@rest); $self->{prefix} = $prefix ? "$prefix:" : ''; return $self; } sub STORE { my ($self, $key, $value) = @_; $self->set($self->{prefix} . $key, $value); } sub FETCH { my ($self, $key) = @_; $self->get($self->{prefix} . $key); } sub FIRSTKEY { my $self = shift; $self->{prefix_keys} = [$self->keys($self->{prefix} . '*')]; $self->NEXTKEY; } sub NEXTKEY { my $self = shift; my $key = shift @{ $self->{prefix_keys} }; return unless defined $key; my $p = $self->{prefix}; $key =~ s/^$p// if $p; return $key; } sub EXISTS { my ($self, $key) = @_; $self->exists($self->{prefix} . $key); } sub DELETE { my ($self, $key) = @_; $self->del($self->{prefix} . $key); } sub CLEAR { my ($self) = @_; $self->del($_) for $self->keys($self->{prefix} . '*'); $self->{prefix_keys} = []; } 1; ## End of Redis::Hash __END__ =pod =head1 NAME Redis::Hash - tie Perl hashes to Redis hashes =head1 VERSION version 1.967 =head1 DESCRIPTION Ties a Perl hash to Redis. Note that it doesn't use Redis Hashes, but implements a fake hash using regular keys like "prefix:KEY". If no C is given, it will tie the entire Redis database as a hash. Future versions will also allow you to use real Redis hash structures. =head1 SYNOPSYS ## Create fake hash using keys like 'hash_prefix:KEY' tie %my_hash, 'Redis::Hash', 'hash_prefix', @Redis_new_parameters; ## Treat the entire Redis database as a hash tie %my_hash, 'Redis::Hash', undef, @Redis_new_parameters; $value = $my_hash{$key}; $my_hash{$key} = $value; @keys = keys %my_hash; @values = values %my_hash; %my_hash = reverse %my_hash; %my_hash = (); =head1 AUTHORS =over 4 =item * Pedro Melo =item * Damien Krotkine =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 List.pm100644000765000024 453212257644644 15206 0ustar00damsstaff000000000000Redis-1.967/lib/Redis# # 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::List; { $Redis::List::VERSION = '1.967'; } # ABSTRACT: tie Perl arrays to Redis lists # VERSION # AUTHORITY use strict; use warnings; use base qw/Redis Tie::Array/; sub TIEARRAY { my ($class, $list, @rest) = @_; my $self = $class->new(@rest); $self->{list} = $list; return $self; } sub FETCH { my ($self, $index) = @_; $self->lindex($self->{list}, $index); } sub FETCHSIZE { my ($self) = @_; $self->llen($self->{list}); } sub STORE { my ($self, $index, $value) = @_; $self->lset($self->{list}, $index, $value); } sub STORESIZE { my ($self, $count) = @_; $self->ltrim($self->{list}, 0, $count); # if $count > $self->FETCHSIZE; } sub CLEAR { my ($self) = @_; $self->del($self->{list}); } sub PUSH { my $self = shift; my $list = $self->{list}; $self->rpush($list, $_) for @_; } sub POP { my $self = shift; $self->rpop($self->{list}); } sub SHIFT { my ($self) = @_; $self->lpop($self->{list}); } sub UNSHIFT { my $self = shift; my $list = $self->{list}; $self->lpush($list, $_) for @_; } sub SPLICE { my ($self, $offset, $length) = @_; $self->lrange($self->{list}, $offset, $length); # FIXME rest of @_ ? } sub EXTEND { my ($self, $count) = @_; $self->rpush($self->{list}, '') for ($self->FETCHSIZE .. ($count - 1)); } sub DESTROY { $_[0]->quit } 1; ## End of Redis::List __END__ =pod =head1 NAME Redis::List - tie Perl arrays to Redis lists =head1 VERSION version 1.967 =head1 SYNOPSYS tie @my_list, 'Redis::List', 'list_name', @Redis_new_parameters; $value = $my_list[$index]; $my_list[$index] = $value; $count = @my_list; push @my_list, 'values'; $value = pop @my_list; unshift @my_list, 'values'; $value = shift @my_list; ## NOTE: fourth parameter of splice is *NOT* supported for now @other_list = splice(@my_list, 2, 3); @my_list = (); =head1 AUTHORS =over 4 =item * Pedro Melo =item * Damien Krotkine =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 06-on-connect.t100644000765000024 217512257644644 15040 0ustar00damsstaff000000000000Redis-1.967/t#!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(timeout => 1); END { $c->() if $c } subtest 'on_connect' => sub { my $r; ok($r = Redis->new(server => $srv, on_connect => sub { shift->incr('on_connect') }), 'connected to our test redis-server'); is($r->get('on_connect'), 1, '... on_connect code was run'); ok($r = Redis->new(server => $srv, on_connect => sub { shift->incr('on_connect') }), 'new connection is up and running'); is($r->get('on_connect'), 2, '... on_connect code was run again'); ok($r = Redis->new(reconnect => 1, server => $srv, on_connect => sub { shift->incr('on_connect') }), 'new connection with reconnect enabled'); is($r->get('on_connect'), 3, '... on_connect code one again perfect'); $r->quit; is($r->get('on_connect'), 4, '... on_connect code works after reconnect also'); }; done_testing(); scripts000755000765000024 012257644644 13444 5ustar00damsstaff000000000000Redis-1.967publish.pl100755000765000024 101012257644644 15602 0ustar00damsstaff000000000000Redis-1.967/scripts#!/usr/bin/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 Redis; my $pub = Redis->new(); my $channel = $ARGV[0] || die "usage: $0 channel\n"; print "#$channel > "; while () { chomp; $channel = $1 if s/\s*\#(\w+)\s*//; # remove channel from message my $nr = $pub->publish($channel, $_); print "#$channel $nr> "; } 08-unix-socket.t100644000765000024 237712257644644 15254 0ustar00damsstaff000000000000Redis-1.967/t#!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; plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' unless $ENV{TEST_REDIS_SERVER_SOCK_PATH}; my $conn = sub { my @args = @_; my $r; is( exception { $r = Redis->new(sock => $ENV{TEST_REDIS_SERVER_SOCK_PATH}, @args); }, undef, 'Connected to the Redis server ok', ); return $r; }; subtest 'basic tests' => sub { my $r = $conn->(); ok($r->set(xpto => '42'), '... set command via UNIX ok'); is($r->get('xpto'), '42', '... and get command ok too'); is(exception { $r->quit }, undef, 'Connection closed ok'); like(exception { $r->get('xpto') }, qr!Not connected to any server!, 'Command failed ok, no reconnect',); }; subtest 'reconnect over UNIX daemon' => sub { my $r = $conn->(reconnect => 2); ok($r->quit, '... and connection closed ok'); is(exception { $r->set(xpto => '43') }, undef, 'set command via UNIX ok, reconnected fine'); is($r->get('xpto'), '43', '... and get command ok too'); }; done_testing(); 42-client_cmds.t100644000765000024 346212257644644 15261 0ustar00damsstaff000000000000Redis-1.967/t#!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 Redis; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(requires_version => '2.6.9'); END { $c->() if $c } subtest 'client_{set|get}name commands' => sub { ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); my @clients = $r->client_list; is(@clients, 1, 'one client listed'); like($clients[0], qr/\s+name=\s+/, '... no name set yet'); is($r->client_setname('my_preccccious'), 'OK', "client_setname() is supported, no errors"); is($r->client_getname, 'my_preccccious', '... client_getname() returns new connection name'); @clients = $r->client_list; like($clients[0], qr/\s+name=my_preccccious\s+/, '... no name set yet'); }; subtest 'client name via constructor' => sub { ok(my $r = Redis->new(server => $srv, name => 'buuu'), 'connected to our test redis-server, with a name'); is($r->client_getname, 'buuu', '...... name was properly set'); ok($r = Redis->new(server => $srv, name => sub {"cache-for-$$"}), '... with a dynamic name'); is($r->client_getname, "cache-for-$$", '...... name was properly set'); ok($r = Redis->new(server => $srv, name => sub {undef}), '... with a dynamic name, but returning undef'); is($r->client_getname, undef, '...... name was not set'); my $generation = 0; for (1 .. 3) { ok($r = Redis->new(server => $srv, name => sub { "gen-$$-" . ++$generation }), "Using dynamic name, for generation $generation"); my $n = "gen-$$-$generation"; is($r->client_getname, $n, "... name was set properly, '$n'"); } }; done_testing(); release-distmeta.t100644000765000024 76112257644644 15761 0ustar00damsstaff000000000000Redis-1.967/t#!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) # BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::CPAN::Meta"; plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@; meta_yaml_ok(); release-pod-coverage.t100644000765000024 127112257644644 16537 0ustar00damsstaff000000000000Redis-1.967/t#!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) # BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; eval "use Pod::Coverage::TrustPod"; plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); redis-benchmark.pl100755000765000024 202112257644644 17175 0ustar00damsstaff000000000000Redis-1.967/scripts#!/usr/bin/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 Benchmark qw/:all/; use lib 'lib'; use Redis; use Redis::Hash; my $r = Redis->new; my %hash; tie %hash, 'Redis::Hash', 'hash'; my $i = 0; timethese( -5, { '00_ping' => sub { $r->ping }, '10_set' => sub { $r->set('foo', $i++) }, '11_set_r' => sub { $r->set('bench-' . rand(), rand()) }, '20_get' => sub { $r->get('foo') }, '21_get_r' => sub { $r->get('bench-' . rand()) }, '30_incr' => sub { $r->incr('counter') }, '30_incr_r' => sub { $r->incr('bench-' . rand()) }, '40_lpush' => sub { $r->lpush('mylist', 'bar') }, '40_lpush' => sub { $r->lpush('mylist', 'bar') }, '50_lpop' => sub { $r->lpop('mylist') }, '90_h_set' => sub { $hash{ 'test' . rand() } = rand() }, '90_h_get' => sub { my $a = $hash{ 'test' . rand() }; }, } ); Test000755000765000024 012257644644 14071 5ustar00damsstaff000000000000Redis-1.967/t/tlibSpawnRedisServer.pm100644000765000024 642112257644644 20040 0ustar00damsstaff000000000000Redis-1.967/t/tlib/Test# # 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::SpawnRedisServer; use strict; use warnings; use Redis; use File::Temp; 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 ); ## FIXME: for the love of $Deity... move to Test::TCP, will you?? my $port = 11011 + ($$ % 127); sub redis { my %params = ( timeout => 120, @_, ); my ($fh, $fn) = File::Temp::tempfile(); $port++; my $local_port = $port; $params{port} and $local_port = $params{port}; my $addr = "127.0.0.1:$local_port"; unlink("redis-server-$addr.log"); unlink('dump.rdb'); $fh->print(" timeout $params{timeout} appendonly no daemonize no port $local_port bind 127.0.0.1 loglevel debug logfile redis-server-$addr.log "); $fh->flush; Test::More::diag("Spawn Redis at $addr, cfg $fn") if $ENV{REDIS_DEBUG}; 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, $addr) }; if (my $e = $@) { reap(); Test::More::plan skip_all => "Could not start redis-server: $@"; 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(); if ($pid) { ## Parent require Test::More; Test::More::diag("Starting server with pid $pid") if $ENV{REDIS_DEBUG}; my $redis = Redis->new(server => $addr, reconnect => 5, every => 200); my $version = $redis->info->{redis_version}; my $alive = $$; my $c = sub { return unless $alive; return unless $$ == $alive; ## only our creator can kill us Test::More::diag("Killing server at $pid") if $ENV{REDIS_DEBUG}; kill(15, $pid); my $failed = reap($pid); Test::More::diag("Failed to kill server at $pid") if $ENV{REDIS_DEBUG} and $failed; unlink("redis-server-$addr.log"); unlink('dump.rdb'); $alive = 0; return !$failed; }; return $version => $c; } elsif (defined $pid) { ## Child exec(@_); warn "## In child Failed exec of '@_': $!, "; exit(1); } die "Could not fork(): $!"; } sub reap { my ($pid, $limit) = @_; $pid = -1 unless $pid; $limit = 3 unless $limit; my $try = 0; while ($try++ < $limit) { my $ok = waitpid($pid, WNOHANG); $try = 0, last if $ok > 0; sleep(1); } return $try; } 1; benchmarks000755000765000024 012257644644 15232 5ustar00damsstaff000000000000Redis-1.967/toolsread_vs_sysread.pl100644000765000024 412512257644644 21106 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks# # 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 5.18.1; use Time::HiRes qw(gettimeofday tv_interval); my $total_bytes = 5_000_000; my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); foreach my $length (@lengths) { my $packet_nb = int($total_bytes / $length); my %results; my $method = "read"; if (my $pid = open(my $kid, "|-")) { # parent my $data = 'x' x $length; my $i = $packet_nb; my $t0 = [gettimeofday]; while ($i--) { print $kid $data; } close($kid) or warn "kid exited with $?"; my $elapsed = tv_interval ($t0); # equivalent code say "$method: $packet_nb packets of size $length : $elapsed sec"; $results{$method}{$length} = $elapsed; } else { # child my $data; my $i = 0; while ($i < $packet_nb) { read STDIN, $data, $length, $i*$length; $i++; } length($data) eq $length * $packet_nb or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; exit; # don't forget this } my $method = "sysread"; if (my $pid = open(my $kid, "|-")) { # parent my $data = 'x' x $length; my $i = $packet_nb; my $t0 = [gettimeofday]; while ($i--) { syswrite $kid, $data, $length; } close($kid) or warn "kid exited with $?"; my $elapsed = tv_interval ($t0); # equivalent code say "$method: $packet_nb packets of size $length : $elapsed sec"; $results{$method}{$length} = $elapsed; } else { # child my $data; my $i = 0; while ($i < $packet_nb) { sysread STDIN, $data, $length, $i*$length; $i++; } length($data) eq $length * $packet_nb or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; exit; # don't forget this } } SpawnRedisTimeoutServer.pm100644000765000024 241612257644644 21407 0ustar00damsstaff000000000000Redis-1.967/t/tlib/Test# # 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 "ops $!"; my $buffer; while (1) { my $client = $socket->accept(); if (defined (my $got = <$client>)) { sleep $timeout; $client->print("+42\r\n"); } # sleep($in_timeout) if $in_timeout; # if ( $client->sysread( $buffer, 5 ) ) { # my $response = # pack( 'N a*', bytes::length($message), $message ); # $client->syswrite($response); # sleep(1); # } } }, ); } 1; readline_vs_sysread_vs_recv000755000765000024 012257644644 23006 5ustar00damsstaff000000000000Redis-1.967/tools/benchmarksrun.pl100755000765000024 211212257644644 24306 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/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; if (my $pid = fork()) { #parent print "starting server-generator\n"; system('./server-generator.pl'); kill 'KILL', $pid; } else { #child sleep(1); $| = 1; my $total_bytes = 5_000_000; my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); foreach my $length (@lengths) { my $cnt = int($total_bytes / $length); printf "--- # of lines: %d --- len of line: %d bytes ---\n", $cnt, $length; my $rl_res = `./client-readline.pl $cnt $length`; chomp $rl_res; print "readline: $rl_res sec\n"; my $sr_res = `./client-sysread.pl $cnt $length`; chomp $sr_res; print "sysread: $sr_res sec\n"; my $rc_res = `./client-recv.pl $cnt $length`; chomp $rc_res; print "recv: $rc_res sec\n"; } print "hit ctrl+c to stop the server\n"; } client-recv.pl100755000765000024 335612257644644 25730 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/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 Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; $sock->send("$exp_cnt,$exp_len\n"); $exp_len += 1; my $cnt = 0; while (my $line = read_line($sock)) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; exit 0; # implementation of application layer buffering # general concept: # 1. try read 4K block of data # 2. scan if for \n # 3. if found, return line # 4. go to step 1 my $str; my $potential_data_in_str; sub read_line { my $sock = shift; if ($str && $potential_data_in_str) { my $idx = index($str, "\n"); if ($idx >= 0) { return substr($str, 0, $idx + 1, ''); } $potential_data_in_str = 0; } while (1) { my $buf; my $res = $sock->recv($buf, 4096); return unless defined $res; return unless $buf; my $idx = index($buf, "\n"); if ($idx >= 0) { my $line = $str ? $str . substr($buf, 0, $idx + 1, '') : substr($buf, 0, $idx + 1, ''); $str = $buf; $potential_data_in_str = 1; return $line; } else { $str .= $buf; } } } client-sysread.pl100755000765000024 337612257644644 26445 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/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 Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; die $! unless print $sock "$exp_cnt,$exp_len\n"; $exp_len += 1; my $cnt = 0; while (my $line = read_line($sock)) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; exit 0; # implementation of application layer buffering # general concept: # 1. try read 4K block of data # 2. scan if for \n # 3. if found, return line # 4. go to step 1 my $str; my $potential_data_in_str; sub read_line { my $sock = shift; if ($str && $potential_data_in_str) { my $idx = index($str, "\n"); if ($idx >= 0) { return substr($str, 0, $idx + 1, ''); } $potential_data_in_str = 0; } while (1) { my $buf; my $len = sysread($sock, $buf, 4096); return unless defined $len; return unless $len; my $idx = index($buf, "\n"); if ($idx >= 0) { my $line = $str ? $str . substr($buf, 0, $idx + 1, '') : substr($buf, 0, $idx + 1, ''); $str = $buf; $potential_data_in_str = 1; return $line; } else { $str .= $buf; } } } client-readline.pl100755000765000024 150512257644644 26546 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/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 Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; die $! unless print $sock "$exp_cnt,$exp_len\n"; $exp_len += 1; my $cnt = 0; while (my $line = <$sock>) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; server-generator.pl100755000765000024 132112257644644 26775 0ustar00damsstaff000000000000Redis-1.967/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/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 IO::Socket::INET; $| = 1; my $sock = IO::Socket::INET->new( Listen => 5, LocalAddr => 'localhost', LocalPort => 1234, Proto => 'tcp', ReuseAddr => 1, ); die $! unless $sock; die $! unless $sock->listen(); while (my $client = $sock->accept()) { my $line = <$client>; chomp $line; my ($cnt, $len) = split(',', $line); next unless $cnt || $len; for (my $i = 1; $i <= $cnt; ++$i) { print $client '.' x $len, "\n"; } }