Redis-1.9820007551706202451456525 012657040045 12377 5ustar00dkrotkine000000000000README1006441706202451456525 50512657040045 13320 0ustar00dkrotkine000000000000Redis-1.982 This archive contains the distribution Redis, version 1.982: Perl binding for Redis database This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) This README file was generated by Dist::Zilla::Plugin::Readme v5.032. Changes1006441706202451456525 1652112657040045 14000 0ustar00dkrotkine000000000000Redis-1.982Revision history for Redis 1.982 2016-02-11 09:02:40CET+0100 Europe/Paris * fix issue #117: fix backward compatibility with 5.8 1.981 2015-09-29 12:31:57CEST+0200 Europe/Paris * fix a bug where when not yet connected, pid is undef, leading to warnings 1.980 2015-08-24 09:48:08CEST+0200 Europe/Paris * fix "set" documentation as per Emanuele Tomasi suggestion 1.979 2015-05-14 14:28:35CEST+0200 Europe/Amsterdam * depends on IO::Socket::Timeout 0.29 that fixes an important bug on Windows, Solaris, when mixing sockets with and without timeouts. 1.978 2015-01-28 09:52:27 Europe/Amsterdam * reshape the documentation * croak when reconnecting while responses are pending (#101) * merge PR#106 ( support "0" in topic ) 1.977 2015-01-28 01:10:31 Europe/Amsterdam 1.976 2014-10-03 15:05:58 Europe/Amsterdam 1.975 2014-08-03 20:50:25 Europe/Amsterdam * Clarification about reconnect and read_timeout (#89) * Test::CPAN::Meta (et al.) are required even if unused (#92) 1.974 2014-05-16 21:42:48 Europe/Amsterdam * released as stable version, no change 1.973_04 2014-05-12 22:53:06 Europe/Amsterdam * release again, last one was screwed up. * fix #85 (PR #86) reconnect during transaction 1.973_03 2014-05-12 22:49:07 Europe/Amsterdam * fix #85 (PR #86) reconnect during transaction 1.973_02 2014-04-30 12:04:29 Europe/Amsterdam * merge PR #84 optimize try read sock 1.973_01 2014-04-26 18:00:31 Europe/Amsterdam * use new network code from Ivan Kruglov * fix sentinel tests * fix #81: doc for 'every' option 1.972 2014-02-18 00:54:01 Europe/Amsterdam * Sentinel features (connections, timeouts, etc) support * various bugfixes and testfixes * fix network code for BSDs * no_auto_connect_on_new 1.971 2014-02-01 09:55:11 Europe/Paris * skip some tests that fail on some platforms for now 1.970 2014-01-30 15:07:42 Europe/Amsterdam * fix tests breaking in some case 1.969 2014-01-30 13:19:28 Europe/Amsterdam * Clarification for (p)unsubscribe commands. * use Test::TCP for testing 1.968 2014-01-30 12:19:11 Europe/Amsterdam * Add a no_auto_connect_on_new parameter to new() to allow users to call $x = Redis->new and then $x->connect, instead of Redis auto-connecting. Useful for tuning the cnx_timeout parameter. 1.967 2013-12-28 22:58:55 Europe/Paris * use new IO::Socket::Timeout with different API 1.966 2013-12-17 13:58:33 Europe/Amsterdam * fix tests for Redis 2.8 1.965 2013-11-29 09:28:36 Europe/Amsterdam * fix #60: TEST_REQUIRES needs newer MakeMaker * 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 LICENSE1006441706202451456525 2154012657040045 13507 0ustar00dkrotkine000000000000Redis-1.982This software is Copyright (c) 2015 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.ini1006441706202451456525 253712657040045 14133 0ustar00dkrotkine000000000000Redis-1.982name = Redis author = Pedro Melo author = Damien Krotkine license = Artistic_2_0 copyright_holder = Pedro Melo, Damien Krotkine copyright_year = 2015 ; -- version from git ; version = 1.974 [Git::NextVersion] first_version = 1.962 [MetaJSON] [MetaResources] homepage = https://github.com/PerlRedis/perl-redis bugtracker.web = https://github.com/PerlRedis/perl-redis/issues 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-* exclude_match = t/redis-server-* exclude_match = sentinel-* exclude_match = t/sentinel-* [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.29 [Prereqs / TestRequires] Test::SharedFork = 0 Digest::SHA = 0 IO::String = 0 IPC::Cmd = 0 Test::Deep = 0 Test::Fatal = 0 Test::More = 0.98 Test::TCP = 1.19 Test::CPAN::Meta = 0 Pod::Coverage::TrustPod = 0 ; -- release [NextRelease] [CheckChangeLog] [Git::Tag] [Git::Check] [Git::Commit] [Git::Push] META.yml1006441706202451456525 166212657040045 13736 0ustar00dkrotkine000000000000Redis-1.982--- 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 Pod::Coverage::TrustPod: 0 Test::CPAN::Meta: 0 Test::Deep: 0 Test::Fatal: 0 Test::More: 0.98 Test::SharedFork: 0 Test::TCP: 1.19 configure_requires: ExtUtils::MakeMaker: 6.63_03 Module::Build::Tiny: 0.039 dynamic_config: 0 generated_by: 'Dist::Zilla version 5.032, CPAN::Meta::Converter version 2.150005' 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.29 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.982 MANIFEST1006441706202451456525 200412657040045 13605 0ustar00dkrotkine000000000000Redis-1.982# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.032. Build.PL Changes LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini lib/Redis.pm lib/Redis/Hash.pm lib/Redis/List.pm lib/Redis/Sentinel.pm scripts/publish.pl scripts/redis-benchmark.pl t/00-compile.t 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/44-no-unicode-bug.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 tools/html_doc_scrapper.pl Build.PL1006441706202451456525 6612657040045 13716 0ustar00dkrotkine000000000000Redis-1.982use 5.008; use Module::Build::Tiny 0.039; Build_PL(); META.json1006441706202451456525 356112657040045 14106 0ustar00dkrotkine000000000000Redis-1.982{ "abstract" : "Perl binding for Redis database", "author" : [ "Pedro Melo ", "Damien Krotkine " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.032, CPAN::Meta::Converter version 2.150005", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Redis", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.63_03", "Module::Build::Tiny" : "0.039" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::Pod::Coverage" : "1.08" } }, "runtime" : { "requires" : { "IO::Socket::Timeout" : "0.29", "Try::Tiny" : "0", "perl" : "5.008" } }, "test" : { "requires" : { "Digest::SHA" : "0", "File::Spec" : "0", "IO::Handle" : "0", "IO::String" : "0", "IPC::Cmd" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::More" : "0.98", "Test::SharedFork" : "0", "Test::TCP" : "1.19" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PerlRedis/perl-redis/issues" }, "homepage" : "https://github.com/PerlRedis/perl-redis", "repository" : { "type" : "git", "url" : "https://github.com/PerlRedis/perl-redis.git", "web" : "https://github.com/PerlRedis/perl-redis" } }, "version" : "1.982" } Makefile.PL1006441706202451456525 733312657040045 14440 0ustar00dkrotkine000000000000Redis-1.982# # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # # This Makefile.PL for Redis was generated by # Dist::Zilla::Plugin::MakeMaker::Fallback 0.005 # and Dist::Zilla::Plugin::MakeMaker::Awesome 0.33. # Don't edit it but the dist.ini and plugins used to construct it. use strict; use warnings; BEGIN { my %configure_requires = ( ); 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 " ], "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.63_03", "Module::Build::Tiny" => "0.039" }, "DISTNAME" => "Redis", "EXE_FILES" => [], "LICENSE" => "artistic_2", "MIN_PERL_VERSION" => "5.008", "NAME" => "Redis", "PREREQ_PM" => { "IO::Socket::Timeout" => "0.29", "Try::Tiny" => 0 }, "TEST_REQUIRES" => { "Digest::SHA" => 0, "File::Spec" => 0, "IO::Handle" => 0, "IO::String" => 0, "IPC::Cmd" => 0, "IPC::Open3" => 0, "Pod::Coverage::TrustPod" => 0, "Test::CPAN::Meta" => 0, "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "0.98", "Test::SharedFork" => 0, "Test::TCP" => "1.19" }, "VERSION" => "1.982", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Digest::SHA" => 0, "ExtUtils::MakeMaker" => "6.63_03", "File::Spec" => 0, "IO::Handle" => 0, "IO::Socket::Timeout" => "0.29", "IO::String" => 0, "IPC::Cmd" => 0, "IPC::Open3" => 0, "Module::Build::Tiny" => "0.039", "Pod::Coverage::TrustPod" => 0, "Test::CPAN::Meta" => 0, "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "0.98", "Test::SharedFork" => 0, "Test::TCP" => "1.19", "Try::Tiny" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); lib0007551706202451456525 012657040045 13066 5ustar00dkrotkine000000000000Redis-1.982Redis.pm1006441706202451456525 20206712657040045 14701 0ustar00dkrotkine000000000000Redis-1.982/lib# # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # package Redis; $Redis::VERSION = '1.982'; # 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; use Try::Tiny; use Scalar::Util (); use Redis::Sentinel; use constant WIN32 => $^O =~ /mswin32/i; use constant EWOULDBLOCK => eval {Errno::EWOULDBLOCK} || -1E9; use constant EAGAIN => eval {Errno::EAGAIN} || -1E9; use constant EINTR => eval {Errno::EINTR} || -1E9; use constant BUFSIZE => 4096; sub _maybe_enable_timeouts { my ($self, $socket) = @_; $socket or return; exists $self->{read_timeout} || exists $self->{write_timeout} or return $socket; IO::Socket::Timeout->enable_timeouts_on($socket); defined $self->{read_timeout} and $socket->read_timeout($self->{read_timeout}); defined $self->{write_timeout} and $socket->write_timeout($self->{write_timeout}); $socket; } sub new { my ($class, %args) = @_; my $self = bless {}, $class; $self->{__buf} = ''; $self->{debug} = $args{debug} || $ENV{REDIS_DEBUG}; ## Deal with REDIS_SERVER ENV if ($ENV{REDIS_SERVER} && ! exists $args{sock} && ! exists $args{server} && ! exists $args{sentinel}) { 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; } } defined $args{$_} and $self->{$_} = $args{$_} for qw(password on_connect name no_auto_connect_on_new cnx_timeout write_timeout read_timeout sentinels_cnx_timeout sentinels_write_timeout sentinels_read_timeout no_sentinels_list_update); $self->{reconnect} = $args{reconnect} || 0; $self->{conservative_reconnect} = $args{conservative_reconnect} || 0; $self->{every} = $args{every} || 1000; if (exists $args{sock}) { $self->{server} = $args{sock}; $self->{builder} = sub { my ($self) = @_; $self->_maybe_enable_timeouts( IO::Socket::UNIX->new( Peer => $self->{server}, ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ): () ), ) ); }; } elsif ($args{sentinels}) { $self->{sentinels} = $args{sentinels}; ref $self->{sentinels} eq 'ARRAY' or croak("'sentinels' param must be an ArrayRef"); defined($self->{service} = $args{service}) or croak("Need 'service' name when using 'sentinels'!"); $self->{builder} = sub { my ($self) = @_; # try to connect to a sentinel my $status; foreach my $sentinel_address (@{$self->{sentinels}}) { my $sentinel = eval { Redis::Sentinel->new( server => $sentinel_address, cnx_timeout => ( exists $self->{sentinels_cnx_timeout} ? $self->{sentinels_cnx_timeout} : 0.1), read_timeout => ( exists $self->{sentinels_read_timeout} ? $self->{sentinels_read_timeout} : 1 ), write_timeout => ( exists $self->{sentinels_write_timeout} ? $self->{sentinels_write_timeout} : 1 ), ) } or next; my $server_address = $sentinel->get_service_address($self->{service}); defined $server_address or $status ||= "Sentinels don't know this service", next; $server_address eq 'IDONTKNOW' and $status = "service is configured in one Sentinel, but was never reached", next; # we found the service, set the server $self->{server} = $server_address; if (! $self->{no_sentinels_list_update} ) { # move the elected sentinel at the front of the list and add # additional sentinels my $idx = 2; my %h = ( ( map { $_ => $idx++ } @{$self->{sentinels}}), $sentinel_address => 1, ); $self->{sentinels} = [ ( sort { $h{$a} <=> $h{$b} } keys %h ), # sorted existing sentinels, grep { ! $h{$_}; } # list of unknown map { +{ @$_ }->{name}; } # names of $sentinel->sentinel( # sentinels sentinels => $self->{service} # for this service ) ]; } return $self->_maybe_enable_timeouts( IO::Socket::INET->new( PeerAddr => $server_address, Proto => 'tcp', ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ) ); } croak($status || "failed to connect to any of the sentinels"); }; } else { $self->{server} = exists $args{server} ? $args{server} : '127.0.0.1:6379'; $self->{builder} = sub { my ($self) = @_; $self->_maybe_enable_timeouts( IO::Socket::INET->new( PeerAddr => $self->{server}, Proto => 'tcp', ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ) ); }; } $self->{is_subscriber} = 0; $self->{subscribers} = {}; $self->connect unless $args{no_auto_connect_on_new}; 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 $uc_command = uc($command); my $collect_errors = $cb && $uc_command eq 'EXEC'; if ($uc_command eq 'MULTI') { $self->{__inside_transaction} = 1; } elsif ($uc_command eq 'EXEC' || $uc_command eq 'DISCARD') { delete $self->{__inside_transaction}; delete $self->{__inside_watch}; } elsif ($uc_command eq 'WATCH') { $self->{__inside_watch} = 1; } elsif ($uc_command eq 'UNWATCH') { delete $self->{__inside_watch}; } ## Fast path, no reconnect; $self->{reconnect} 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->{__inside_transaction} || $self->{__inside_watch} and croak("reconnect disabled inside transaction or watch"); scalar @{$self->{queue} || []} && $self->{conservative_reconnect} and croak("reconnect disabled while responses are pending and conservative reconnect mode enabled"); $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) = @_; croak "[$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}; croak "[quit] only works in synchronous mode, " if @_ && ref $_[-1] eq 'CODE'; try { $self->wait_all_responses; $self->__send_command('QUIT'); }; $self->__close_sock() if $self->{sock}; return 1; } sub shutdown { my ($self) = @_; $self->__is_valid_command('SHUTDOWN'); croak "[shutdown] only works in synchronous mode, " if @_ && ref $_[-1] eq 'CODE'; return unless $self->{sock}; $self->wait_all_responses; $self->__send_command('SHUTDOWN'); $self->__close_sock() || croak("Can't close socket: $!"); return 1; } sub ping { my $self = shift; $self->__is_valid_command('PING'); croak "[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 { $self->__close_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 = $self->__try_read_sock($sock); # If the socket is ready to read but there is nothing to read, ( so # it's an EOF ), try to reconnect. defined $has_stuff or $self->__throw_reconnect('EOF from server'); do { my ($reply, $error) = $self->__read_response('WAIT_FOR_MESSAGES'); croak "[WAIT_FOR_MESSAGES] $error, " if defined $error; $self->__process_pubsub_msg($reply); $count++; # if __try_read_sock() return 0 (no data) # or undef ( socket became EOF), back to select until timeout } while ($self->{__buf} || $self->__try_read_sock($sock)); } }); } 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; croak("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); croak "[$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 = defined $m->[2] ? $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) = @_; croak("Cannot use command '$cmd' while in SUBSCRIBE mode, ") if $self->{is_subscriber}; } ### Socket operations sub connect { my ($self) = @_; delete $self->{sock}; delete $self->{__inside_watch}; delete $self->{__inside_transaction}; # Suppose we have at least one command response pending, but we're about # to reconnect. The new connection will never get a response to any of # 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) || croak("Could not connect to Redis server at $self->{server}: $!"); $self->{__buf} = ''; if (exists $self->{password}) { try { $self->auth($self->{password}) } catch { $self->{reconnect} = 0; croak("Redis server refused password"); }; } $self->__on_connection; return; } sub __close_sock { my ($self) = @_; $self->{__buf} = ''; delete $self->{__inside_watch}; delete $self->{__inside_transaction}; return close(delete $self->{sock}); } sub __on_connection { my ($self) = @_; # 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}); } foreach my $topic (CORE::keys(%{$self->{subscribers}})) { if ($topic =~ /(p?message):(.*)$/ ) { my ($key, $channel) = ($1, $2); if ($key eq 'message') { $self->__send_command('subscribe', $channel); my (undef, $error) = $self->__read_response('subscribe'); defined $error and croak "[subscribe] $error"; } else { $self->__send_command('psubscribe', $channel); my (undef, $error) = $self->__read_response('psubscribe'); defined $error and croak "[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 already connected but after a fork, reconnect if ($self->{sock} && ($self->{pid} || 0) != $$) { $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, @_) { utf8::downgrade($bin, 1) or croak "command sent is not an octet sequence in the native encoding (Latin-1). Consider using debug mode to see the command itself."; $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 = $self->__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) = @_; croak("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); 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 { croak "[$command] $nested[1], " if defined $nested[1]; push @list, $nested[0]; } } return \@list, undef; } else { croak "unknown answer type: $type ($result), "; } } sub __read_line { my $self = $_[0]; my $sock = $self->{sock}; my $data = $self->__read_line_raw; croak("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_line_raw { my $self = $_[0]; my $sock = $self->{sock}; my $buf = \$self->{__buf}; if (length $$buf) { my $idx = index($$buf, "\r\n"); $idx >= 0 and return substr($$buf, 0, $idx + 2, ''); } while (1) { my $bytes = sysread($sock, $$buf, BUFSIZE, length($$buf)); next if !defined $bytes && $! == EINTR; return unless defined $bytes && $bytes; # start looking for \r\n where we stopped last time # extracting one is required to handle corner case # where \r\n are split and therefore read by two conseqent sysreads my $idx = index($$buf, "\r\n", length($$buf) - $bytes - 1); $idx >= 0 and return substr($$buf, 0, $idx + 2, ''); } } sub __read_len { my ($self, $len) = @_; my $buf = \$self->{__buf}; my $buflen = length($$buf); if ($buflen < $len) { my $to_read = $len - $buflen; while ($to_read > 0) { my $bytes = sysread($self->{sock}, $$buf, BUFSIZE, length($$buf)); next if !defined $bytes && $! == EINTR; croak("Error while reading from Redis server: $!") unless defined $bytes; croak("Redis server closed connection") unless $bytes; $to_read -= $bytes; } } my $data = substr($$buf, 0, $len, ''); chomp $data; warn "[RECV RAW] '$data'" if $self->{debug}; return $data; } sub __try_read_sock { my ($self, $sock) = @_; my $data = ''; while (1) { # WIN32 doesn't support MSG_DONTWAIT, # need to swith fh to nonblockng mode manually. # For Unix still use MSG_DONTWAIT because of fewer syscalls my ($res, $err); if (WIN32) { __fh_nonblocking_win32($sock, 1); $res = recv($sock, $data, BUFSIZE, 0); $err = 0 + $!; __fh_nonblocking_win32($sock, 0); } else { $res = recv($sock, $data, BUFSIZE, MSG_DONTWAIT); $err = 0 + $!; } if (defined $res) { ## have read some data if (length($data)) { $self->{__buf} .= $data; return 1; } ## no data but also no error means EOF return; } next if $err && $err == EINTR; ## Keep going if nothing there, but socket is alive return 0 if $err and ($err == EWOULDBLOCK or $err == EAGAIN); ## result is undef but err is 0? should never happen return if $err == 0; ## For everything else, there is Mastercard... croak("Unexpected error condition $err/$^O, please report this as a bug"); } } ## Copied from AnyEvent::Util sub __fh_nonblocking_win32 { ioctl $_[0], 0x8004667e, pack "L", $_[1]; } ########################## # I take exception to that sub __throw_reconnect { my ($self, $m) = @_; die bless(\$m, 'Redis::X::Reconnect') if $self->{reconnect}; die $m; } 1; # End of Redis.pm __END__ =pod =encoding UTF-8 =head1 NAME Redis - Perl binding for Redis database =head1 VERSION version 1.982 =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, every => 1_000_000); ## Try each 100ms upto 2 seconds (every is in microseconds) my $redis = Redis->new(reconnect => 2, every => 100_000); ## Enable connection timeout (in seconds) my $redis = Redis->new(cnx_timeout => 60); ## Enable read timeout (in seconds) my $redis = Redis->new(read_timeout => 0.5); ## Enable write timeout (in seconds) my $redis = Redis->new(write_timeout => 1.2); ## Connect via a list of Sentinels to a given service my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster'); ## Same, but with connection, read and write timeout on the sentinel hosts my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster', sentinels_cnx_timeout => 0.1, sentinels_read_timeout => 1, sentinels_write_timeout => 1, ); ## Use all the regular Redis commands, they all accept a list of ## arguments ## See http://redis.io/commands for full list $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 binary data. And it doesn't do anything when getting data from the Redis server. So, if you are working with character strings, you should pre-encode or post-decode it if needed ! =head1 CONSTRUCTOR =head2 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-$$" }); my $redis = Redis->new(sentinels => [ '127.0.0.1:12345', '127.0.0.1:23456' ], service => 'mymaster'); ## Connect via a list of Sentinels to a given service my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster'); ## Same, but with connection, read and write timeout on the sentinel hosts my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster', sentinels_cnx_timeout => 0.1, sentinels_read_timeout => 1, sentinels_write_timeout => 1, ); =head3 C<< server >> 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. Alternatively you can use the C<< sentinels >> parameter and the C<< service >> parameter to specify a list of sentinels to contact and try to get the address of the given service name. C<< sentinels >> must be an ArrayRef and C<< service >> an Str. The C<< REDIS_SERVER >> can be used for UNIX domain sockets too. The following formats are supported: =over =item * /path/to/sock =item * unix:/path/to/sock =item * 127.0.0.1:11011 =item * tcp:127.0.0.1:11011 =back =head3 C<< reconnect >>, C<< every >> 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 >> microseconds (1 ms 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. =head3 C<< conservative_reconnect >> C<< conservative_reconnect >> option makes sure that reconnection is only attempted when no pending command is ongoing. For instance, if you're doing C<$redis->incr('key')>, and if the server properly understood and processed the command, but the network connection is dropped just before the server replies : the command has been processed but the client doesn't know it. In this situation, if reconnect is enabled, the Redis client will reconnect and send the C command *again*. If it succeeds, at the end the key as been incremented *two* times. To avoid this issue, you can set the C option to a true value. In this case, the client will reconnect only if no request is pending. Otherwise it will die with the message: C. =head3 C<< cnx_timeout >> 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. =head3 C<< sentinels_cnx_timeout >> The C<< sentinels_cnx_timeout >> option enables sentinel connection timeout. When using the sentinels feature, Redis client will wait at most that number of seconds (can be fractional) before giving up connecting to a sentinel. B: 0.1 =head3 C<< read_timeout >> 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. =head3 C<< sentinels_read_timeout >> The C<< sentinels_read_timeout >> option enables sentinel read timeout. When using the sentinels feature, the Redis client will wait at most that number of seconds (can be fractional) before giving up when reading from a sentinel server. B: 1 =head3 C<< write_timeout >> 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. =head3 C<< sentinels_write_timeout >> The C<< sentinels_write_timeout >> option enables sentinel write timeout. When using the sentinels feature, the Redis client will wait at most that number of seconds (can be fractional) before giving up when reading from a sentinel server. B: 1 =head3 C<< password >> 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. =head3 C<< on_connect >> 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. =head3 C<< no_auto_connect_on_new >> You can also provide C<< no_auto_connect_on_new >> in which case C<< new >> won't call C<< $obj->connect >> for you implicitly, you'll have to do that yourself. This is useful for figuring out how long connection setup takes so you can configure the C<< cnx_timeout >> appropriately. =head3 C<< no_sentinels_list_update >> You can also provide C<< no_sentinels_list_update >>. By default (that is, without this option), when successfully contacting a sentinel server, the Redis client will ask it for the list of sentinels known for the given service, and merge it with its list of sentinels (in the C<< sentinels >> attribute). You can disable this behavior by setting C<< no_sentinels_list_update >> to a true value. =head3 C<< name >> 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. =head3 C<< debug >> 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. =head1 CONNECTION HANDLING =head2 connect $r->connect; Connects to the Redis server. This is done by default when the obect is constructed using C, unless C has been set. See this option in the C constructor. =head2 quit $r->quit; Closes the connection to the server. The C method does not support pipelined operation. =head2 ping $r->ping || die "no server?"; The C method does not support pipelined operation. =head1 PIPELINE MANAGEMENT =head2 wait_all_responses Waits until all pending pipelined responses have been received, and invokes the pipeline callback for each one. See L. =head2 wait_one_response Waits until the first pending pipelined response has been received, and invokes its callback. See L. =head1 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. =head2 publish $r->publish($topic, $message); Publishes the C<< $message >> to the C<< $topic >>. =head2 subscribe $r->subscribe( @topics_to_subscribe_to, my $savecallback = 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. =head2 unsubscribe $r->unsubscribe(@topic_list, $savecallback); Stops receiving messages via C<$savecallback> for all the topics in C<@topic_list>. B it is important that you give the same calleback that you used for subscribtion. The value of the CodeRef must be the same, as this is how internally the code identifies it. =head2 psubscribe my @topic_matches = ('prefix1.*', 'prefix2.*'); $r->psubscribe(@topic_matches, my $savecallback = sub { my ($m, $t, $s) = @_; ... }); Subscribes a pattern of topics. All messages to topics that match the pattern will be delivered to the callback. =head2 punsubscribe my @topic_matches = ('prefix1.*', 'prefix2.*'); $r->punsubscribe(@topic_matches, $savecallback); Stops receiving messages via C<$savecallback> for all the topics pattern matches in C<@topic_list>. B it is important that you give the same calleback that you used for subscribtion. The value of the CodeRef must be the same, as this is how internally the code identifies it. =head2 is_subscriber if ($r->is_subscriber) { say "We are in Pub/Sub mode!" } Returns true if we are in I mode. =head2 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. =head1 IMPORTANT NOTES ON METHODS =head2 methods that return multiple values When a method returns more than one value, it checks the context and returns either a list of values or an ArrayRef. =head2 transaction-handling methods B the behaviour of the TRANSACTIONS commands when combined with pipelining is still under discussion, and you should B use them at the same time just now. You can L. =head2 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 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. =head2 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 =head2 eval Note that this commands sends the Lua script every time you call it. See L and L for an alternative. =head2 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. =head1 KEYS =head2 del $r->del(key [key ...]) Delete a key (see L) =head2 dump $r->dump(key) Return a serialized version of the value stored at the specified key. (see L) =head2 exists $r->exists(key) Determine if a key exists (see L) =head2 expire $r->expire(key, seconds) Set a key's time to live in seconds (see L) =head2 expireat $r->expireat(key, timestamp) Set the expiration for a key as a UNIX timestamp (see L) =head2 keys $r->keys(pattern) Find all keys matching the given pattern (see L) =head2 migrate $r->migrate(host, port, key, destination-db, timeout, [COPY], [REPLACE]) Atomically transfer a key from a Redis instance to another one. (see L) =head2 move $r->move(key, db) Move a key to another database (see L) =head2 object $r->object(subcommand, [arguments [arguments ...]]) Inspect the internals of Redis objects (see L) =head2 persist $r->persist(key) Remove the expiration from a key (see L) =head2 pexpire $r->pexpire(key, milliseconds) Set a key's time to live in milliseconds (see L) =head2 pexpireat $r->pexpireat(key, milliseconds-timestamp) Set the expiration for a key as a UNIX timestamp specified in milliseconds (see L) =head2 pttl $r->pttl(key) Get the time to live for a key in milliseconds (see L) =head2 randomkey $r->randomkey() Return a random key from the keyspace (see L) =head2 rename $r->rename(key, newkey) Rename a key (see L) =head2 renamenx $r->renamenx(key, newkey) Rename a key, only if the new key does not exist (see L) =head2 restore $r->restore(key, ttl, serialized-value) Create a key using the provided serialized value, previously obtained using DUMP. (see L) =head2 scan $r->scan(cursor, [MATCH pattern], [COUNT count]) Incrementally iterate the keys space (see L) =head2 sort $r->sort(key, [BY pattern], [LIMIT offset count], [GET pattern [GET pattern ...]], [ASC|DESC], [ALPHA], [STORE destination]) Sort the elements in a list, set or sorted set (see L) =head2 ttl $r->ttl(key) Get the time to live for a key (see L) =head2 type $r->type(key) Determine the type stored at key (see L) =head1 STRINGS =head2 append $r->append(key, value) Append a value to a key (see L) =head2 bitcount $r->bitcount(key, [start end]) Count set bits in a string (see L) =head2 bitop $r->bitop(operation, destkey, key [key ...]) Perform bitwise operations between strings (see L) =head2 bitpos $r->bitpos(key, bit, [start], [end]) Find first bit set or clear in a string (see L) =head2 blpop $r->blpop(key [key ...], timeout) Remove and get the first element in a list, or block until one is available (see L) =head2 brpop $r->brpop(key [key ...], timeout) Remove and get the last element in a list, or block until one is available (see L) =head2 brpoplpush $r->brpoplpush(source, destination, timeout) Pop a value from a list, push it to another list and return it; or block until one is available (see L) =head2 decr $r->decr(key) Decrement the integer value of a key by one (see L) =head2 decrby $r->decrby(key, decrement) Decrement the integer value of a key by the given number (see L) =head2 get $r->get(key) Get the value of a key (see L) =head2 getbit $r->getbit(key, offset) Returns the bit value at offset in the string value stored at key (see L) =head2 getrange $r->getrange(key, start, end) Get a substring of the string stored at a key (see L) =head2 getset $r->getset(key, value) Set the string value of a key and return its old value (see L) =head2 incr $r->incr(key) Increment the integer value of a key by one (see L) =head2 incrby $r->incrby(key, increment) Increment the integer value of a key by the given amount (see L) =head2 incrbyfloat $r->incrbyfloat(key, increment) Increment the float value of a key by the given amount (see L) =head2 mget $r->mget(key [key ...]) Get the values of all the given keys (see L) =head2 mset $r->mset(key value [key value ...]) Set multiple keys to multiple values (see L) =head2 msetnx $r->msetnx(key value [key value ...]) Set multiple keys to multiple values, only if none of the keys exist (see L) =head2 psetex $r->psetex(key, milliseconds, value) Set the value and expiration in milliseconds of a key (see L) =head2 set $r->set(key, value, ['EX', seconds], ['PX', milliseconds], ['NX'|'XX']) Set the string value of a key (see L). Example: $r->set('key', 'test', 'EX', 60, 'NX') =head2 setbit $r->setbit(key, offset, value) Sets or clears the bit at offset in the string value stored at key (see L) =head2 setex $r->setex(key, seconds, value) Set the value and expiration of a key (see L) =head2 setnx $r->setnx(key, value) Set the value of a key, only if the key does not exist (see L) =head2 setrange $r->setrange(key, offset, value) Overwrite part of a string at key starting at the specified offset (see L) =head2 strlen $r->strlen(key) Get the length of the value stored in a key (see L) =head1 HASHES =head2 hdel $r->hdel(key, field [field ...]) Delete one or more hash fields (see L) =head2 hexists $r->hexists(key, field) Determine if a hash field exists (see L) =head2 hget $r->hget(key, field) Get the value of a hash field (see L) =head2 hgetall $r->hgetall(key) Get all the fields and values in a hash (see L) =head2 hincrby $r->hincrby(key, field, increment) Increment the integer value of a hash field by the given number (see L) =head2 hincrbyfloat $r->hincrbyfloat(key, field, increment) Increment the float value of a hash field by the given amount (see L) =head2 hkeys $r->hkeys(key) Get all the fields in a hash (see L) =head2 hlen $r->hlen(key) Get the number of fields in a hash (see L) =head2 hmget $r->hmget(key, field [field ...]) Get the values of all the given hash fields (see L) =head2 hmset $r->hmset(key, field value [field value ...]) Set multiple hash fields to multiple values (see L) =head2 hscan $r->hscan(key, cursor, [MATCH pattern], [COUNT count]) Incrementally iterate hash fields and associated values (see L) =head2 hset $r->hset(key, field, value) Set the string value of a hash field (see L) =head2 hsetnx $r->hsetnx(key, field, value) Set the value of a hash field, only if the field does not exist (see L) =head2 hvals $r->hvals(key) Get all the values in a hash (see L) =head1 SETS =head2 sadd $r->sadd(key, member [member ...]) Add one or more members to a set (see L) =head2 scard $r->scard(key) Get the number of members in a set (see L) =head2 sdiff $r->sdiff(key [key ...]) Subtract multiple sets (see L) =head2 sdiffstore $r->sdiffstore(destination, key [key ...]) Subtract multiple sets and store the resulting set in a key (see L) =head2 sinter $r->sinter(key [key ...]) Intersect multiple sets (see L) =head2 sinterstore $r->sinterstore(destination, key [key ...]) Intersect multiple sets and store the resulting set in a key (see L) =head2 sismember $r->sismember(key, member) Determine if a given value is a member of a set (see L) =head2 smembers $r->smembers(key) Get all the members in a set (see L) =head2 smove $r->smove(source, destination, member) Move a member from one set to another (see L) =head2 spop $r->spop(key) Remove and return a random member from a set (see L) =head2 srandmember $r->srandmember(key, [count]) Get one or multiple random members from a set (see L) =head2 srem $r->srem(key, member [member ...]) Remove one or more members from a set (see L) =head2 sscan $r->sscan(key, cursor, [MATCH pattern], [COUNT count]) Incrementally iterate Set elements (see L) =head2 sunion $r->sunion(key [key ...]) Add multiple sets (see L) =head2 sunionstore $r->sunionstore(destination, key [key ...]) Add multiple sets and store the resulting set in a key (see L) =head1 SORTED SETS =head2 zadd $r->zadd(key, score member [score member ...]) Add one or more members to a sorted set, or update its score if it already exists (see L) =head2 zcard $r->zcard(key) Get the number of members in a sorted set (see L) =head2 zcount $r->zcount(key, min, max) Count the members in a sorted set with scores within the given values (see L) =head2 zincrby $r->zincrby(key, increment, member) Increment the score of a member in a sorted set (see L) =head2 zinterstore $r->zinterstore(destination, numkeys, key [key ...], [WEIGHTS weight [weight ...]], [AGGREGATE SUM|MIN|MAX]) Intersect multiple sorted sets and store the resulting sorted set in a new key (see L) =head2 zlexcount $r->zlexcount(key, min, max) Count the number of members in a sorted set between a given lexicographical range (see L) =head2 zrange $r->zrange(key, start, stop, [WITHSCORES]) Return a range of members in a sorted set, by index (see L) =head2 zrangebylex $r->zrangebylex(key, min, max, [LIMIT offset count]) Return a range of members in a sorted set, by lexicographical range (see L) =head2 zrangebyscore $r->zrangebyscore(key, min, max, [WITHSCORES], [LIMIT offset count]) Return a range of members in a sorted set, by score (see L) =head2 zrank $r->zrank(key, member) Determine the index of a member in a sorted set (see L) =head2 zrem $r->zrem(key, member [member ...]) Remove one or more members from a sorted set (see L) =head2 zremrangebylex $r->zremrangebylex(key, min, max) Remove all members in a sorted set between the given lexicographical range (see L) =head2 zremrangebyrank $r->zremrangebyrank(key, start, stop) Remove all members in a sorted set within the given indexes (see L) =head2 zremrangebyscore $r->zremrangebyscore(key, min, max) Remove all members in a sorted set within the given scores (see L) =head2 zrevrange $r->zrevrange(key, start, stop, [WITHSCORES]) Return a range of members in a sorted set, by index, with scores ordered from high to low (see L) =head2 zrevrangebylex $r->zrevrangebylex(key, max, min, [LIMIT offset count]) Return a range of members in a sorted set, by lexicographical range, ordered from higher to lower strings. (see L) =head2 zrevrangebyscore $r->zrevrangebyscore(key, max, min, [WITHSCORES], [LIMIT offset count]) Return a range of members in a sorted set, by score, with scores ordered from high to low (see L) =head2 zrevrank $r->zrevrank(key, member) Determine the index of a member in a sorted set, with scores ordered from high to low (see L) =head2 zscan $r->zscan(key, cursor, [MATCH pattern], [COUNT count]) Incrementally iterate sorted sets elements and associated scores (see L) =head2 zscore $r->zscore(key, member) Get the score associated with the given member in a sorted set (see L) =head2 zunionstore $r->zunionstore(destination, numkeys, key [key ...], [WEIGHTS weight [weight ...]], [AGGREGATE SUM|MIN|MAX]) Add multiple sorted sets and store the resulting sorted set in a new key (see L) =head1 HYPERLOGLOG =head2 pfadd $r->pfadd(key, element [element ...]) Adds the specified elements to the specified HyperLogLog. (see L) =head2 pfcount $r->pfcount(key [key ...]) Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s). (see L) =head2 pfmerge $r->pfmerge(destkey, sourcekey [sourcekey ...]) Merge N different HyperLogLogs into a single one. (see L) =head1 PUB/SUB =head2 pubsub $r->pubsub(subcommand, [argument [argument ...]]) Inspect the state of the Pub/Sub subsystem (see L) =head1 TRANSACTIONS =head2 discard $r->discard() Discard all commands issued after MULTI (see L) =head2 exec $r->exec() Execute all commands issued after MULTI (see L) =head2 multi $r->multi() Mark the start of a transaction block (see L) =head2 unwatch $r->unwatch() Forget about all watched keys (see L) =head2 watch $r->watch(key [key ...]) Watch the given keys to determine execution of the MULTI/EXEC block (see L) =head1 SCRIPTING =head2 eval $r->eval(script, numkeys, key [key ...], arg [arg ...]) Execute a Lua script server side (see L) =head2 evalsha $r->evalsha(sha1, numkeys, key [key ...], arg [arg ...]) Execute a Lua script server side (see L) =head2 script_exists $r->script_exists(script [script ...]) Check existence of scripts in the script cache. (see L) =head2 script_flush $r->script_flush() Remove all the scripts from the script cache. (see L) =head2 script_kill $r->script_kill() Kill the script currently in execution. (see L) =head2 script_load $r->script_load(script) Load the specified Lua script into the script cache. (see L) =head1 CONNECTION =head2 auth $r->auth(password) Authenticate to the server (see L) =head2 echo $r->echo(message) Echo the given string (see L) =head2 ping $r->ping() Ping the server (see L) =head2 quit $r->quit() Close the connection (see L) =head2 select $r->select(index) Change the selected database for the current connection (see L) =head1 SERVER =head2 bgrewriteaof $r->bgrewriteaof() Asynchronously rewrite the append-only file (see L) =head2 bgsave $r->bgsave() Asynchronously save the dataset to disk (see L) =head2 client_getname $r->client_getname() Get the current connection name (see L) =head2 client_kill $r->client_kill([ip:port], [ID client-id], [TYPE normal|slave|pubsub], [ADDR ip:port], [SKIPME yes/no]) Kill the connection of a client (see L) =head2 client_list $r->client_list() Get the list of client connections (see L) =head2 client_pause $r->client_pause(timeout) Stop processing commands from clients for some time (see L) =head2 client_setname $r->client_setname(connection-name) Set the current connection name (see L) =head2 cluster_slots $r->cluster_slots() Get array of Cluster slot to node mappings (see L) =head2 command $r->command() Get array of Redis command details (see L) =head2 command_count $r->command_count() Get total number of Redis commands (see L) =head2 command_getkeys $r->command_getkeys() Extract keys given a full Redis command (see L) =head2 command_info $r->command_info(command-name [command-name ...]) Get array of specific Redis command details (see L) =head2 config_get $r->config_get(parameter) Get the value of a configuration parameter (see L) =head2 config_resetstat $r->config_resetstat() Reset the stats returned by INFO (see L) =head2 config_rewrite $r->config_rewrite() Rewrite the configuration file with the in memory configuration (see L) =head2 config_set $r->config_set(parameter, value) Set a configuration parameter to the given value (see L) =head2 dbsize $r->dbsize() Return the number of keys in the selected database (see L) =head2 debug_object $r->debug_object(key) Get debugging information about a key (see L) =head2 debug_segfault $r->debug_segfault() Make the server crash (see L) =head2 flushall $r->flushall() Remove all keys from all databases (see L) =head2 flushdb $r->flushdb() Remove all keys from the current database (see L) =head2 info $r->info([section]) Get information and statistics about the server (see L) =head2 lastsave $r->lastsave() Get the UNIX time stamp of the last successful save to disk (see L) =head2 lindex $r->lindex(key, index) Get an element from a list by its index (see L) =head2 linsert $r->linsert(key, BEFORE|AFTER, pivot, value) Insert an element before or after another element in a list (see L) =head2 llen $r->llen(key) Get the length of a list (see L) =head2 lpop $r->lpop(key) Remove and get the first element in a list (see L) =head2 lpush $r->lpush(key, value [value ...]) Prepend one or multiple values to a list (see L) =head2 lpushx $r->lpushx(key, value) Prepend a value to a list, only if the list exists (see L) =head2 lrange $r->lrange(key, start, stop) Get a range of elements from a list (see L) =head2 lrem $r->lrem(key, count, value) Remove elements from a list (see L) =head2 lset $r->lset(key, index, value) Set the value of an element in a list by its index (see L) =head2 ltrim $r->ltrim(key, start, stop) Trim a list to the specified range (see L) =head2 monitor $r->monitor() Listen for all requests received by the server in real time (see L) =head2 role $r->role() Return the role of the instance in the context of replication (see L) =head2 rpop $r->rpop(key) Remove and get the last element in a list (see L) =head2 rpoplpush $r->rpoplpush(source, destination) Remove the last element in a list, append it to another list and return it (see L) =head2 rpush $r->rpush(key, value [value ...]) Append one or multiple values to a list (see L) =head2 rpushx $r->rpushx(key, value) Append a value to a list, only if the list exists (see L) =head2 save $r->save() Synchronously save the dataset to disk (see L) =head2 shutdown $r->shutdown([NOSAVE], [SAVE]) Synchronously save the dataset to disk and then shut down the server (see L) =head2 slaveof $r->slaveof(host, port) Make the server a slave of another instance, or promote it as master (see L) =head2 slowlog $r->slowlog(subcommand, [argument]) Manages the Redis slow queries log (see L) =head2 sync $r->sync() Internal command used for replication (see L) =head2 time $r->time() Return the current server time (see L) =head1 ACKNOWLEDGEMENTS The following persons contributed to this project (random 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 =item * Steffen Mueller =back =head1 AUTHORS =over 4 =item * Pedro Melo =item * Damien Krotkine =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut t0007551706202451456525 012657040045 12563 5ustar00dkrotkine000000000000Redis-1.98201-basic.t1007551706202451456525 2642412657040045 14442 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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 $n; is( exception { $n = Redis->new(server => $srv, name => 'no_auto_connect', no_auto_connect_on_new => 1) }, undef, 'Got an unconnected object', ); ok(!$n->ping, "ping doesn't work yet"); $n->connect; ok($n->ping, "ping works after connection"); my $o; is( 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 ord($euro) > 255, "assume \$eur is wide character"; ok ! eval { $o->set(utf8 => $euro); 1 }, "accepts only binary data, thus crashes on strings with characters > 255"; like "$@", qr/command sent is not an octet sequence in the native encoding/i, ".. and crashes on syswrite call"; ok ! defined $o->get('utf8'), ".. and does not write actual data"; 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 SKIP: { eval { $o->zrank($zset, 'bar') }; skip "zrank not implemented in this redis", 4 if $@ && $@ =~ /unknown command/; is($o->zrank($zset, 'bar'), 0); is($o->zrank($zset, 'foo'), 1); is($o->zrevrank($zset, 'bar'), 1); is($o->zrevrank($zset, 'foo'), 0); } ok($o->zadd($zset, 2.1, 'baz')); # we now have bar foo baz 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/]); SKIP: { eval { $o->zcount($zset, 2, 3) }; skip "zcount not implemented in this redis", 1 if $@ && $@ =~ /unknown command/; is($o->zcount($zset, 2, 3), 2); } is($o->zcard($zset), 3); 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); SKIP: { my $retval = eval { $o->zremrangebyrank($zset, 5, 8) }; skip "zremrangebyrank not implemented in this redis", 5 if $@ && $@ =~ /unknown command/; is($retval, 3); # remove quux and up is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]); is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar 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); SKIP: { my $retval = eval { $o->hset($hash, foo => 'bar') }; skip "hset not implemented in this redis", 20 if $@ && $@ =~ /unknown command/; ok($retval); is($o->hget($hash, 'foo'), 'bar'); ok($o->hexists($hash, 'foo')); ok($o->hdel($hash, 'foo')); 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.t1007551706202451456525 2326712657040045 14665 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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 $r = Redis->new(server => $srv); eval { $r->publish( 'aa', 'v1' ) }; plan 'skip_all' => "pubsub not implemented on this redis server" if $@ && $@ =~ /unknown command/; } my ($another_kill_switch, $yet_another_kill_switch); END { $_ and $_->() for($another_kill_switch, $yet_another_kill_switch) } 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 'zero_topic' => sub { my %got; my $pub = Redis->new(server => $srv); my $sub = Redis->new(server => $srv); my $db_size = -1; $sub->dbsize(sub { $db_size = $_[0] }); my $bad_topic = '0'; my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; $sub->psubscribe("$bad_topic*", 'xx', $sub_cb); is($pub->publish($bad_topic, 'vBAD'), 1, "Delivered to 1 subscriber of topic '$bad_topic'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { "$bad_topic*" => "vBAD:$bad_topic" }, "... for the expected topic, '$bad_topic'"); }; 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.t1006441706202451456525 375712657040045 15031 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # use strict; use warnings; use Test::More; use Test::Fatal; use Redis; use lib 't/tlib'; use Test::SpawnRedisTimeoutServer; use Errno qw(ETIMEDOUT EWOULDBLOCK); use POSIX qw(strerror); use Carp; use IO::Socket::INET; use Test::TCP; subtest 'server replies quickly enough' => sub { my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(0); my $redis = Redis->new(server => '127.0.0.1:' . $server->port, read_timeout => 1); ok($redis); my $res = $redis->get('foo');; is $res, 42; }; subtest "server doesn't replies quickly enough" => sub { my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(10); my $redis = Redis->new(server => '127.0.0.1:' . $server->port, read_timeout => 1); ok($redis); my $msg1 = "Error while reading from Redis server: " . strerror(ETIMEDOUT); my $msg2 = "Error while reading from Redis server: " . strerror(EWOULDBLOCK); like( exception { $redis->get('foo'); }, qr/$msg1|$msg2/, "the code died as expected", ); }; subtest "server doesn't respond at connection (cnx_timeout)" => sub { SKIP: { skip "This subtest is failing on some platforms", 4; my $server = Test::TCP->new(code => sub { my $port = shift; my $sock = IO::Socket::INET->new(Listen => 1, LocalPort => $port, Proto => 'tcp', LocalAddr => '127.0.0.1') or croak "fail to listen on port $port"; while(1) { sleep(1); }; }); my $redis; my $start_time = time; isnt( exception { $redis = Redis->new(server => '127.0.0.1:' . $server->port, cnx_timeout => 1); }, undef, "the code died", ); ok(time - $start_time >= 1, "gave up late enough"); ok(time - $start_time < 5, "gave up soon enough"); ok(!$redis, 'redis was not set'); } }; done_testing; 30-scripts.t1007551706202451456525 240412657040045 15022 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1006441706202451456525 242512657040045 14760 0ustar00dkrotkine000000000000Redis-1.982/tuse 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.054 use Test::More; plan tests => 4 + ($ENV{AUTHOR_TESTING} ? 1 : 0); my @module_files = ( 'Redis.pm', 'Redis/Hash.pm', 'Redis/List.pm', 'Redis/Sentinel.pm' ); # no fake home requested my $inc_switch = -d 'blib' ? '-Mblib' : '-Ilib'; use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L 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"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; 04-pipeline.t1007551706202451456525 1076512657040045 15172 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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 } { my $r = Redis->new(server => $srv); eval { $r->multi( ); }; plan 'skip_all' => "multi without arguments not implemented on this redis server" if $@ && $@ =~ /unknown command/; } ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); 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.t1006441706202451456525 233112657040045 15136 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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(!$r->__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(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block"); alarm(0); }; done_testing(); 10-tie-list.t1007551706202451456525 354312657040045 15070 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1007551706202451456525 304212657040045 15033 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1007551706202451456525 464512657040045 15364 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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"} @_)); $r->{__buf} = ''; } ## -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.t1007551706202451456525 1504212657040045 15341 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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; use Net::EmptyPort qw(empty_port); 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 'Conservative Reconnection dies on pending commands' => sub { ok(my $r = Redis->new(reconnect => 2, conservative_reconnect => 1, 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'); like(exception { $r->set(foo => 'bar') }, qr{while responses are pending and conservative reconnect mode enabled}, 'send command with reconnect and conservative_reconnect should raise an exception'); is($processed_pending, 0, 'pending command never arrived'); }; 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'); }; subtest "Reconnect during transaction" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect_1' => 1), 'set first key'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); like(exception { $r->set('reconnect_2' => 2) }, qr{reconnect disabled inside transaction}, 'set second key'); $r->connect(); #reconnect is($r->exists('reconnect_1'), 0, 'key "reconnect_1" should not exist'); is($r->exists('reconnect_2'), 0, 'key "reconnect_2" should not exist'); }; subtest "Reconnect works after WATCH + MULTI + EXEC" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->set('watch' => 'watch'), 'set watch key'); ok($r->watch('watch'), 'start watching key'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect' => 1), 'set key'); ok($r->exec(), 'execute transaction'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting key should not fail'); }; subtest "Reconnect works after WATCH + MULTI + DISCARD" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->set('watch' => 'watch'), 'set watch key'); ok($r->watch('watch'), 'start watching key'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect' => 1), 'set key'); ok($r->discard(), 'dscard transaction'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting second key should not fail'); }; done_testing(); 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.t1006441706202451456525 135112657040045 15271 0ustar00dkrotkine000000000000Redis-1.982/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; Redis0007551706202451456525 012657040045 14134 5ustar00dkrotkine000000000000Redis-1.982/libHash.pm1006441706202451456525 466412657040045 15527 0ustar00dkrotkine000000000000Redis-1.982/lib/Redis# # This file is part of Redis # # This software is Copyright (c) 2015 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.982'; # 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 =encoding UTF-8 =head1 NAME Redis::Hash - tie Perl hashes to Redis hashes =head1 VERSION version 1.982 =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) 2015 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut List.pm1006441706202451456525 454412657040045 15554 0ustar00dkrotkine000000000000Redis-1.982/lib/Redis# # This file is part of Redis # # This software is Copyright (c) 2015 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.982'; # 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 =encoding UTF-8 =head1 NAME Redis::List - tie Perl arrays to Redis lists =head1 VERSION version 1.982 =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) 2015 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut 06-on-connect.t1006441706202451456525 217512657040045 15403 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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(); scripts0007551706202451456525 012657040045 14007 5ustar00dkrotkine000000000000Redis-1.982publish.pl1007551706202451456525 101012657040045 16145 0ustar00dkrotkine000000000000Redis-1.982/scripts#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1006441706202451456525 237712657040045 15617 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1006441706202451456525 346212657040045 15624 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.t1006441706202451456525 73412657040045 16324 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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'); } } # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); Sentinel.pm1006441706202451456525 434012657040045 16414 0ustar00dkrotkine000000000000Redis-1.982/lib/Redis# # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # package Redis::Sentinel; $Redis::Sentinel::VERSION = '1.982'; # ABSTRACT: Redis Sentinel interface use warnings; use strict; use Carp; use base qw(Redis); sub new { my ($class, %args) = @_; # these args are not allowed when contacting a sentinel delete @args{qw(sentinels service)}; $class->SUPER::new(%args); } sub get_service_address { my ($self, $service) = @_; my ($ip, $port) = $self->sentinel('get-master-addr-by-name', $service); defined $ip or return; $ip eq 'IDONTKNOW' and return $ip; return "$ip:$port"; } sub get_masters { map { +{ @$_ }; } @{ shift->sentinel('masters') || [] }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Redis::Sentinel - Redis Sentinel interface =head1 VERSION version 1.982 =head1 SYNOPSIS my $sentinel = Redis::Sentinel->new( ... ); my $service_address = $sentinel->get_service_address('mymaster'); my @masters = $sentinel->get_masters; =head1 DESCRIPTION This is a subclass of the Redis module, specialized into connecting to a Sentinel instance. Inherits from the C package; =head1 CONSTRUCTOR =head2 new See C in L. All parameters are supported, except C and C, which are silently ignored. =head1 METHODS All the methods of the C package are supported, plus the additional following methods: =head2 get_service_address Takes the name of a service as parameter, and returns either void (emptly list) if the master couldn't be found, the string 'IDONTKNOW' if the service is in the sentinel config but cannot be reached, or the string C<"$ip:$port"> if the service were found. =head2 get_masters Returns a list of HashRefs representing all the master redis instances that this sentinel monitors. =head1 AUTHORS =over 4 =item * Pedro Melo =item * Damien Krotkine =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut 44-no-unicode-bug.t1007551706202451456525 143112657040045 16152 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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 } ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); my $s2 = my $s1 = "test\x{80}"; utf8::upgrade($s1); # no need to use 'use utf8' to call this utf8::downgrade($s2); # no need to use 'use utf8' to call this ok ($s1 eq $s2, 'assume test string are considered identical by perl'); $r->set($s1 => 42); is $r->get($s2), 42, "same binary strings should point to same keys"; ## All done done_testing(); release-pod-coverage.t1006441706202451456525 107612657040045 17105 0ustar00dkrotkine000000000000Redis-1.982/t#!perl # # This file is part of Redis # # This software is Copyright (c) 2015 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'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); redis-benchmark.pl1007551706202451456525 202112657040045 17540 0ustar00dkrotkine000000000000Redis-1.982/scripts#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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() }; }, } ); tools0007551706202451456525 012657040045 13460 5ustar00dkrotkine000000000000Redis-1.982html_doc_scrapper.pl1006441706202451456525 361712657040045 17654 0ustar00dkrotkine000000000000Redis-1.982/tools# # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # use strict; use warnings; use 5.10.1; my %exclude = map { $_ => 1 } qw(publish subscribe unsubscribe psubscribe punsubscribe ); my %hash; my (@groups, $group, $command, @args, $text); my ($in_section, $in_nav, $in_args); while (my $line = <>) { chomp $line; $line =~ m|
| and $in_section=1, next; $in_section && $line =~ m|| and $in_section = 0, $in_nav = 0, next; $line =~ m|li data-group="(.+?)".+?">| and $group = $1, next; $line =~ m|href="/commands/(.+?)">.+?| and $command=$1, @args=(), next; $line =~ m|| and $in_args = 1, next; $in_args && $line =~ m|| and $in_args = 0, next; $in_args and push(@args, $line =~ s/^\s+|\s+$//rg), next; ( ($text) = $line =~ m|(.+?)| ) && ! $exclude{$command} and $hash{$group}{$command =~ s/-/_/gr} = { text => $text, synopsis => '$r->' . ($command =~ s/-/_/gr). '(' . join(', ', @args) . ')', ref => $command, }, @args = (); } my $pod = ''; foreach (@groups) { my ($group, $name) = @$_; $pod .= "=head1 " . uc($name) . "\n\n"; foreach my $command (sort keys %{$hash{$group}}) { my %h = %{$hash{$group}{$command}}; $pod .= "=head2 $command\n\n" . " $h{synopsis}\n\n" . $h{text} . " (see L)\n\n"; } } say $pod; Test0007551706202451456525 012657040045 14434 5ustar00dkrotkine000000000000Redis-1.982/t/tlibSpawnRedisServer.pm1006441706202451456525 1161512657040045 20424 0ustar00dkrotkine000000000000Redis-1.982/t/tlib/Test# # This file is part of Redis # # This software is Copyright (c) 2015 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 ); use Net::EmptyPort qw(empty_port); our @EXPORT = qw( redis sentinel ); our @EXPORT_OK = qw( redis reap ); sub redis { my %params = ( timeout => 120, @_, ); my ($fh, $fn) = File::Temp::tempfile(); my $port = empty_port(); my $local_port = $port; $params{port} and $local_port = $params{port}; my $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 sentinel { my %params = ( timeout => 120, @_, ); my ($fh, $fn) = File::Temp::tempfile(); my $port = empty_port(); my $local_port = $port; $params{port} and $local_port = $params{port}; my $redis_port = $params{redis_port} or die "need a redis port"; my $addr = "127.0.0.1:$local_port"; unlink("redis-sentinel-$addr.log"); $fh->print(" port $local_port sentinel monitor mymaster 127.0.0.1 $redis_port 2 sentinel down-after-milliseconds mymaster 2000 sentinel failover-timeout mymaster 4000 logfile sentinel-$addr.log "); $fh->flush; my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server'; if (!can_run($redis_server_path)) { Test::More::plan skip_all => "Could not find binary redis-server"; return; } my ($ver, $c); eval { ($ver, $c) = spawn_server($redis_server_path, $fn, '--sentinel', $addr) }; if (my $e = $@) { reap(); Test::More::plan skip_all => "Could not start redis-sentinel: $@"; return; } if (my $rvs = $params{requires_version}) { if (!defined $ver) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version"; return; } my ($v1, $v2, $v3) = split(/[.]/, $ver); my ($r1, $r2, $r3) = split(/[.]/, $rvs); if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver"; return; } } return ($c, $addr, $ver, split(/[.]/, $ver), $local_port); } sub spawn_server { my $addr = pop; my $pid = fork(); 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("redis-sentinel-$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; local $?; while ($try++ < $limit) { my $ok = waitpid($pid, WNOHANG); $try = 0, last if $ok > 0; sleep(1); } return $try; } 1; benchmarks0007551706202451456525 012657040045 15575 5ustar00dkrotkine000000000000Redis-1.982/toolsread_vs_sysread.pl1006441706202451456525 412512657040045 21451 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks# # This file is part of Redis # # This software is Copyright (c) 2015 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.pm1006441706202451456525 175112657040045 21753 0ustar00dkrotkine000000000000Redis-1.982/t/tlib/Test# # This file is part of Redis # # This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. # # This is free software, licensed under: # # The Artistic License 2.0 (GPL Compatible) # package # Hide from PAUSE Test::SpawnRedisTimeoutServer; use strict; use warnings; use Test::TCP; sub create_server_with_timeout { my $timeout = shift; Test::TCP->new( code => sub { my $port = shift; my $socket = IO::Socket::INET->new( Listen => 5, Timeout => 1, Reuse => 1, Blocking => 1, LocalPort => $port ) or die "failed to connect to RedisTimeoutServer: $!"; my $buffer; while (1) { my $client = $socket->accept(); if (defined (my $got = <$client>)) { sleep $timeout; $client->print("+42\r\n"); } } }, ); } 1; readline_vs_sysread_vs_recv0007551706202451456525 012657040045 23351 5ustar00dkrotkine000000000000Redis-1.982/tools/benchmarksrun.pl1007551706202451456525 211212657040045 24651 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.pl1007551706202451456525 335612657040045 26273 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.pl1007551706202451456525 337612657040045 27010 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.pl1007551706202451456525 150512657040045 27111 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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.pl1007551706202451456525 132112657040045 27340 0ustar00dkrotkine000000000000Redis-1.982/tools/benchmarks/readline_vs_sysread_vs_recv#!/usr/bin/perl # # This file is part of Redis # # This software is Copyright (c) 2015 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"; } }