Redis-2.000000755000765000024 014360351554 14135 5ustar00damien.krotkinestaff000000000000README100644000765000024 50214360351554 15053 0ustar00damien.krotkinestaff000000000000Redis-2.000This archive contains the distribution Redis, version 2.000: 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 v6.024. Changes100644000765000024 2263314360351554 15537 0ustar00damien.krotkinestaff000000000000Redis-2.000Revision history for Redis 2.000 2023-01-13 22:55:51+01:00 Europe/Paris * #166: add ssl, username and password args to redis sentinel (Merwan Ouddane) * #163: Add support for username/password AUTH (Joel Chornik) * #162: Retry socket connect if errno is EINTR (Michael Schout) * #158: Better fix of redis version in test (Michal Josef Špaček) * #156: Fix of test for multiple arguments in info command (Michal Josef Špaček) 1.999 2022-01-14 21:42:33+01:00 Europe/Paris * enable ssl support * remove test expression that is problematic on OpenBSD and NetBSD 1.997 2020-80-17 10:03:00+01:00 Europe/Paris * various travis fixes * #112 applied * enable unix socket tests by enabling them in the local test server * #144: change exists into defined * #146: Fix sentinel option typo 1.996 2020-03-05 16:17:21+01:00 Europe/Paris 1.996 2020-03-05 11:56:11+01:00 Europe/Paris * #139: Fix for "Unexpected error condition 104/linux" 1.995 2019-07-22 11:20:07+02:00 Europe/Paris * revert #136, remove deps that are in core, as it breaks builds in some setup 1.994 2019-07-22 07:51:57+02:00 Europe/Paris * Don't send SELECT if current database equals the one being selected (@dallaylaen, #132) 1.993 2019-07-22 07:01:30+02:00 Europe/Paris * fix missing deps (@manwar, #136 ) 1.992 2019-07-21 18:27:23+02:00 Europe/Paris * relax the check in 04-pipeline.t about unknown command output (#130) 1.991 2016-08-23 16:04:29CEST+0200 Europe/Paris * release as a normal release after successful testing of the dev releases 1.990_02 2016-08-06 20:30:30CEST+0200 Europe/Paris * move reconnection test in reconnect test file to avoid test issues (skip_all but still run some tests) 1.990_01 2016-08-05 17:17:28CEST+0200 Europe/Paris * fix issue #122: don't attempt to close an already closed or undefined socket * fix issue #120 and #111: don't depend on locales for matching error messages * fix issue #118: spelling mistake * fix issue #116: forbid continuing using socket after a read timeout * fix issue #115: Unexpected error condition 54/freebsd 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 LICENSE100644000765000024 2154014360351554 15245 0ustar00damien.krotkinestaff000000000000Redis-2.000This 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.ini100644000765000024 256214360351554 15667 0ustar00damien.krotkinestaff000000000000Redis-2.000name = 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.993 [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 ; -- release [NextRelease] [CheckChangeLog] [Git::Tag] [Git::Check] [Git::Commit] [Git::Push] [Run::AfterRelease] run = perldoc -u %d%plib%pRedis.pm > README.pod META.yml100644000765000024 206114360351554 15466 0ustar00damien.krotkinestaff000000000000Redis-2.000--- abstract: 'Perl binding for Redis database' author: - 'Pedro Melo ' - 'Damien Krotkine ' build_requires: Digest::SHA: '0' File::Spec: '0' IO::Handle: '0' IO::String: '0' IPC::Cmd: '0' IPC::Open3: '0' Test::Deep: '0' Test::Fatal: '0' Test::More: '0.98' Test::SharedFork: '0' Test::TCP: '1.19' perl: '5.010' configure_requires: ExtUtils::MakeMaker: 6.63_03 Module::Build::Tiny: '0.034' perl: '5.010' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010' 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.010' 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: '2.000' x_generated_by_perl: v5.32.1 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: Artistic-2.0 MANIFEST100644000765000024 206214360351554 15347 0ustar00damien.krotkinestaff000000000000Redis-2.000# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.024. Build.PL Changes LICENSE MANIFEST META.json META.yml Makefile.PL README README.pod 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/author-distmeta.t t/author-pod-coverage.t t/stunnel/cert.pem t/stunnel/key.pem 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.PL100644000765000024 55414360351554 15476 0ustar00damien.krotkinestaff000000000000Redis-2.000# # 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 Build.PL for Redis was generated by Dist::Zilla::Plugin::ModuleBuildTiny 0.015. use strict; use warnings; use 5.010; use Module::Build::Tiny 0.034; Build_PL(); META.json100644000765000024 374714360351554 15652 0ustar00damien.krotkinestaff000000000000Redis-2.000{ "abstract" : "Perl binding for Redis database", "author" : [ "Pedro Melo ", "Damien Krotkine " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010", "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.034", "perl" : "5.010" } }, "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.010" } }, "test" : { "requires" : { "Digest::SHA" : "0", "File::Spec" : "0", "IO::Handle" : "0", "IO::String" : "0", "IPC::Cmd" : "0", "IPC::Open3" : "0", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::More" : "0.98", "Test::SharedFork" : "0", "Test::TCP" : "1.19", "perl" : "5.010" } } }, "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" : "2.000", "x_generated_by_perl" : "v5.32.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.27", "x_spdx_expression" : "Artistic-2.0" } README.pod100644000765000024 12570714360351554 15733 0ustar00damien.krotkinestaff000000000000Redis-2.000=pod =encoding UTF-8 =head1 NAME Redis - Perl binding for Redis database =head1 VERSION version 1.999 =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'); ## Connect to Redis over a secure SSL/TLS channel. See ## IO::Socket::SSL documentation for more information ## about SSL_verify_mode parameter. my $redis = Redis->new( server => 'redis.tls.example.com:8080', ssl => 1, SSL_verify_mode => SSL_VERIFY_PEER, ); ## 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 up to 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 https://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( server => '192.168.0.1:6379', ssl => 1, SSL_verify_mode => SSL_VERIFY_PEER ); 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<< ssl >> You can connect to Redis over SSL/TLS by setting this flag if the target Redis server or cluster has been setup to support SSL/TLS. This requires IO::Socket::SSL to be installed on the client. It's off by default. =head3 C<< SSL_verify_mode >> This parameter will be applied when C<< ssl >> flag is set. It sets the verification mode for the peer certificate. It's compatible with the parameter with the same name in IO::Socket::SSL. =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 Makefile.PL100644000765000024 747114360351554 16201 0ustar00damien.krotkinestaff000000000000Redis-2.000# # 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.030 # and Dist::Zilla::Plugin::MakeMaker::Awesome 0.49. # Don't edit it but the dist.ini and plugins used to construct it. use strict; use warnings; use 5.010; use ExtUtils::MakeMaker; BEGIN { my %configure_requires = ( 'Module::Build::Tiny' => '0.034', ); my %errors = map { eval "require $_; $_->VERSION($configure_requires{$_}); 1"; $_ => $@, } keys %configure_requires; if (grep { $_ } values %errors) { warn "Errors from configure prereqs:\n" . do { require Data::Dumper; Data::Dumper->new([ \%errors ])->Indent(2)->Terse(1)->Sortkeys(1)->Dump; }; } if (not $ENV{PERL_MM_FALLBACK_SILENCE_WARNING}) { 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 using a packaging tool through a unix distribution, this issue should be reported to the package manager. If you're installing manually, please retrain your fingers to run Build.PL when present instead of Makefile.PL. 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)); } } # end BEGIN my %WriteMakefileArgs = ( "ABSTRACT" => "Perl binding for Redis database", "AUTHOR" => [ "Pedro Melo ", "Damien Krotkine " ], "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.63_03", "Module::Build::Tiny" => "0.034" }, "DISTNAME" => "Redis", "LICENSE" => "artistic_2", "MIN_PERL_VERSION" => "5.010", "NAME" => "Redis", "PL_FILES" => {}, "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, "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "0.98", "Test::SharedFork" => 0, "Test::TCP" => "1.19" }, "VERSION" => "2.000", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Digest::SHA" => 0, "File::Spec" => 0, "IO::Handle" => 0, "IO::Socket::Timeout" => "0.29", "IO::String" => 0, "IPC::Cmd" => 0, "IPC::Open3" => 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); t000755000765000024 014360351554 14321 5ustar00damien.krotkinestaff000000000000Redis-2.00001-basic.t100755000765000024 2754314360351554 16203 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; my $n; is( exception { $n = Redis->new(server => $srv, name => 'no_auto_connect', no_auto_connect_on_new => 1, ssl => $use_ssl, SSL_verify_mode => 0) }, 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', ssl => $use_ssl, SSL_verify_mode => 0) }, 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, ssl => $use_ssl, SSL_verify_mode => 0); 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()'); # Shutdown the SSL tunnel if it is used $t->() if $t; # and wait for the server to shutdown sleep(1); like( exception { Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0) }, qr/Could not connect to Redis server at $srv/, 'Failed connection throws exception' ); ## All done done_testing(); lib000755000765000024 014360351554 14624 5ustar00damien.krotkinestaff000000000000Redis-2.000Redis.pm100644000765000024 21372114360351554 16436 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 = '2.000'; # 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 SSL_AVAILABLE => eval { require IO::Socket::SSL }; 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 ECONNRESET => eval {Errno::ECONNRESET} || -1E9; # According to IO::Socket::SSL documentation, 16k is the maximum # size of an SSL frame and because sysread returns data from only # a single SSL frame you guarantee this way, that there is no pending # data. use constant BUFSIZE => 16_384; sub _maybe_enable_timeouts { my ($self, $socket) = @_; $socket or return; defined $self->{read_timeout} || defined $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} && ! defined $args{sock} && ! defined $args{server} && ! defined $args{sentinels}) { 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(username password on_connect name no_auto_connect_on_new cnx_timeout write_timeout read_timeout sentinels_ssl sentinels_username sentinels_password 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 (defined $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, username => $self->{sentinels_username}, password => $self->{sentinels_password}, cnx_timeout => ( defined $self->{sentinels_cnx_timeout} ? $self->{sentinels_cnx_timeout} : 0.1 ), read_timeout => ( defined $self->{sentinels_read_timeout} ? $self->{sentinels_read_timeout} : 1 ), write_timeout => ( defined $self->{sentinels_write_timeout} ? $self->{sentinels_write_timeout} : 1 ), ssl => ( defined $self->{sentinels_ssl} ? $self->{sentinels_ssl} : 0 ), ) } 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 ) ]; } my $socket_class; my %socket_args = ( PeerAddr => $server_address, ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ); if (exists $args{ssl} and $args{ssl}) { if ( ! SSL_AVAILABLE ) { croak("IO::Socket::SSL is required for connecting to Redis using SSL"); } $self->{ssl} = 1; $socket_class = 'IO::Socket::SSL'; $socket_args{SSL_verify_mode} = $args{SSL_verify_mode} // 1; } else { $self->{ssl} = 0; $socket_class = 'IO::Socket::INET'; } return $self->_maybe_enable_timeouts( $socket_class->new(%socket_args) ); } croak($status || "failed to connect to any of the sentinels"); }; } else { $self->{server} = defined $args{server} ? $args{server} : '127.0.0.1:6379'; $self->{builder} = sub { my ($self) = @_; my $socket_class; my %socket_args = ( PeerAddr => $self->{server}, ( $self->{cnx_timeout} ? ( Timeout => $self->{cnx_timeout} ) : () ), ); if (exists $args{ssl} and $args{ssl}) { if ( ! SSL_AVAILABLE ) { croak("IO::Socket::SSL is required for connecting to Redis using SSL"); } $self->{ssl} = 1; $socket_class = 'IO::Socket::SSL'; $socket_args{SSL_verify_mode} = $args{SSL_verify_mode} // 1; } else { $self->{ssl} = 0; $socket_class = 'IO::Socket::INET'; } return $self->_maybe_enable_timeouts( $socket_class->new(%socket_args) ); }; } $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; croak( "Cannot select an undefined redis database" ) unless defined $database; # don't want to send multiple select() back and forth if (!defined $self->{current_database} or $self->{current_database} ne $database) { my $ret = $self->__std_cmd('select', $database, @_); $self->{current_database} = $database; return $ret; }; return "OK"; # emulate redis response as of 3.0.6 just in case anybody cares } ### 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(); 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 defined $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'); my $cond; if ( ! $self->{ssl} ) { $cond = sub { # if __try_read_sock() return 0 (no data) # or undef ( socket became EOF), back to select until timeout return $self->{__buf} || $self->__try_read_sock($sock); } } else { $cond = sub { # continue if there is still some data left. If the buffer is # larger than 16K, there won't be any pending data left though return $self->{__buf} || $sock->pending; } } do { my ($reply, $error) = $self->__read_response('WAIT_FOR_MESSAGES'); croak "[WAIT_FOR_MESSAGES] $error, " if defined $error; $self->__process_pubsub_msg($reply); $count++; } while ($cond->()); } }); } 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 (!defined $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) = @_; do { $self->{sock} = $self->{builder}->($self); } while (!$self->{sock} && $! == Errno::EINTR); unless ($self->{sock}) { croak("Could not connect to Redis server at $self->{server}: $!"); } $self->{__buf} = ''; if (defined $self->{username} && defined $self->{password}) { try { $self->auth($self->{username}, $self->{password}) } catch { my $error = $_; $self->{reconnect} = 0; croak('Redis server authentication error: ' . $error); }; } elsif (defined $self->{password}) { try { $self->auth($self->{password}) } catch { my $error = $_; $self->{reconnect} = 0; croak('Redis server authentication error: ' . $error); }; } $self->__on_connection; return; } sub __close_sock { my ($self) = @_; $self->{__buf} = ''; delete $self->{__inside_watch}; delete $self->{__inside_transaction}; defined $self->{sock} or return 1; 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; }; # don't use select() function as it's caching database name, # rather call select directly defined $self->{current_database} and $self->__std_cmd('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"; } # this function works differently with a SSL socket cause it's not # possible to read just a few bytes from a TLS frame. 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; if (! defined $data) { # In case the caller catches the exception and wants to persist on using # the redis connection, let's forbid that. $self->__close_sock(); croak("Error while reading from Redis server: $!") } 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 { if ($self->{ssl}) { ## use peek to see if there is any data available instead of reading ## it cause it's not possible to read only a few bytes from an SSL ## frame. This does not work in WIN32 $sock->blocking(0); $res = $sock->peek($data, BUFSIZE); $sock->blocking(1); } else { $res = recv($sock, $data, BUFSIZE, MSG_DONTWAIT); } $err = 0 + $!; } if (defined $res) { ## have read some data if (length($data)) { $self->{__buf} .= $data unless $self->{ssl}; 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); ## if we got ECONNRESET, it might be due a timeout from the other side (on freebsd) ## or because an intermediate proxy shut down our connection using its internal timeout counter return 0 if ($err && $err == ECONNRESET); ## 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 2.000 =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'); ## Connect to Redis over a secure SSL/TLS channel. See ## IO::Socket::SSL documentation for more information ## about SSL_verify_mode parameter. my $redis = Redis->new( server => 'redis.tls.example.com:8080', ssl => 1, SSL_verify_mode => SSL_VERIFY_PEER, ); ## 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 up to 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 https://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( server => '192.168.0.1:6379', ssl => 1, SSL_verify_mode => SSL_VERIFY_PEER ); 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<< ssl >> You can connect to Redis over SSL/TLS by setting this flag if the target Redis server or cluster has been setup to support SSL/TLS. This requires IO::Socket::SSL to be installed on the client. It's off by default. =head3 C<< SSL_verify_mode >> This parameter will be applied when C<< ssl >> flag is set. It sets the verification mode for the peer certificate. It's compatible with the parameter with the same name in IO::Socket::SSL. =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) $r->auth(username, password) Authenticate to the server using Redis 6.0+ ACL System (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 03-pubsub.t100755000765000024 2640014360351554 16413 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 ); use constant DEFAULT_DELAY => 5; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; { my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 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); my ($another_kill_switch_stunnel, $yet_another_kill_switch_stunnel); END { $_ and $_->() for ($another_kill_switch, $yet_another_kill_switch, $another_kill_switch_stunnel, $yet_another_kill_switch_stunnel) } subtest 'basics' => sub { my %got; ok(my $pub = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), 'connected to our test redis-server (pub)'); ok(my $sub = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0); my $sub = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 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_kill_switch_stunnel, $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, ssl => $use_ssl, SSL_verify_mode => 0), '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"); if ($another_kill_switch_stunnel) { ok($another_kill_switch_stunnel->(), "stunnel killed"); } note("parent killed pub/sub redis server, signal child to proceed"); $sync->lpush('wake_up_child', 'the redis-server is dead, do your thing'); note("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, ssl => $use_ssl, SSL_verify_mode => 0); my $sub = Redis->new(server => $another_server, ssl => $use_ssl, SSL_verify_mode => 0); $sub->subscribe('chan', sub { }); note("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 note("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_kill_switch_stunnel, $another_server) = @ret; pop @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, ssl => $use_ssl, SSL_verify_mode => 0), '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"); if ($another_kill_switch_stunnel) { ok($another_kill_switch_stunnel->(), "stunnel killed"); } note("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 DEFAULT_DELAY; # relaunch it on the same port my ($yet_another_kill_switch, $yet_another_kill_switch_stunnel) = redis(port => $port); my $pub = Redis->new(server => $another_server, ssl => $use_ssl, SSL_verify_mode => 0); note("PARENT: has relaunched the server..."); sleep DEFAULT_DELAY; is($pub->publish('chan', 'v1'), 1, "PARENT: published and the child is subscribed"); note("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"); if ($yet_another_kill_switch_stunnel) { ok($yet_another_kill_switch_stunnel->(), "stunnel killed"); } } else { ## child my $sync = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); my $sub = Redis->new(server => $another_server, ssl => $use_ssl, SSL_verify_mode => 0, reconnect => 10, on_connect => sub { note "CHILD: reconnected (with a 10s timeout)"; } ); my %got; $sub->subscribe('chan', sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }); note("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) { note("CHILD: launch wait_for_messages(2), with reconnect..."); my $r = $sub->wait_for_messages(2); $r and last; note("CHILD: after 2 sec, nothing yet, retrying"); } note("CHILD: child received the message"); cmp_deeply(\%got, { 'chan' => 'v1:chan' }, "CHILD: the message is what we want"); exit(0); } }; ## And we are done done_testing(); 11-timeout.t100644000765000024 532414360351554 16557 0ustar00damien.krotkinestaff000000000000Redis-2.000/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::SpawnRedisServer; use Test::SpawnRedisTimeoutServer; use Errno qw(ETIMEDOUT EWOULDBLOCK); use POSIX qw(strerror); use Carp; use IO::Socket::INET; use Test::TCP; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 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, ssl => SSL_AVAILABLE, SSL_verify_mode => 0); ok($redis); my $res = $redis->get('foo');; is $res, 42, "the code didn't died, as expected"; }; 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, ssl => SSL_AVAILABLE, SSL_verify_mode => 0); ok($redis); like( exception { $redis->get('foo'); }, qr/Error while reading from Redis server:/, "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 %args = ( Listen => 1, LocalPort => $port, LocalAddr => '127.0.0.1', ); my $socket_class = 'IO::Socket::INET'; if ( SSL_AVAILABLE ) { $socket_class = 'IO::Socket::SSL'; $args{SSL_cert_file} = 't/stunnel/cert.pem'; $args{SSL_key_file} = 't/stunnel/key.pem'; } my $sock = $socket_class->new(%args) 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, ssl => SSL_AVAILABLE, SSL_verify_mode => 0); }, 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.t100755000765000024 267114360351554 16566 0ustar00damien.krotkinestaff000000000000Redis-2.000/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); use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; my $o = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); ## Make sure SCRIPT commands are available eval { $o->script_flush }; if ($@ && $@ =~ /ERR unknown command 'SCRIPT',/) { $c->(); $t->(); plan skip_all => 'This redis-server lacks scripting support'; } ## Commands related to Lua scripting # Specifically, these commands test multi-word commands ok($o->set(foo => 'bar'), 'set foo => bar'); my $script = "return 1"; my $script_sha = sha1_hex($script); my @ret = $o->script_exists($script_sha); ok(@ret && $ret[0] == 0, "script exists returns false"); @ret = $o->script_load($script); ok(@ret && $ret[0] eq $script_sha, "script load returns the sha1 of the script"); ok($o->script_exists($script_sha), "script exists returns true after loading"); ok($o->evalsha($script_sha, 0), "evalsha returns true with the sha1 of the script"); ok($o->eval($script, 0), "eval returns true"); ## All done done_testing(); 00-compile.t100644000765000024 273114360351554 16516 0ustar00damien.krotkinestaff000000000000Redis-2.000/tuse 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 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 @switches = ( -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; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-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.t100755000765000024 1155114360351554 16722 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; { my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 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, ssl => $use_ssl, SSL_verify_mode => 0), '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, re(qr{^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] } })], $r->info->{redis_version} ge '7.0.0' ? ( [ info => [qw], {}, ], ) : ( [ info => [qw], undef, re(qr{^ERR (?:syntax error|wrong number of arguments for 'info' command)$}) ], ) ); pipeline_ok 'pipeline with multi-bulk reply', ([hmset => [kapow => (a => 1, b => 2, c => 3)], 'OK'], [hmget => [kapow => qw], [3, 2, 1]],); pipeline_ok 'large pipeline', ( (map { [hset => [zzapp => $_ => -$_], 1] } 1 .. 5000), [hmget => [zzapp => (1 .. 5000)], [reverse -5000 .. -1]], [del => ['zzapp'], 1], ); subtest 'synchronous request with pending pipeline' => sub { my $clunk; is($r->get('clunk', sub { $clunk = $_[0] }), 1, 'queue a request'); is($r->set('kapow', 'zzapp', sub { }), 1, 'queue another request'); is($r->get('kapow'), 'zzapp', 'synchronous request has expected return'); is($clunk, 'eth', 'synchronous request processes pending ones'); }; subtest 'transaction with error and pipeline' => sub { my @responses; my $s = sub { push @responses, [@_] }; $r->multi($s); $r->set(clunk => 'eth', $s); $r->rpush(clunk => 'oops', $s); $r->get('clunk', $s); $r->exec($s); $r->wait_all_responses; is(shift(@responses)->[0], 'OK' , 'multi started' ); is(shift(@responses)->[0], 'QUEUED', 'queued'); is(shift(@responses)->[0], 'QUEUED', 'queued'); is(shift(@responses)->[0], 'QUEUED', 'queued'); my $resp = shift @responses; is ($resp->[0]->[0]->[0], 'OK', 'set'); is ($resp->[0]->[1]->[0], undef, 'bad rpush value should be undef'); like ($resp->[0]->[1]->[1], qr/(?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value/, 'bad rpush should give an error'); is ($resp->[0]->[2]->[0], 'eth', 'get should work'); }; subtest 'transaction with error and no pipeline' => sub { is($r->multi, 'OK', 'multi'); is($r->set('clunk', 'eth'), 'QUEUED', 'transactional SET'); is($r->rpush('clunk', 'oops'), 'QUEUED', 'transactional bad RPUSH'); is($r->get('clunk'), 'QUEUED', 'transactional GET'); like( exception { $r->exec }, qr{\[exec\] (?:WRONGTYPE|ERR) Operation against a key holding the wrong kind of value,}, 'synchronous EXEC dies for intervening error' ); }; subtest 'wait_one_response' => sub { my $first; my $second; $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->wait_one_response(); is($first, 1, 'after first wait_one_response(), first callback called'); is($second, undef, '... but not the second one'); $r->wait_one_response(); is($first, 1, 'after second wait_one_response(), first callback was not called again'); is($second, 1, '... but the second one was called'); $r->wait_all_responses(); is($first, 2, 'after final wait_all_responses(), first callback was called again'); is($second, 2, '... the second one was also called'); $r->wait_one_response(); is($first, 2, 'after final wait_one_response(), first callback was not called again'); is($second, 2, '... nor was the second one'); }; done_testing(); 05-nonblock.t100644000765000024 252014360351554 16674 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv, undef, undef, undef, undef, undef, $sock_temp_file) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; subtest 'non-block TCP' => sub { ok(my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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 { ok(my $r = Redis->new(sock => $sock_temp_file), '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(); 20-tie-hash.t100755000765000024 340514360351554 16574 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; ## Setup my %my_hash; ok(my $redis = tie(%my_hash, 'Redis::Hash', 'my_hash', server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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(); 10-tie-list.t100755000765000024 410614360351554 16622 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; ## Setup my @my_list; ok(my $redis = tie(@my_list, 'Redis::List', 'my_list', server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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(); 07-reconnect.t100755000765000024 2170414360351554 17101 0ustar00damien.krotkinestaff000000000000Redis-2.000/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); use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(timeout => 1); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; subtest 'Command without connection, no reconnect' => sub { ok(my $r = Redis->new(reconnect => 0, server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), '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, ssl => $use_ssl, SSL_verify_mode => 0), 'connected to our test redis-server'); $c->() if $c; ## Make sure the server is dead $t->() if $t; ## Make sure the tunnel is down 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->() if $c; ## Make sure previous server is dead $t->() if $t; ## Make sure previous tunnel is down my $port = empty_port(); ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), 'connected to our test redis-server'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect_1' => 1), 'set first key'); $c->() if $c; $t->() if $t; ok(($c, $t, $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->() if $c; ## Make sure previous server is dead $t->() if $t; ## Make sure previous tunnel is down my $port = empty_port(); ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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->() if $c; $t->() if $t; ok(($c, $t, $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->() if $c; ## Make sure previous server is dead $t->() if $t; ## Make sure previous tunnel is down my $port = empty_port(); ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis->new(reconnect => 3, server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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->() if $c; $t->() if $t; ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting second key should not fail'); }; my ($c2, $t2, $srv2) = redis(); END { $c2->() if $c2; $t2->() if $t2; } subtest 'Reconnection by read timeout discards pending commands' => sub { ok(my $r = Redis->new(server => $srv2, read_timeout => 1, reconnect => 1, ssl => $use_ssl, SSL_verify_mode => 0), 'connected to our test redis-server'); ok($r->set(foo => 'bar'), 'set foo bar'); eval { $r->debug(sleep => 4) }; ok $@, 'sleep command is timeout'; diag 'waiting for sleep command'; sleep 4; is($r->get('foo'), 'bar', 'the value of key foo is bar'); }; 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); } 02-responses.t100755000765000024 517314360351554 17117 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; ok(my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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(); 50-fork_safe.t100644000765000024 171614360351554 17034 0ustar00damien.krotkinestaff000000000000Redis-2.000/tuse strict; use warnings; use Test::More; use Redis; use lib 't/tlib'; use Test::SpawnRedisServer; use Test::SharedFork; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; my $o = Redis->new(server => $srv, name => 'my_name_is_glorious', ssl => $use_ssl, SSL_verify_mode => 0); 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; 06-on-connect.t100644000765000024 311014360351554 17127 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(timeout => 1); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; subtest 'on_connect' => sub { my $r; ok($r = Redis->new(server => $srv, on_connect => sub { shift->incr('on_connect') }, ssl => $use_ssl, SSL_verify_mode => 0), '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') }, ssl => $use_ssl, SSL_verify_mode => 0), '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') }, ssl => $use_ssl, SSL_verify_mode => 0), '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(); stunnel000755000765000024 014360351554 16011 5ustar00damien.krotkinestaff000000000000Redis-2.000/tkey.pem100644000765000024 625314360351554 17452 0ustar00damien.krotkinestaff000000000000Redis-2.000/t/stunnel-----BEGIN RSA PRIVATE KEY----- MIIJJwIBAAKCAgEAxfgOWjIORtnv0HSIn8vT/6esqVHfMLsHRPwBcFbYrPxmWsYn SH/rPbruUqIEukJJGvH6bXUkT2q5NL4IPqL+7CTcwgir2lKPgpBZcfrJY5eZQIpK Zq1uu2MkA03B+5HKylSH0sTB0VxGTHwowfxk3mIFbScDQzgKggLLIiOFi5aRg+Pd K/7GWITntugxExm420vVT2BuHkdoeFBYl4QJ/YNODClRSSPkfrLinAKp4Cb4hi1L BgQb1I7B2xc5LSMp3RB+R9Vmf7cBNu4g45WmiS96JxccNVEtDikwFcbEvfYCEldS 79/jHdJbL3Yg4kHsgKXj45wjnc1gIGVgS9g+C6BAo6DvD7re7nQdhLNf69785d7t 5fY03nHvrFPnBDep2EmlQ69hbae45x1BPifAkBInxQYEATyjGzYdp29rZWW+AOUI j4f/wGXtzZG0FcDSBE8NSUtJsYe5XimSakJYU0J8VSaXRFRwc+ZNf0d4lOR+YxsA LDthLnR/+f6dhecSJ06m6xCVdJVpTBDxGe5l91QIJiNKCjhAtoXtqKXVSCvUtFEs klohUdguAkDMW9CA/TrvMVyU1GS1tyhXFzpwbXNPTw6P7eECiuO35K32BkJnn3Pa ZJQ+bi6KwXir7RWqvDFFghlRsuw6QjmbUIE8Z/5XjBx99jAumJ6Old9e3NcCAwEA AQKCAgBxdtzzASGBpkN23HO58p8NNlMVsKEVUvy1oyJH+t6xNvCLMmsteHOhq9QQ dF/1SSyRTwNTXQJ0qhyAiDI9hDpLqk0EwOeOeCdck9NQKobml+r0PM6rztdae1YW tqhpwYPTN2Opf6/+iL6Z88eAd2JwuwmVJ/kMu7/6CBPY+zb9bEz2pNEM+DdCYNpV 0PrfkayLtAkMN56lqBPOcW51WO5I6MsA2WWHYBUEMQ8Ej9pBaNSkQq1vQ0eYKkId ik/w+OhzlZJrJXpb1M3TZ+RdzFXo5tdCNFKslFwYc67lrEjy/17smDQm29FWNEyj BTePtm0QxwO4XrNjLGTd7Hymu8fC7ACrer16MkIe8OxsqMckJoPtiR3GaOryHD2D cqFG84y0zzmsNT1QAQdT4ITyA5nU1AQgR5i2Nsu+cvd1hnjNCEhSJM/d22dYQWEX cGrJELxaPCkpl40l796WJvQ0dbwKqbrRrS86ZgjxA+s4bQ0TLBXGqBSEXB/BePCF hUMjL0+zlhG54tWL74FZ5RBs50SkG2c0O9X9fY/tJ0jqifmeZ2/YaP3MQUHh+MUd BuRbNq8IAnrFuqKihM5xQ3rRXfJzdOnvNd0EbcuJs8wGmzbmttIFraHYMFY01p9j lP+DeLdO5nliOkxc17jTPoXQcHdgPGSz7QK7S8kOOVPljaGw0QKCAQEA496cSRLG 35n8ed24WYlcSVY3t3E/PBwnB4zArRPZFwiWIyIVmAqH6A982oB4NZolB9La/N3v FDls8xtIkr7aD6iSV1JFtzbUdmIIi2aOeEkhWfotRmFWEs83uRFBHG68pMldPVuQ PZf1SaKiAYy3E/eDAMfgr/NWkrpz8qlGJZUJMg5/nlrOnKDAohrYEZ+kxiJWZ82N uGfHb8AhQi2eJjU+FPJL77uUOycE08pOQ/436TjNP2S+hGbhcJowp+hGBLGUF1dg Vam267l+ula8+fqtFiLZNG0FP8RTYmUxIUP96iieckYmiNpJ4lU/XGO0MvAC4Vve COYtHHjDLdaglQKCAQEA3mh+QyYWx12+vvIo+kYi4Z1wMfXHG+bjjsGFNxoXpLb0 yFIBBYN9K76zQTUG0yQckaNbgBkRhUQej6Drrqd6HPmfQybK2YOVhnF/XGg1G0VT YXGPFeL2g4J5YtEYgVupahivehvZ5HiDUocmOSqUioa4bJUzGapoXRbldrg6xwtH 3Uj3UlY+1YMBIc6fztVgCOubZYrmDzFdnEpw5HOGFYBGkAq/5lPju/m3BdA+yjO/ kgDsP7LS/mJy9o/KZG8JWm7d5x8TMFIch62GI56ebDqJYlBVUDVC17XTidSrIfo3 rNZpy5zN1D16Qq8Zbfad/KHqImALUsbAB7UGVIVQuwKCAQB9ZKLcE1kc8r/c0AYC P3RpZuiCKe+CRHu1y967X5C2/CKicr8vS5w+N0edddSwqoJ2K7IWNIq7tl4d6YWm OyAEPd9J7hwvFh0UiB3rmCQOTS/tM552fFnBQAaJ8NTDsKxegfCtMxXMzzJLsxMz hxu4ARw18cfTCzU4ySHFByFyzPCiexf/LDlGN6/JhLwh9pfV8E9cD+FM+M7mz/N9 V10P6XygSjU/Vxna8z3Uzh8Di4F49aj8mZO9iF/GdxMPUuI08wNrVMnOWfYvAYSb Rd/4L9nPtJ2SG+wniwHXw5ellqTDllaay7+oz3aY9hBH5xXicfEj0kn82603Xb0K HHGBAoIBAAUXJyyqRoMxphgAuudfi5TWYacDFReSZUrzKvVj536hoWCkX9mcdNT3 fGrVp95VSUIcFxALgtcmA/0NldddhfH71KVY0fPAiz+UgXHAANcq8wmb68Z4d2Pz LIwSdRkg2/PNtNZ6pLYR/A97gGh2jQfOpZH2qEDCIblfuMjK1q2PmIl8Dg0YZD/G y9PWQtodECGkIt5kG3fljVryaTsRWdRMJ1FMra+74859nK7JYWaHYK8azk127lVc M31pNRyvXetv9ixADdRhTL3ePt+51a5seJCDfjBjx6/gPYM+FtykOXn/PlSmth9R eObl0xMtPdh2bEF1KU0vt111yztMAdkCggEAYU+g86VRCMMysr21B++CVOwxebe5 FhkNrDXtemFn58ZXqcjHU+MMgqvf6jjWW4n820jiJF1kZTviZdWLtCckjJRAExs2 YIgIIXgTsiSj/FTsGJRE7SYRabLgu++rEIB+/T1x5fihFxL9zfuQazSIkp2TTdD1 nsCvdDsjNIA8a02aNqo8CCOhcZgY4UtjAV7HpTzCnA9UTorRVmEBJeYtYrRHfla8 Gb05bepCQ74H0R5UDZaH9i0H27qqVkBZs0Nca4AbZ/IqGG5oIm/FIW4+owh/noR1 CED3mN9bvEBTZzm4jxVtbFrr9Ffpx3Fvi8/MA77/q3uD5E8DiLajRt0rGQ== -----END RSA PRIVATE KEY----- Redis000755000765000024 014360351554 15672 5ustar00damien.krotkinestaff000000000000Redis-2.000/libList.pm100644000765000024 454414360351554 17312 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 = '2.000'; # 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 2.000 =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 Hash.pm100644000765000024 466414360351554 17265 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 = '2.000'; # 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 2.000 =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 42-client_cmds.t100644000765000024 463514360351554 17365 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(requires_version => '2.6.9'); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; subtest 'client_{set|get}name commands' => sub { ok(my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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', ssl => $use_ssl, SSL_verify_mode => 0), '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-$$"}, ssl => $use_ssl, SSL_verify_mode => 0), '... with a dynamic name'); is($r->client_getname, "cache-for-$$", '...... name was properly set'); ok($r = Redis->new(server => $srv, name => sub {undef}, ssl => $use_ssl, SSL_verify_mode => 0), '... 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 }, ssl => $use_ssl, SSL_verify_mode => 0), "Using dynamic name, for generation $generation"); my $n = "gen-$$-$generation"; is($r->client_getname, $n, "... name was set properly, '$n'"); } }; done_testing(); 08-unix-socket.t100644000765000024 240314360351554 17343 0ustar00damien.krotkinestaff000000000000Redis-2.000/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, undef, undef, undef, undef, undef, undef, undef, $sock_temp_file) = redis(); END { $c->() if $c } my $conn = sub { my @args = @_; my $r; is( exception { $r = Redis->new(sock => $sock_temp_file, @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(); cert.pem100644000765000024 357314360351554 17621 0ustar00damien.krotkinestaff000000000000Redis-2.000/t/stunnel-----BEGIN CERTIFICATE----- MIIFWTCCA0GgAwIBAgIJAJmwzHYpCw2LMA0GCSqGSIb3DQEBCwUAMEIxCzAJBgNV BAYTAlhYMRUwEwYDVQQHDAxEZWZhdWx0IENpdHkxHDAaBgNVBAoME0RlZmF1bHQg Q29tcGFueSBMdGQwIBcNMTgwNTIzMDg1NjQ3WhgPMjExODA0MjkwODU2NDdaMEIx CzAJBgNVBAYTAlhYMRUwEwYDVQQHDAxEZWZhdWx0IENpdHkxHDAaBgNVBAoME0Rl ZmF1bHQgQ29tcGFueSBMdGQwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoIC AQDF+A5aMg5G2e/QdIify9P/p6ypUd8wuwdE/AFwVtis/GZaxidIf+s9uu5SogS6 Qkka8fptdSRPark0vgg+ov7sJNzCCKvaUo+CkFlx+sljl5lAikpmrW67YyQDTcH7 kcrKVIfSxMHRXEZMfCjB/GTeYgVtJwNDOAqCAssiI4WLlpGD490r/sZYhOe26DET GbjbS9VPYG4eR2h4UFiXhAn9g04MKVFJI+R+suKcAqngJviGLUsGBBvUjsHbFzkt IyndEH5H1WZ/twE27iDjlaaJL3onFxw1US0OKTAVxsS99gISV1Lv3+Md0lsvdiDi QeyApePjnCOdzWAgZWBL2D4LoECjoO8Put7udB2Es1/r3vzl3u3l9jTece+sU+cE N6nYSaVDr2Ftp7jnHUE+J8CQEifFBgQBPKMbNh2nb2tlZb4A5QiPh//AZe3NkbQV wNIETw1JS0mxh7leKZJqQlhTQnxVJpdEVHBz5k1/R3iU5H5jGwAsO2EudH/5/p2F 5xInTqbrEJV0lWlMEPEZ7mX3VAgmI0oKOEC2he2opdVIK9S0USySWiFR2C4CQMxb 0ID9Ou8xXJTUZLW3KFcXOnBtc09PDo/t4QKK47fkrfYGQmefc9pklD5uLorBeKvt Faq8MUWCGVGy7DpCOZtQgTxn/leMHH32MC6Yno6V317c1wIDAQABo1AwTjAdBgNV HQ4EFgQU3csnTCuLU1pv61r/aYOnfF4kKEgwHwYDVR0jBBgwFoAU3csnTCuLU1pv 61r/aYOnfF4kKEgwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAgEAQnI1 Li1F+rN+0UHTB2Bif+iOX6nXWRZDe5ULOkHGyxlFFdQJp2Kd+O9AK6dqyb6v1pLJ x3RbHx0VhtCVC4Ebwe4AtPyzr25Chlhzel6gOVeul1V0GkGQoew55sfJyWJWJz6j lwOxws6EePBVGUIs7wpDeoyGJu+aJ6sbQ3IYwRR6EF+12v6/DvUcECAechdY6uNY yswMs7nrShv2WM8Wcp1PSvdSAEjqSZYkSOAe+NSLw1bx4roHWFiE9StGaHxeI1O9 p4KZ/ljUsX+xo3w4xWZX5vAqlBBqPo4kUdZhwlW2wyG1yLDi4A8zgFOs6hqQ59XQ 2UIwrqdiWzur9jsLUiZbXkPwiqF7mc1+U1GV/oU7/ahsfLNc3siE6Gt/1c6PJzuH 0KM2xfMS+4IXTXQrwIZNB3fVUdpttpPHRLaK2XkZcxxT7yR9nldIvaytsUuhz7S4 GlEVqebNxXngocNaMRCkZ2lMcYCbvrqer0KxFFfblR8BJkFvUPBa3vRizsWuD9bp 8iQdrPx3n1WhTR61octOptc+6+wPTxpitkd40zw0QBtpHh0W3/soTk/5JoLGWBCS 7Q9lUjyVvswIAefCt/ki9F/a8nb+/v8fx4rfgtaXNNPJiBM4buHkr9vMr6eFvyxb e/3z0X7Fw6ARAIRp/vnOzGDpRxpyA77+LXwAkqs= -----END CERTIFICATE----- scripts000755000765000024 014360351554 15545 5ustar00damien.krotkinestaff000000000000Redis-2.000publish.pl100755000765000024 101014360351554 17703 0ustar00damien.krotkinestaff000000000000Redis-2.000/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> "; } author-distmeta.t100644000765000024 70014360351554 17735 0ustar00damien.krotkinestaff000000000000Redis-2.000/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{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); 44-no-unicode-bug.t100755000765000024 176014360351554 17715 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; my ($c, $t, $srv) = redis(); END { $c->() if $c; $t->() if $t; } my $use_ssl = $t ? SSL_AVAILABLE : 0; ok(my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0), '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(); Sentinel.pm100644000765000024 434014360351554 20152 0ustar00damien.krotkinestaff000000000000Redis-2.000/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 = '2.000'; # 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 2.000 =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 author-pod-coverage.t100644000765000024 104214360351554 20516 0ustar00damien.krotkinestaff000000000000Redis-2.000/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{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # 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' }); tools000755000765000024 014360351554 15216 5ustar00damien.krotkinestaff000000000000Redis-2.000html_doc_scrapper.pl100644000765000024 362014360351554 21404 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; redis-benchmark.pl100755000765000024 202114360351554 21276 0ustar00damien.krotkinestaff000000000000Redis-2.000/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() }; }, } ); Test000755000765000024 014360351554 16172 5ustar00damien.krotkinestaff000000000000Redis-2.000/t/tlibSpawnRedisServer.pm100644000765000024 1712114360351554 22160 0ustar00damien.krotkinestaff000000000000Redis-2.000/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); use constant SSL_WAIT => 2; # Wait a bit till the mock secure tunnel is up use constant SSL_AVAILABLE => eval { require IO::Socket::SSL }; our @EXPORT = qw( redis sentinel ); our @EXPORT_OK = qw( redis reap ); sub redis { my %params = ( timeout => 120, @_, ); my $use_ssl = $ENV{USE_SSL} ? SSL_AVAILABLE : 0; # Sentinel mode does not support SSL/TLS yet so we have this # option to explicitly turn off SSL/TLS in testing. $use_ssl = 0 if $params{no_ssl}; my $port = empty_port(); my $local_port = $port; my $stunnel_port = empty_port(); if ( ! $use_ssl ) { # Use this specific port in non-TLS mode $params{port} and $local_port = $params{port}; } else { # Reuse the same port if it is specified $params{port} and $stunnel_port = $params{port}; } my $addr = "127.0.0.1:$local_port"; unlink("redis-server-$addr.log"); unlink('dump.rdb'); # Spawn the tunnel first so that we know if we can test SSL/TLS setup my $stunnel_addr = "127.0.0.1:$stunnel_port"; my ($ver, $c, $t); if ( $use_ssl ) { Test::More::diag("Spawn stunnel $stunnel_addr:$addr") if $ENV{REDIS_DEBUG}; my ($stunnel_fh, $stunnel_fn) = File::Temp::tempfile(); $stunnel_fh->print("pid= debug = 0 foreground = yes [redis] accept = $stunnel_port connect = $addr cert = t/stunnel/cert.pem key = t/stunnel/key.pem "); $stunnel_fh->flush; my $stunnel_path = $ENV{STUNNEL_PATH} || 'stunnel'; if (!can_run($stunnel_path)) { Test::More::diag("Could not find binary stunnel, revert to plain text Redis server"); $addr = $stunnel_addr; $local_port = $stunnel_port; $use_ssl = 0; } else { eval { $t = spawn_tunnel($stunnel_path, $stunnel_fn) }; if (my $e = $@) { reap(); Test::More::diag("Could not start stunnel, revert to plain text Redis server: $@"); $use_ssl = 0 } } sleep(SSL_WAIT) if $use_ssl; } my ($fh, $fn) = File::Temp::tempfile(); my (undef, $sock_temp_file) = File::Temp::tempfile(); $fh->print(" timeout $params{timeout} appendonly no daemonize no port $local_port bind 127.0.0.1 unixsocket $sock_temp_file unixsocketperm 700 loglevel debug logfile FOOredis-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; } 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; } } if ( $use_ssl ) { # Connect to Redis through stunnel return ($c, $t, $stunnel_addr, $ver, split(/[.]/, $ver), $stunnel_port, $sock_temp_file); } else { # Connect to Redis directly return ($c, undef, $addr, $ver, split(/[.]/, $ver), $local_port, $sock_temp_file); } } 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 spawn_tunnel { my ($stunnel, $stunnel_cfg) = @_; my $cmd = "$stunnel $stunnel_cfg"; my $pid = fork(); if ($pid) { require Test::More; Test::More::diag("Starting stunnel $cmd pid $pid") if $ENV{REDIS_DEBUG}; my $alive = $$; my $c = sub { return unless $alive; return unless $$ == $alive; ## only our creator can kill us Test::More::diag("Killing stunnel at $pid") if $ENV{REDIS_DEBUG}; kill(15, $pid); my $failed = reap($pid); Test::More::diag("Failed to kill stunnel at $pid") if $ENV{REDIS_DEBUG} and $failed; $alive = 0; return !$failed; }; return $c; } elsif (defined $pid) { exec($cmd); warn "## In child Failed exec of '$cmd': $!, "; exit(1); } die "Could not fork() stunnel: $!"; } 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; benchmarks000755000765000024 014360351554 17333 5ustar00damien.krotkinestaff000000000000Redis-2.000/toolsread_vs_sysread.pl100644000765000024 412514360351554 23207 0ustar00damien.krotkinestaff000000000000Redis-2.000/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.pm100644000765000024 263014360351554 23506 0ustar00damien.krotkinestaff000000000000Redis-2.000/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; use constant SSL_AVAILABLE => eval { require IO::Socket::SSL }; sub create_server_with_timeout { my $timeout = shift; Test::TCP->new( code => sub { my $port = shift; my %args = ( Listen => 5, Timeout => 1, Reuse => 1, Blocking => 1, LocalPort => $port, ); my $socket_class = 'IO::Socket::INET'; if ( SSL_AVAILABLE ) { $socket_class = 'IO::Socket::SSL'; $args{SSL_cert_file} = 't/stunnel/cert.pem'; $args{SSL_key_file} = 't/stunnel/key.pem'; } my $socket = $socket_class->new(%args) or die "failed to connect to RedisTimeoutServer: $!"; my $buffer; while (1) { my $client = $socket->accept(); next unless defined $client; if (defined (my $got = <$client>)) { sleep $timeout; $client->print("+42\r\n"); } } }, ); } 1; readline_vs_sysread_vs_recv000755000765000024 014360351554 25107 5ustar00damien.krotkinestaff000000000000Redis-2.000/tools/benchmarksrun.pl100755000765000024 211214360351554 26407 0ustar00damien.krotkinestaff000000000000Redis-2.000/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.pl100755000765000024 335614360351554 30031 0ustar00damien.krotkinestaff000000000000Redis-2.000/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.pl100755000765000024 337614360351554 30546 0ustar00damien.krotkinestaff000000000000Redis-2.000/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.pl100755000765000024 150514360351554 30647 0ustar00damien.krotkinestaff000000000000Redis-2.000/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.pl100755000765000024 132114360351554 31076 0ustar00damien.krotkinestaff000000000000Redis-2.000/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"; } }