├── .gitignore ├── .travis.yml ├── Changes ├── README.pod ├── dist.ini ├── lib ├── Redis.pm └── Redis │ ├── Hash.pm │ ├── List.pm │ └── Sentinel.pm ├── scripts ├── publish.pl └── redis-benchmark.pl ├── t ├── 01-basic.t ├── 02-responses.t ├── 03-pubsub.t ├── 04-pipeline.t ├── 05-nonblock.t ├── 06-on-connect.t ├── 07-reconnect.t ├── 08-unix-socket.t ├── 09-env-redis-server.t ├── 10-tie-list.t ├── 11-timeout.t ├── 12-scan-callback.t ├── 20-tie-hash.t ├── 30-scripts.t ├── 42-client_cmds.t ├── 44-no-unicode-bug.t ├── 50-fork_safe.t ├── 60-sentinel.t ├── stunnel │ ├── cert.pem │ └── key.pem └── tlib │ └── Test │ ├── SpawnRedisServer.pm │ └── SpawnRedisTimeoutServer.pm └── tools ├── benchmarks ├── read_vs_sysread.pl └── readline_vs_sysread_vs_recv │ ├── client-readline.pl │ ├── client-recv.pl │ ├── client-sysread.pl │ ├── run.pl │ └── server-generator.pl └── html_doc_scrapper.pl /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | blib 3 | pm_to_blib 4 | Makefile 5 | Makefile.old 6 | *.sw[op] 7 | *.tar.gz 8 | dump.rdb 9 | Redis-* 10 | .build/ 11 | *.log 12 | t/*.log 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | services: 3 | - redis-server 4 | perl: 5 | - "5.26" 6 | - "5.28" 7 | - "5.30" 8 | before_install: 9 | - "git config --global user.name TravisCI" 10 | - "git config --global github.user dams" 11 | install: 12 | - "cpanm --quiet --notest Dist::Zilla" 13 | - "dzil authordeps | xargs cpanm --quiet --notest && dzil listdeps --develop | xargs cpanm --quiet --notest" 14 | script: 15 | - "dzil test --release" 16 | - "USE_SSL=1 dzil test --release" 17 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Redis 2 | 3 | {{$NEXT}} 4 | 5 | 2.000 2023-01-13 22:55:51+01:00 Europe/Paris 6 | 7 | * #166: add ssl, username and password args to redis sentinel (Merwan Ouddane) 8 | * #163: Add support for username/password AUTH (Joel Chornik) 9 | * #162: Retry socket connect if errno is EINTR (Michael Schout) 10 | * #158: Better fix of redis version in test (Michal Josef Špaček) 11 | * #156: Fix of test for multiple arguments in info command (Michal Josef Špaček) 12 | 13 | 1.999 2022-01-14 21:42:33+01:00 Europe/Paris 14 | 15 | * enable ssl support 16 | * remove test expression that is problematic on OpenBSD and NetBSD 17 | 18 | 1.997 2020-80-17 10:03:00+01:00 Europe/Paris 19 | 20 | * various travis fixes 21 | * #112 applied 22 | * enable unix socket tests by enabling them in the local test server 23 | * #144: change exists into defined 24 | * #146: Fix sentinel option typo 25 | 26 | 1.996 2020-03-05 16:17:21+01:00 Europe/Paris 27 | 28 | 1.996 2020-03-05 11:56:11+01:00 Europe/Paris 29 | * #139: Fix for "Unexpected error condition 104/linux" 30 | 31 | 1.995 2019-07-22 11:20:07+02:00 Europe/Paris 32 | * revert #136, remove deps that are in core, as it breaks builds in some setup 33 | 34 | 1.994 2019-07-22 07:51:57+02:00 Europe/Paris 35 | * Don't send SELECT if current database equals the one being selected (@dallaylaen, #132) 36 | 37 | 1.993 2019-07-22 07:01:30+02:00 Europe/Paris 38 | * fix missing deps (@manwar, #136 ) 39 | 40 | 1.992 2019-07-21 18:27:23+02:00 Europe/Paris 41 | * relax the check in 04-pipeline.t about unknown command output (#130) 42 | 43 | 1.991 2016-08-23 16:04:29CEST+0200 Europe/Paris 44 | * release as a normal release after successful testing of the dev releases 45 | 46 | 1.990_02 2016-08-06 20:30:30CEST+0200 Europe/Paris 47 | * move reconnection test in reconnect test file to avoid test issues 48 | (skip_all but still run some tests) 49 | 50 | 1.990_01 2016-08-05 17:17:28CEST+0200 Europe/Paris 51 | * fix issue #122: don't attempt to close an already closed or undefined socket 52 | * fix issue #120 and #111: don't depend on locales for matching error messages 53 | * fix issue #118: spelling mistake 54 | * fix issue #116: forbid continuing using socket after a read timeout 55 | * fix issue #115: Unexpected error condition 54/freebsd 56 | 57 | 1.982 2016-02-11 09:02:40CET+0100 Europe/Paris 58 | * fix issue #117: fix backward compatibility with 5.8 59 | 60 | 1.981 2015-09-29 12:31:57CEST+0200 Europe/Paris 61 | * fix a bug where when not yet connected, pid is undef, leading to warnings 62 | 63 | 1.980 2015-08-24 09:48:08CEST+0200 Europe/Paris 64 | * fix "set" documentation as per Emanuele Tomasi suggestion 65 | 66 | 1.979 2015-05-14 14:28:35CEST+0200 Europe/Amsterdam 67 | 68 | * depends on IO::Socket::Timeout 0.29 that fixes an important bug on 69 | Windows, Solaris, when mixing sockets with and without timeouts. 70 | 71 | 1.978 2015-01-28 09:52:27 Europe/Amsterdam 72 | 73 | * reshape the documentation 74 | * croak when reconnecting while responses are pending (#101) 75 | * merge PR#106 ( support "0" in topic ) 76 | 77 | 1.977 2015-01-28 01:10:31 Europe/Amsterdam 78 | 79 | 1.976 2014-10-03 15:05:58 Europe/Amsterdam 80 | 81 | 1.975 2014-08-03 20:50:25 Europe/Amsterdam 82 | 83 | * Clarification about reconnect and read_timeout (#89) 84 | * Test::CPAN::Meta (et al.) are required even if unused (#92) 85 | 86 | 1.974 2014-05-16 21:42:48 Europe/Amsterdam 87 | 88 | * released as stable version, no change 89 | 90 | 1.973_04 2014-05-12 22:53:06 Europe/Amsterdam 91 | 92 | * release again, last one was screwed up. 93 | * fix #85 (PR #86) reconnect during transaction 94 | 95 | 1.973_03 2014-05-12 22:49:07 Europe/Amsterdam 96 | 97 | * fix #85 (PR #86) reconnect during transaction 98 | 99 | 1.973_02 2014-04-30 12:04:29 Europe/Amsterdam 100 | 101 | * merge PR #84 optimize try read sock 102 | 103 | 1.973_01 2014-04-26 18:00:31 Europe/Amsterdam 104 | 105 | * use new network code from Ivan Kruglov 106 | * fix sentinel tests 107 | * fix #81: doc for 'every' option 108 | 109 | 1.972 2014-02-18 00:54:01 Europe/Amsterdam 110 | * Sentinel features (connections, timeouts, etc) support 111 | * various bugfixes and testfixes 112 | * fix network code for BSDs 113 | * no_auto_connect_on_new 114 | 115 | 1.971 2014-02-01 09:55:11 Europe/Paris 116 | 117 | * skip some tests that fail on some platforms for now 118 | 119 | 1.970 2014-01-30 15:07:42 Europe/Amsterdam 120 | 121 | * fix tests breaking in some case 122 | 123 | 1.969 2014-01-30 13:19:28 Europe/Amsterdam 124 | 125 | * Clarification for (p)unsubscribe commands. 126 | * use Test::TCP for testing 127 | 128 | 1.968 2014-01-30 12:19:11 Europe/Amsterdam 129 | 130 | * Add a no_auto_connect_on_new parameter to new() to allow users 131 | to call $x = Redis->new and then $x->connect, instead of Redis 132 | auto-connecting. Useful for tuning the cnx_timeout parameter. 133 | 134 | 1.967 2013-12-28 22:58:55 Europe/Paris 135 | * use new IO::Socket::Timeout with different API 136 | 137 | 1.966 2013-12-17 13:58:33 Europe/Amsterdam 138 | * fix tests for Redis 2.8 139 | 140 | 1.965 2013-11-29 09:28:36 Europe/Amsterdam 141 | 142 | * fix #60: TEST_REQUIRES needs newer MakeMaker 143 | * fix #34: perl-redis doesn't receive subcribed message if server restart 144 | * fix #38: select new database doesn't survive after reconnect 145 | * minor documentation fixes 146 | 147 | 1.964 2013-11-14 15:45:08 Europe/Amsterdam 148 | * minor fix to dist.ini to fix github url 149 | 150 | 1.963 2013-11-13 22:44:29 Europe/Paris 151 | 152 | * Add documentation for the slowlog command PR #44 (rgs) 153 | * doc fix, duplicate spop PR #48 (nightlord) 154 | * Redis client is now fork safe PR #51 (songmu) 155 | * rewrite dist.ini 156 | 157 | 1.962 2013-10-16T14:58:30Z 158 | * merge #54 (fix for broken test) 159 | * Parameter name to new() can be a CodeRef, dynamic connection names 160 | * admin: added co-maintainer Damien Krotkine 161 | 162 | 1.961 2013-01-23T15:09:47Z 163 | * Add wait_one_response() for better pipeline management 164 | 165 | 1.960 2013-01-23T11:28:40Z 166 | * Make the new() name parameter safe to use with all redis- 167 | server versions 168 | 169 | 1.959 2013-01-22T14:46:42Z 170 | * __try_read_sock: test error conditions more thoroughly (issue #31) 171 | * Improve Test::SpawnRedisServer: multi-server support 172 | * tidyall the code and docs 173 | 174 | 1.958 2013-01-15T16:54:40Z 175 | * Support for name constructor parameter, set connection name 176 | * Add documentation for CLIENT * commands 177 | * Improve reliability of Test::SpawnRedisServer 178 | 179 | 1.957 2013-01-15T13:18:07Z 180 | * Fix minimum Perl version 181 | 182 | 1.956 2013-01-15T10:35:10Z 183 | * Add on_connect callback to Redis constructor (issue 28) 184 | * Make sure quit() doesn't die when the socket is already dead (issue 30); 185 | * Switch to Digest::SHA, one less non-core dep RT#81841 186 | * Try and make Travis-CI more useful, ask for a redis-server 187 | * Update SUPPORT section, moving bugtracker to GitHub issues 188 | 189 | 1.955 2012-10-10T11:43:44Z 190 | * Skip 30-scripts.t if the redis-server found lacks script support 191 | 192 | 1.954 2012-10-10T11:16:22Z 193 | * Support for multi-word commands such as "SCRIPT LOAD". 194 | * Try another fix for Windows non-blocking reads 195 | 196 | 1.953 2012-09-05T00:49:11Z 197 | * Tweak travis.ci setup 198 | 199 | 1.952 2012-09-04T11:22:18Z 200 | * Added automatic authentication after connection establishment 201 | * Support Redis 2.6: Aaron Crane 202 | * Attempt to fix non-blocking read on Windows 203 | * Enable travis.ci support on the repository 204 | 205 | 1.951 2012-03-13T10:17:09Z 206 | * Remove Tie::StdHash from our dependencies list, its part of core 207 | and it creates problems with some CPAN clients 208 | 209 | 1.950 2012-03-12T13:54:10Z 210 | * DEPRECATED: the encoding attribute to new() - we will not support 211 | automatic decoding after 2.000, so please test your code with 212 | encoding => undef now. 213 | * Add pipeline support: Aaron Crane arc@github++! 214 | * Cache AUTOLOAD calls: improves performance a bit, fixes #2 215 | * Fix: apply reconnect logic to KEYS and INFO 216 | * Fix: forbid PING and SHUTDOWN in SUBSCRIBE mode 217 | * Updated docs covering pipelining and multi/exec 218 | * Updated docs to point users to Github for code and issues 219 | 220 | 1.926 Wed Jan 11 15:48:11 UTC 2012 221 | * Fix auto-reconnect when the server is dead or a 222 | client timeout. 223 | See https://github.com/melo/perl-redis/issues/1#issuecomment-3444989 224 | 225 | 1.925 Tue Jan 10 16:02:04 UTC 2012 226 | * Implemented auto-reconnect 227 | * Add support for UNIX domain sockets 228 | * Make REDIS_SERVER work with both TCP and UNIX domain sockets 229 | * Make the test suite workaround a missing redis-server binary 230 | * Assorted small bug fixes 231 | * Improve documentation 232 | 233 | 1.904 Sat Mar 5 23:10:48 UTC 2011 234 | * Fix bug with NIL multi-bulk replies (Case 42) RT#64040 235 | 236 | 1.903 Tue Feb 22 13:04:24 UTC 2011 237 | * remove the Guard dependency 238 | 239 | 1.902 Sat Feb 5 12:38:57 UTC 2011 240 | * fix: ping() no longer dies (RT #62489) 241 | * fix: shutdown() no longer dies 242 | 243 | 1.901 Sat Feb 5 11:15:04 UTC 2011 244 | * Released 1.900_01 as latest version 245 | 246 | 1.900_01 Sun Jan 30 06:03:14 UTC 2011 247 | * admin: change of maintainer to Pedro Melo 248 | * feature: full support for Redis 2.x multi-bulk protocol 249 | * feature: support for Redis PUBLISH/SUBSCRIBE commands 250 | * feature: automatic encoding can be turned off, use encoding => undef on new() (performance++) 251 | * performance: substantial performance improvements, specially with large responses 252 | * fix: add POP method to our List Tie interface 253 | 254 | 1.2001 Wed Mar 17 17:22:01 CET 2010 255 | * feadure: Redis protocol 1.2 support by Jeremy Zawodny CPAN RT #54841 256 | * Version bump to be in-sync with Redis version 257 | * bug: Correctly round-trip utf-8 encoded characters 258 | 259 | 0.08 Tue Mar 24 22:38:59 CET 2009 260 | * This version supports new protocol introduced in beta 8 261 | * Version bump to be in-sync with Redis version 262 | 263 | 0.01 Sun Mar 22 19:02:17 CET 2009 264 | * First version, tracking git://github.com/antirez/redis 265 | 266 | -------------------------------------------------------------------------------- /README.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =encoding UTF-8 4 | 5 | =head1 NAME 6 | 7 | Redis - Perl binding for Redis database 8 | 9 | =head1 VERSION 10 | 11 | version 2.000 12 | 13 | =head1 SYNOPSIS 14 | 15 | ## Defaults to $ENV{REDIS_SERVER} or 127.0.0.1:6379 16 | my $redis = Redis->new; 17 | 18 | my $redis = Redis->new(server => 'redis.example.com:8080'); 19 | 20 | ## Set the connection name (requires Redis 2.6.9) 21 | my $redis = Redis->new( 22 | server => 'redis.example.com:8080', 23 | name => 'my_connection_name', 24 | ); 25 | my $generation = 0; 26 | my $redis = Redis->new( 27 | server => 'redis.example.com:8080', 28 | name => sub { "cache-$$-".++$generation }, 29 | ); 30 | 31 | ## Use UNIX domain socket 32 | my $redis = Redis->new(sock => '/path/to/socket'); 33 | 34 | ## Connect to Redis over a secure SSL/TLS channel. See 35 | ## IO::Socket::SSL documentation for more information 36 | ## about SSL_verify_mode parameter. 37 | my $redis = Redis->new( 38 | server => 'redis.tls.example.com:8080', 39 | ssl => 1, 40 | SSL_verify_mode => SSL_VERIFY_PEER, 41 | ); 42 | 43 | ## Enable auto-reconnect 44 | ## Try to reconnect every 1s up to 60 seconds until success 45 | ## Die if you can't after that 46 | my $redis = Redis->new(reconnect => 60, every => 1_000_000); 47 | 48 | ## Try each 100ms up to 2 seconds (every is in microseconds) 49 | my $redis = Redis->new(reconnect => 2, every => 100_000); 50 | 51 | ## Enable connection timeout (in seconds) 52 | my $redis = Redis->new(cnx_timeout => 60); 53 | 54 | ## Enable read timeout (in seconds) 55 | my $redis = Redis->new(read_timeout => 0.5); 56 | 57 | ## Enable write timeout (in seconds) 58 | my $redis = Redis->new(write_timeout => 1.2); 59 | 60 | ## Connect via a list of Sentinels to a given service 61 | my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster'); 62 | 63 | ## Same, but with connection, read and write timeout on the sentinel hosts 64 | my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster', 65 | sentinels_cnx_timeout => 0.1, 66 | sentinels_read_timeout => 1, 67 | sentinels_write_timeout => 1, 68 | ); 69 | 70 | ## Use all the regular Redis commands, they all accept a list of 71 | ## arguments 72 | ## See https://redis.io/commands for full list 73 | $redis->get('key'); 74 | $redis->set('key' => 'value'); 75 | $redis->sort('list', 'DESC'); 76 | $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}); 77 | 78 | ## Add a coderef argument to run a command in the background 79 | $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}, sub { 80 | my ($reply, $error) = @_; 81 | die "Oops, got an error: $error\n" if defined $error; 82 | print "$_\n" for @$reply; 83 | }); 84 | long_computation(); 85 | $redis->wait_all_responses; 86 | ## or 87 | $redis->wait_one_response(); 88 | 89 | ## Or run a large batch of commands in a pipeline 90 | my %hash = _get_large_batch_of_commands(); 91 | $redis->hset('h', $_, $hash{$_}, sub {}) for keys %hash; 92 | $redis->wait_all_responses; 93 | 94 | ## Publish/Subscribe 95 | $redis->subscribe( 96 | 'topic_1', 97 | 'topic_2', 98 | sub { 99 | my ($message, $topic, $subscribed_topic) = @_ 100 | 101 | ## $subscribed_topic can be different from topic if 102 | ## you use psubscribe() with wildcards 103 | } 104 | ); 105 | $redis->psubscribe('nasdaq.*', sub {...}); 106 | 107 | ## Blocks and waits for messages, calls subscribe() callbacks 108 | ## ... forever 109 | my $timeout = 10; 110 | $redis->wait_for_messages($timeout) while 1; 111 | 112 | ## ... until some condition 113 | my $keep_going = 1; ## other code will set to false to quit 114 | $redis->wait_for_messages($timeout) while $keep_going; 115 | 116 | $redis->publish('topic_1', 'message'); 117 | 118 | =head1 DESCRIPTION 119 | 120 | Pure perl bindings for L 121 | 122 | This version supports protocol 2.x (multi-bulk) or later of Redis available at 123 | L. 124 | 125 | This documentation lists commands which are exercised in test suite, but 126 | additional commands will work correctly since protocol specifies enough 127 | information to support almost all commands with same piece of code with a 128 | little help of C. 129 | 130 | =head1 PIPELINING 131 | 132 | Usually, running a command will wait for a response. However, if you're doing 133 | large numbers of requests, it can be more efficient to use what Redis calls 134 | I: send multiple commands to Redis without waiting for a response, 135 | then wait for the responses that come in. 136 | 137 | To use pipelining, add a coderef argument as the last argument to a command 138 | method call: 139 | 140 | $r->set('foo', 'bar', sub {}); 141 | 142 | Pending responses to pipelined commands are processed in a single batch, as 143 | soon as at least one of the following conditions holds: 144 | 145 | =over 146 | 147 | =item * 148 | 149 | A non-pipelined (synchronous) command is called on the same connection 150 | 151 | =item * 152 | 153 | A pub/sub subscription command (one of C, C, 154 | C, or C) is about to be called on the same 155 | connection. 156 | 157 | =item * 158 | 159 | One of L or L methods is called 160 | explicitly. 161 | 162 | =back 163 | 164 | The coderef you supply to a pipelined command method is invoked once the 165 | response is available. It takes two arguments, C<$reply> and C<$error>. If 166 | C<$error> is defined, it contains the text of an error reply sent by the Redis 167 | server. Otherwise, C<$reply> is the non-error reply. For almost all commands, 168 | that means it's C, or a defined but non-reference scalar, or an array 169 | ref of any of those; but see L, L, and L. 170 | 171 | Note the contrast with synchronous commands, which throw an exception on 172 | receipt of an error reply, or return a non-error reply directly. 173 | 174 | The fact that pipelined commands never throw an exception can be particularly 175 | useful for Redis transactions; see L. 176 | 177 | =head1 ENCODING 178 | 179 | There is no encoding feature anymore, it has been deprecated and finally 180 | removed. This module consider that any data sent to the Redis server is a binary data. 181 | And it doesn't do anything when getting data from the Redis server. 182 | 183 | So, if you are working with character strings, you should pre-encode or post-decode it if needed ! 184 | 185 | =head1 CONSTRUCTOR 186 | 187 | =head2 new 188 | 189 | my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379 190 | 191 | my $r = Redis->new( server => '192.168.0.1:6379', debug => 0 ); 192 | my $r = Redis->new( server => '192.168.0.1:6379', encoding => undef ); 193 | my $r = Redis->new( server => '192.168.0.1:6379', ssl => 1, SSL_verify_mode => SSL_VERIFY_PEER ); 194 | my $r = Redis->new( sock => '/path/to/sock' ); 195 | my $r = Redis->new( reconnect => 60, every => 5000 ); 196 | my $r = Redis->new( password => 'boo' ); 197 | my $r = Redis->new( on_connect => sub { my ($redis) = @_; ... } ); 198 | my $r = Redis->new( name => 'my_connection_name' ); 199 | my $r = Redis->new( name => sub { "cache-for-$$" }); 200 | 201 | my $redis = Redis->new(sentinels => [ '127.0.0.1:12345', '127.0.0.1:23456' ], 202 | service => 'mymaster'); 203 | 204 | ## Connect via a list of Sentinels to a given service 205 | my $redis = Redis->new(sentinels => [ '127.0.0.1:12345' ], service => 'mymaster'); 206 | 207 | ## Same, but with connection, read and write timeout on the sentinel hosts 208 | my $redis = Redis->new( sentinels => [ '127.0.0.1:12345' ], service => 'mymaster', 209 | sentinels_cnx_timeout => 0.1, 210 | sentinels_read_timeout => 1, 211 | sentinels_write_timeout => 1, 212 | ); 213 | 214 | =head3 C<< server >> 215 | 216 | The C<< server >> parameter specifies the Redis server we should connect to, 217 | via TCP. Use the 'IP:PORT' format. If no C<< server >> option is present, we 218 | will attempt to use the C<< REDIS_SERVER >> environment variable. If neither of 219 | those options are present, it defaults to '127.0.0.1:6379'. 220 | 221 | Alternatively you can use the C<< sock >> parameter to specify the path of the 222 | UNIX domain socket where the Redis server is listening. 223 | 224 | Alternatively you can use the C<< sentinels >> parameter and the C<< service >> 225 | parameter to specify a list of sentinels to contact and try to get the address 226 | of the given service name. C<< sentinels >> must be an ArrayRef and C<< service 227 | >> an Str. 228 | 229 | The C<< REDIS_SERVER >> can be used for UNIX domain sockets too. The following 230 | formats are supported: 231 | 232 | =over 233 | 234 | =item * 235 | 236 | /path/to/sock 237 | 238 | =item * 239 | 240 | unix:/path/to/sock 241 | 242 | =item * 243 | 244 | 127.0.0.1:11011 245 | 246 | =item * 247 | 248 | tcp:127.0.0.1:11011 249 | 250 | =back 251 | 252 | =head3 C<< reconnect >>, C<< every >> 253 | 254 | The C<< reconnect >> option enables auto-reconnection mode. If we cannot 255 | connect to the Redis server, or if a network write fails, we enter retry mode. 256 | We will try a new connection every C<< every >> microseconds (1 ms by 257 | default), up-to C<< reconnect >> seconds. 258 | 259 | Be aware that read errors will always thrown an exception, and will not trigger 260 | a retry until the new command is sent. 261 | 262 | If we cannot re-establish a connection after C<< reconnect >> seconds, an 263 | exception will be thrown. 264 | 265 | =head3 C<< conservative_reconnect >> 266 | 267 | C<< conservative_reconnect >> option makes sure that reconnection is only attempted 268 | when no pending command is ongoing. For instance, if you're doing 269 | C<<$redis->incr('key')>>, and if the server properly understood and processed the 270 | command, but the network connection is dropped just before the server replies : 271 | the command has been processed but the client doesn't know it. In this 272 | situation, if reconnect is enabled, the Redis client will reconnect and send 273 | the C command *again*. If it succeeds, at the end the key as been 274 | incremented *two* times. To avoid this issue, you can set the C 275 | option to a true value. In this case, the client will reconnect only if no 276 | request is pending. Otherwise it will die with the message: C. 278 | 279 | =head3 C<< cnx_timeout >> 280 | 281 | The C<< cnx_timeout >> option enables connection timeout. The Redis client will 282 | wait at most that number of seconds (can be fractional) before giving up 283 | connecting to a server. 284 | 285 | =head3 C<< sentinels_cnx_timeout >> 286 | 287 | The C<< sentinels_cnx_timeout >> option enables sentinel connection timeout. 288 | When using the sentinels feature, Redis client will wait at most that number of 289 | seconds (can be fractional) before giving up connecting to a sentinel. 290 | B: 0.1 291 | 292 | =head3 C<< read_timeout >> 293 | 294 | The C<< read_timeout >> option enables read timeout. The Redis client will wait 295 | at most that number of seconds (can be fractional) before giving up when 296 | reading from the server. 297 | 298 | =head3 C<< sentinels_read_timeout >> 299 | 300 | The C<< sentinels_read_timeout >> option enables sentinel read timeout. When 301 | using the sentinels feature, the Redis client will wait at most that number of 302 | seconds (can be fractional) before giving up when reading from a sentinel 303 | server. B: 1 304 | 305 | =head3 C<< write_timeout >> 306 | 307 | The C<< write_timeout >> option enables write timeout. The Redis client will wait 308 | at most that number of seconds (can be fractional) before giving up when 309 | reading from the server. 310 | 311 | =head3 C<< sentinels_write_timeout >> 312 | 313 | The C<< sentinels_write_timeout >> option enables sentinel write timeout. When 314 | using the sentinels feature, the Redis client will wait at most that number of 315 | seconds (can be fractional) before giving up when reading from a sentinel 316 | server. B: 1 317 | 318 | =head3 C<< password >> 319 | 320 | If your Redis server requires authentication, you can use the C<< password >> 321 | attribute. After each established connection (at the start or when 322 | reconnecting), the Redis C<< AUTH >> command will be send to the server. If the 323 | password is wrong, an exception will be thrown and reconnect will be disabled. 324 | 325 | =head3 C<< on_connect >> 326 | 327 | You can also provide a code reference that will be immediately after each 328 | successful connection. The C<< on_connect >> attribute is used to provide the 329 | code reference, and it will be called with the first parameter being the Redis 330 | object. 331 | 332 | =head3 C<< no_auto_connect_on_new >> 333 | 334 | You can also provide C<< no_auto_connect_on_new >> in which case C<< 335 | new >> won't call C<< $obj->connect >> for you implicitly, you'll have 336 | to do that yourself. This is useful for figuring out how long 337 | connection setup takes so you can configure the C<< cnx_timeout >> 338 | appropriately. 339 | 340 | =head3 C<< no_sentinels_list_update >> 341 | 342 | You can also provide C<< no_sentinels_list_update >>. By default (that is, 343 | without this option), when successfully contacting a sentinel server, the Redis 344 | client will ask it for the list of sentinels known for the given service, and 345 | merge it with its list of sentinels (in the C<< sentinels >> attribute). You 346 | can disable this behavior by setting C<< no_sentinels_list_update >> to a true 347 | value. 348 | 349 | =head3 C<< name >> 350 | 351 | You can also set a name for each connection. This can be very useful for 352 | debugging purposes, using the C<< CLIENT LIST >> command. To set a connection 353 | name, use the C<< name >> parameter. You can use both a scalar value or a 354 | CodeRef. If the latter, it will be called after each connection, with the Redis 355 | object, and it should return the connection name to use. If it returns a 356 | undefined value, Redis will not set the connection name. 357 | 358 | Please note that there are restrictions on the name you can set, the most 359 | important of which is, no spaces. See the L for all the juicy 361 | details. This feature is safe to use with all versions of Redis servers. If C<< 362 | CLIENT SETNAME >> support is not available (Redis servers 2.6.9 and above 363 | only), the name parameter is ignored. 364 | 365 | =head3 C<< ssl >> 366 | 367 | You can connect to Redis over SSL/TLS by setting this flag if the target Redis 368 | server or cluster has been setup to support SSL/TLS. This requires IO::Socket::SSL 369 | to be installed on the client. It's off by default. 370 | 371 | =head3 C<< SSL_verify_mode >> 372 | 373 | This parameter will be applied when C<< ssl >> flag is set. It sets the verification 374 | mode for the peer certificate. It's compatible with the parameter with the same name 375 | in IO::Socket::SSL. 376 | 377 | =head3 C<< debug >> 378 | 379 | The C<< debug >> parameter enables debug information to STDERR, including all 380 | interactions with the server. You can also enable debug with the C 381 | environment variable. 382 | 383 | =head1 CONNECTION HANDLING 384 | 385 | =head2 connect 386 | 387 | $r->connect; 388 | 389 | Connects to the Redis server. This is done by default when the obect is 390 | constructed using C, unless C has been set. See 391 | this option in the C constructor. 392 | 393 | =head2 quit 394 | 395 | $r->quit; 396 | 397 | Closes the connection to the server. The C method does not support 398 | pipelined operation. 399 | 400 | =head2 ping 401 | 402 | $r->ping || die "no server?"; 403 | 404 | The C method does not support pipelined operation. 405 | 406 | =head1 PIPELINE MANAGEMENT 407 | 408 | =head2 wait_all_responses 409 | 410 | Waits until all pending pipelined responses have been received, and invokes the 411 | pipeline callback for each one. See L. 412 | 413 | =head2 wait_one_response 414 | 415 | Waits until the first pending pipelined response has been received, and invokes 416 | its callback. See L. 417 | 418 | =head1 PUBLISH/SUBSCRIBE COMMANDS 419 | 420 | When one of L or L is used, the Redis object will 421 | enter I mode. When in I mode only commands in this section, 422 | plus L, will be accepted. 423 | 424 | If you plan on using PubSub and other Redis functions, you should use two Redis 425 | objects, one dedicated to PubSub and the other for regular commands. 426 | 427 | All Pub/Sub commands receive a callback as the last parameter. This callback 428 | receives three arguments: 429 | 430 | =over 431 | 432 | =item * 433 | 434 | The published message. 435 | 436 | =item * 437 | 438 | The topic over which the message was sent. 439 | 440 | =item * 441 | 442 | The subscribed topic that matched the topic for the message. With L 443 | these last two are the same, always. But with L, this parameter 444 | tells you the pattern that matched. 445 | 446 | =back 447 | 448 | See the L for more information 449 | about the messages you will receive on your callbacks after each L, 450 | L, L and L. 451 | 452 | =head2 publish 453 | 454 | $r->publish($topic, $message); 455 | 456 | Publishes the C<< $message >> to the C<< $topic >>. 457 | 458 | =head2 subscribe 459 | 460 | $r->subscribe( 461 | @topics_to_subscribe_to, 462 | my $savecallback = sub { 463 | my ($message, $topic, $subscribed_topic) = @_; 464 | ... 465 | }, 466 | ); 467 | 468 | Subscribe one or more topics. Messages published into one of them will be 469 | received by Redis, and the specified callback will be executed. 470 | 471 | =head2 unsubscribe 472 | 473 | $r->unsubscribe(@topic_list, $savecallback); 474 | 475 | Stops receiving messages via C<$savecallback> for all the topics in 476 | C<@topic_list>. B it is important that you give the same calleback 477 | that you used for subscribtion. The value of the CodeRef must be the same, as 478 | this is how internally the code identifies it. 479 | 480 | =head2 psubscribe 481 | 482 | my @topic_matches = ('prefix1.*', 'prefix2.*'); 483 | $r->psubscribe(@topic_matches, my $savecallback = sub { my ($m, $t, $s) = @_; ... }); 484 | 485 | Subscribes a pattern of topics. All messages to topics that match the pattern 486 | will be delivered to the callback. 487 | 488 | =head2 punsubscribe 489 | 490 | my @topic_matches = ('prefix1.*', 'prefix2.*'); 491 | $r->punsubscribe(@topic_matches, $savecallback); 492 | 493 | Stops receiving messages via C<$savecallback> for all the topics pattern 494 | matches in C<@topic_list>. B it is important that you give the same 495 | calleback that you used for subscribtion. The value of the CodeRef must be the 496 | same, as this is how internally the code identifies it. 497 | 498 | =head2 is_subscriber 499 | 500 | if ($r->is_subscriber) { say "We are in Pub/Sub mode!" } 501 | 502 | Returns true if we are in I mode. 503 | 504 | =head2 wait_for_messages 505 | 506 | my $keep_going = 1; ## Set to false somewhere to leave the loop 507 | my $timeout = 5; 508 | $r->wait_for_messages($timeout) while $keep_going; 509 | 510 | Blocks, waits for incoming messages and delivers them to the appropriate 511 | callbacks. 512 | 513 | Requires a single parameter, the number of seconds to wait for messages. Use 0 514 | to wait for ever. If a positive non-zero value is used, it will return after 515 | that amount of seconds without a single notification. 516 | 517 | Please note that the timeout is not a commitment to return control to the 518 | caller at most each C seconds, but more a idle timeout, were control 519 | will return to the caller if Redis is idle (as in no messages were received 520 | during the timeout period) for more than C seconds. 521 | 522 | The L call returns the number of messages processed during 523 | the run. 524 | 525 | =head1 IMPORTANT NOTES ON METHODS 526 | 527 | =head2 methods that return multiple values 528 | 529 | When a method returns more than one value, it checks the context and returns 530 | either a list of values or an ArrayRef. 531 | 532 | =head2 transaction-handling methods 533 | 534 | B the behaviour of the TRANSACTIONS commands when combined with 535 | pipelining is still under discussion, and you should B use them at the 536 | same time just now. 537 | 538 | You can L. 540 | 541 | =head2 exec 542 | 543 | my @individual_replies = $r->exec; 544 | 545 | C has special behaviour when run in a pipeline: the C<$reply> argument to 546 | the pipeline callback is an array ref whose elements are themselves C<[$reply, 547 | $error]> pairs. This means that you can accurately detect errors yielded by 548 | any command in the transaction, and without any exceptions being thrown. 549 | 550 | =head2 keys 551 | 552 | my @keys = $r->keys( '*glob_pattern*' ); 553 | my $keys = $r->keys( '*glob_pattern*' ); # count of matching keys 554 | 555 | Note that synchronous C calls in a scalar context return the number of 556 | matching keys (not an array ref of matching keys as you might expect). This 557 | does not apply in pipelined mode: assuming the server returns a list of keys, 558 | as expected, it is always passed to the pipeline callback as an array ref. 559 | 560 | =head2 hashes 561 | 562 | Hashes in Redis cannot be nested as in perl, if you want to store a nested 563 | hash, you need to serialize the hash first. If you want to have a named 564 | hash, you can use Redis-hashes. You will find an example in the tests 565 | of this module t/01-basic.t 566 | 567 | =head2 eval 568 | 569 | Note that this commands sends the Lua script every time you call it. See 570 | L and L for an alternative. 571 | 572 | =head2 info 573 | 574 | my $info_hash = $r->info; 575 | 576 | The C method is unique in that it decodes the server's response into a 577 | hashref, if possible. This decoding happens in both synchronous and pipelined 578 | modes. 579 | 580 | =head1 KEYS 581 | 582 | =head2 del 583 | 584 | $r->del(key [key ...]) 585 | 586 | Delete a key (see L) 587 | 588 | =head2 dump 589 | 590 | $r->dump(key) 591 | 592 | Return a serialized version of the value stored at the specified key. (see L) 593 | 594 | =head2 exists 595 | 596 | $r->exists(key) 597 | 598 | Determine if a key exists (see L) 599 | 600 | =head2 expire 601 | 602 | $r->expire(key, seconds) 603 | 604 | Set a key's time to live in seconds (see L) 605 | 606 | =head2 expireat 607 | 608 | $r->expireat(key, timestamp) 609 | 610 | Set the expiration for a key as a UNIX timestamp (see L) 611 | 612 | =head2 keys 613 | 614 | $r->keys(pattern) 615 | 616 | Find all keys matching the given pattern (see L) 617 | 618 | =head2 migrate 619 | 620 | $r->migrate(host, port, key, destination-db, timeout, [COPY], [REPLACE]) 621 | 622 | Atomically transfer a key from a Redis instance to another one. (see L) 623 | 624 | =head2 move 625 | 626 | $r->move(key, db) 627 | 628 | Move a key to another database (see L) 629 | 630 | =head2 object 631 | 632 | $r->object(subcommand, [arguments [arguments ...]]) 633 | 634 | Inspect the internals of Redis objects (see L) 635 | 636 | =head2 persist 637 | 638 | $r->persist(key) 639 | 640 | Remove the expiration from a key (see L) 641 | 642 | =head2 pexpire 643 | 644 | $r->pexpire(key, milliseconds) 645 | 646 | Set a key's time to live in milliseconds (see L) 647 | 648 | =head2 pexpireat 649 | 650 | $r->pexpireat(key, milliseconds-timestamp) 651 | 652 | Set the expiration for a key as a UNIX timestamp specified in milliseconds (see L) 653 | 654 | =head2 pttl 655 | 656 | $r->pttl(key) 657 | 658 | Get the time to live for a key in milliseconds (see L) 659 | 660 | =head2 randomkey 661 | 662 | $r->randomkey() 663 | 664 | Return a random key from the keyspace (see L) 665 | 666 | =head2 rename 667 | 668 | $r->rename(key, newkey) 669 | 670 | Rename a key (see L) 671 | 672 | =head2 renamenx 673 | 674 | $r->renamenx(key, newkey) 675 | 676 | Rename a key, only if the new key does not exist (see L) 677 | 678 | =head2 restore 679 | 680 | $r->restore(key, ttl, serialized-value) 681 | 682 | Create a key using the provided serialized value, previously obtained using DUMP. (see L) 683 | 684 | =head2 scan 685 | 686 | $r->scan(cursor, [MATCH pattern], [COUNT count]) 687 | 688 | Incrementally iterate the keys space (see L) 689 | 690 | =head2 sort 691 | 692 | $r->sort(key, [BY pattern], [LIMIT offset count], [GET pattern [GET pattern ...]], [ASC|DESC], [ALPHA], [STORE destination]) 693 | 694 | Sort the elements in a list, set or sorted set (see L) 695 | 696 | =head2 ttl 697 | 698 | $r->ttl(key) 699 | 700 | Get the time to live for a key (see L) 701 | 702 | =head2 type 703 | 704 | $r->type(key) 705 | 706 | Determine the type stored at key (see L) 707 | 708 | =head1 STRINGS 709 | 710 | =head2 append 711 | 712 | $r->append(key, value) 713 | 714 | Append a value to a key (see L) 715 | 716 | =head2 bitcount 717 | 718 | $r->bitcount(key, [start end]) 719 | 720 | Count set bits in a string (see L) 721 | 722 | =head2 bitop 723 | 724 | $r->bitop(operation, destkey, key [key ...]) 725 | 726 | Perform bitwise operations between strings (see L) 727 | 728 | =head2 bitpos 729 | 730 | $r->bitpos(key, bit, [start], [end]) 731 | 732 | Find first bit set or clear in a string (see L) 733 | 734 | =head2 blpop 735 | 736 | $r->blpop(key [key ...], timeout) 737 | 738 | Remove and get the first element in a list, or block until one is available (see L) 739 | 740 | =head2 brpop 741 | 742 | $r->brpop(key [key ...], timeout) 743 | 744 | Remove and get the last element in a list, or block until one is available (see L) 745 | 746 | =head2 brpoplpush 747 | 748 | $r->brpoplpush(source, destination, timeout) 749 | 750 | Pop a value from a list, push it to another list and return it; or block until one is available (see L) 751 | 752 | =head2 decr 753 | 754 | $r->decr(key) 755 | 756 | Decrement the integer value of a key by one (see L) 757 | 758 | =head2 decrby 759 | 760 | $r->decrby(key, decrement) 761 | 762 | Decrement the integer value of a key by the given number (see L) 763 | 764 | =head2 get 765 | 766 | $r->get(key) 767 | 768 | Get the value of a key (see L) 769 | 770 | =head2 getbit 771 | 772 | $r->getbit(key, offset) 773 | 774 | Returns the bit value at offset in the string value stored at key (see L) 775 | 776 | =head2 getrange 777 | 778 | $r->getrange(key, start, end) 779 | 780 | Get a substring of the string stored at a key (see L) 781 | 782 | =head2 getset 783 | 784 | $r->getset(key, value) 785 | 786 | Set the string value of a key and return its old value (see L) 787 | 788 | =head2 incr 789 | 790 | $r->incr(key) 791 | 792 | Increment the integer value of a key by one (see L) 793 | 794 | =head2 incrby 795 | 796 | $r->incrby(key, increment) 797 | 798 | Increment the integer value of a key by the given amount (see L) 799 | 800 | =head2 incrbyfloat 801 | 802 | $r->incrbyfloat(key, increment) 803 | 804 | Increment the float value of a key by the given amount (see L) 805 | 806 | =head2 mget 807 | 808 | $r->mget(key [key ...]) 809 | 810 | Get the values of all the given keys (see L) 811 | 812 | =head2 mset 813 | 814 | $r->mset(key value [key value ...]) 815 | 816 | Set multiple keys to multiple values (see L) 817 | 818 | =head2 msetnx 819 | 820 | $r->msetnx(key value [key value ...]) 821 | 822 | Set multiple keys to multiple values, only if none of the keys exist (see L) 823 | 824 | =head2 psetex 825 | 826 | $r->psetex(key, milliseconds, value) 827 | 828 | Set the value and expiration in milliseconds of a key (see L) 829 | 830 | =head2 set 831 | 832 | $r->set(key, value, ['EX', seconds], ['PX', milliseconds], ['NX'|'XX']) 833 | 834 | Set the string value of a key (see L). Example: 835 | 836 | $r->set('key', 'test', 'EX', 60, 'NX') 837 | 838 | =head2 setbit 839 | 840 | $r->setbit(key, offset, value) 841 | 842 | Sets or clears the bit at offset in the string value stored at key (see L) 843 | 844 | =head2 setex 845 | 846 | $r->setex(key, seconds, value) 847 | 848 | Set the value and expiration of a key (see L) 849 | 850 | =head2 setnx 851 | 852 | $r->setnx(key, value) 853 | 854 | Set the value of a key, only if the key does not exist (see L) 855 | 856 | =head2 setrange 857 | 858 | $r->setrange(key, offset, value) 859 | 860 | Overwrite part of a string at key starting at the specified offset (see L) 861 | 862 | =head2 strlen 863 | 864 | $r->strlen(key) 865 | 866 | Get the length of the value stored in a key (see L) 867 | 868 | =head1 HASHES 869 | 870 | =head2 hdel 871 | 872 | $r->hdel(key, field [field ...]) 873 | 874 | Delete one or more hash fields (see L) 875 | 876 | =head2 hexists 877 | 878 | $r->hexists(key, field) 879 | 880 | Determine if a hash field exists (see L) 881 | 882 | =head2 hget 883 | 884 | $r->hget(key, field) 885 | 886 | Get the value of a hash field (see L) 887 | 888 | =head2 hgetall 889 | 890 | $r->hgetall(key) 891 | 892 | Get all the fields and values in a hash (see L) 893 | 894 | =head2 hincrby 895 | 896 | $r->hincrby(key, field, increment) 897 | 898 | Increment the integer value of a hash field by the given number (see L) 899 | 900 | =head2 hincrbyfloat 901 | 902 | $r->hincrbyfloat(key, field, increment) 903 | 904 | Increment the float value of a hash field by the given amount (see L) 905 | 906 | =head2 hkeys 907 | 908 | $r->hkeys(key) 909 | 910 | Get all the fields in a hash (see L) 911 | 912 | =head2 hlen 913 | 914 | $r->hlen(key) 915 | 916 | Get the number of fields in a hash (see L) 917 | 918 | =head2 hmget 919 | 920 | $r->hmget(key, field [field ...]) 921 | 922 | Get the values of all the given hash fields (see L) 923 | 924 | =head2 hmset 925 | 926 | $r->hmset(key, field value [field value ...]) 927 | 928 | Set multiple hash fields to multiple values (see L) 929 | 930 | =head2 hscan 931 | 932 | $r->hscan(key, cursor, [MATCH pattern], [COUNT count]) 933 | 934 | Incrementally iterate hash fields and associated values (see L) 935 | 936 | =head2 hset 937 | 938 | $r->hset(key, field, value) 939 | 940 | Set the string value of a hash field (see L) 941 | 942 | =head2 hsetnx 943 | 944 | $r->hsetnx(key, field, value) 945 | 946 | Set the value of a hash field, only if the field does not exist (see L) 947 | 948 | =head2 hvals 949 | 950 | $r->hvals(key) 951 | 952 | Get all the values in a hash (see L) 953 | 954 | =head1 SETS 955 | 956 | =head2 sadd 957 | 958 | $r->sadd(key, member [member ...]) 959 | 960 | Add one or more members to a set (see L) 961 | 962 | =head2 scard 963 | 964 | $r->scard(key) 965 | 966 | Get the number of members in a set (see L) 967 | 968 | =head2 sdiff 969 | 970 | $r->sdiff(key [key ...]) 971 | 972 | Subtract multiple sets (see L) 973 | 974 | =head2 sdiffstore 975 | 976 | $r->sdiffstore(destination, key [key ...]) 977 | 978 | Subtract multiple sets and store the resulting set in a key (see L) 979 | 980 | =head2 sinter 981 | 982 | $r->sinter(key [key ...]) 983 | 984 | Intersect multiple sets (see L) 985 | 986 | =head2 sinterstore 987 | 988 | $r->sinterstore(destination, key [key ...]) 989 | 990 | Intersect multiple sets and store the resulting set in a key (see L) 991 | 992 | =head2 sismember 993 | 994 | $r->sismember(key, member) 995 | 996 | Determine if a given value is a member of a set (see L) 997 | 998 | =head2 smembers 999 | 1000 | $r->smembers(key) 1001 | 1002 | Get all the members in a set (see L) 1003 | 1004 | =head2 smove 1005 | 1006 | $r->smove(source, destination, member) 1007 | 1008 | Move a member from one set to another (see L) 1009 | 1010 | =head2 spop 1011 | 1012 | $r->spop(key) 1013 | 1014 | Remove and return a random member from a set (see L) 1015 | 1016 | =head2 srandmember 1017 | 1018 | $r->srandmember(key, [count]) 1019 | 1020 | Get one or multiple random members from a set (see L) 1021 | 1022 | =head2 srem 1023 | 1024 | $r->srem(key, member [member ...]) 1025 | 1026 | Remove one or more members from a set (see L) 1027 | 1028 | =head2 sscan 1029 | 1030 | $r->sscan(key, cursor, [MATCH pattern], [COUNT count]) 1031 | 1032 | Incrementally iterate Set elements (see L) 1033 | 1034 | =head2 sunion 1035 | 1036 | $r->sunion(key [key ...]) 1037 | 1038 | Add multiple sets (see L) 1039 | 1040 | =head2 sunionstore 1041 | 1042 | $r->sunionstore(destination, key [key ...]) 1043 | 1044 | Add multiple sets and store the resulting set in a key (see L) 1045 | 1046 | =head1 SORTED SETS 1047 | 1048 | =head2 zadd 1049 | 1050 | $r->zadd(key, score member [score member ...]) 1051 | 1052 | Add one or more members to a sorted set, or update its score if it already exists (see L) 1053 | 1054 | =head2 zcard 1055 | 1056 | $r->zcard(key) 1057 | 1058 | Get the number of members in a sorted set (see L) 1059 | 1060 | =head2 zcount 1061 | 1062 | $r->zcount(key, min, max) 1063 | 1064 | Count the members in a sorted set with scores within the given values (see L) 1065 | 1066 | =head2 zincrby 1067 | 1068 | $r->zincrby(key, increment, member) 1069 | 1070 | Increment the score of a member in a sorted set (see L) 1071 | 1072 | =head2 zinterstore 1073 | 1074 | $r->zinterstore(destination, numkeys, key [key ...], [WEIGHTS weight [weight ...]], [AGGREGATE SUM|MIN|MAX]) 1075 | 1076 | Intersect multiple sorted sets and store the resulting sorted set in a new key (see L) 1077 | 1078 | =head2 zlexcount 1079 | 1080 | $r->zlexcount(key, min, max) 1081 | 1082 | Count the number of members in a sorted set between a given lexicographical range (see L) 1083 | 1084 | =head2 zrange 1085 | 1086 | $r->zrange(key, start, stop, [WITHSCORES]) 1087 | 1088 | Return a range of members in a sorted set, by index (see L) 1089 | 1090 | =head2 zrangebylex 1091 | 1092 | $r->zrangebylex(key, min, max, [LIMIT offset count]) 1093 | 1094 | Return a range of members in a sorted set, by lexicographical range (see L) 1095 | 1096 | =head2 zrangebyscore 1097 | 1098 | $r->zrangebyscore(key, min, max, [WITHSCORES], [LIMIT offset count]) 1099 | 1100 | Return a range of members in a sorted set, by score (see L) 1101 | 1102 | =head2 zrank 1103 | 1104 | $r->zrank(key, member) 1105 | 1106 | Determine the index of a member in a sorted set (see L) 1107 | 1108 | =head2 zrem 1109 | 1110 | $r->zrem(key, member [member ...]) 1111 | 1112 | Remove one or more members from a sorted set (see L) 1113 | 1114 | =head2 zremrangebylex 1115 | 1116 | $r->zremrangebylex(key, min, max) 1117 | 1118 | Remove all members in a sorted set between the given lexicographical range (see L) 1119 | 1120 | =head2 zremrangebyrank 1121 | 1122 | $r->zremrangebyrank(key, start, stop) 1123 | 1124 | Remove all members in a sorted set within the given indexes (see L) 1125 | 1126 | =head2 zremrangebyscore 1127 | 1128 | $r->zremrangebyscore(key, min, max) 1129 | 1130 | Remove all members in a sorted set within the given scores (see L) 1131 | 1132 | =head2 zrevrange 1133 | 1134 | $r->zrevrange(key, start, stop, [WITHSCORES]) 1135 | 1136 | Return a range of members in a sorted set, by index, with scores ordered from high to low (see L) 1137 | 1138 | =head2 zrevrangebylex 1139 | 1140 | $r->zrevrangebylex(key, max, min, [LIMIT offset count]) 1141 | 1142 | Return a range of members in a sorted set, by lexicographical range, ordered from higher to lower strings. (see L) 1143 | 1144 | =head2 zrevrangebyscore 1145 | 1146 | $r->zrevrangebyscore(key, max, min, [WITHSCORES], [LIMIT offset count]) 1147 | 1148 | Return a range of members in a sorted set, by score, with scores ordered from high to low (see L) 1149 | 1150 | =head2 zrevrank 1151 | 1152 | $r->zrevrank(key, member) 1153 | 1154 | Determine the index of a member in a sorted set, with scores ordered from high to low (see L) 1155 | 1156 | =head2 zscan 1157 | 1158 | $r->zscan(key, cursor, [MATCH pattern], [COUNT count]) 1159 | 1160 | Incrementally iterate sorted sets elements and associated scores (see L) 1161 | 1162 | =head2 zscore 1163 | 1164 | $r->zscore(key, member) 1165 | 1166 | Get the score associated with the given member in a sorted set (see L) 1167 | 1168 | =head2 zunionstore 1169 | 1170 | $r->zunionstore(destination, numkeys, key [key ...], [WEIGHTS weight [weight ...]], [AGGREGATE SUM|MIN|MAX]) 1171 | 1172 | Add multiple sorted sets and store the resulting sorted set in a new key (see L) 1173 | 1174 | =head1 HYPERLOGLOG 1175 | 1176 | =head2 pfadd 1177 | 1178 | $r->pfadd(key, element [element ...]) 1179 | 1180 | Adds the specified elements to the specified HyperLogLog. (see L) 1181 | 1182 | =head2 pfcount 1183 | 1184 | $r->pfcount(key [key ...]) 1185 | 1186 | Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s). (see L) 1187 | 1188 | =head2 pfmerge 1189 | 1190 | $r->pfmerge(destkey, sourcekey [sourcekey ...]) 1191 | 1192 | Merge N different HyperLogLogs into a single one. (see L) 1193 | 1194 | =head1 PUB/SUB 1195 | 1196 | =head2 pubsub 1197 | 1198 | $r->pubsub(subcommand, [argument [argument ...]]) 1199 | 1200 | Inspect the state of the Pub/Sub subsystem (see L) 1201 | 1202 | =head1 TRANSACTIONS 1203 | 1204 | =head2 discard 1205 | 1206 | $r->discard() 1207 | 1208 | Discard all commands issued after MULTI (see L) 1209 | 1210 | =head2 exec 1211 | 1212 | $r->exec() 1213 | 1214 | Execute all commands issued after MULTI (see L) 1215 | 1216 | =head2 multi 1217 | 1218 | $r->multi() 1219 | 1220 | Mark the start of a transaction block (see L) 1221 | 1222 | =head2 unwatch 1223 | 1224 | $r->unwatch() 1225 | 1226 | Forget about all watched keys (see L) 1227 | 1228 | =head2 watch 1229 | 1230 | $r->watch(key [key ...]) 1231 | 1232 | Watch the given keys to determine execution of the MULTI/EXEC block (see L) 1233 | 1234 | =head1 SCRIPTING 1235 | 1236 | =head2 eval 1237 | 1238 | $r->eval(script, numkeys, key [key ...], arg [arg ...]) 1239 | 1240 | Execute a Lua script server side (see L) 1241 | 1242 | =head2 evalsha 1243 | 1244 | $r->evalsha(sha1, numkeys, key [key ...], arg [arg ...]) 1245 | 1246 | Execute a Lua script server side (see L) 1247 | 1248 | =head2 script_exists 1249 | 1250 | $r->script_exists(script [script ...]) 1251 | 1252 | Check existence of scripts in the script cache. (see L) 1253 | 1254 | =head2 script_flush 1255 | 1256 | $r->script_flush() 1257 | 1258 | Remove all the scripts from the script cache. (see L) 1259 | 1260 | =head2 script_kill 1261 | 1262 | $r->script_kill() 1263 | 1264 | Kill the script currently in execution. (see L) 1265 | 1266 | =head2 script_load 1267 | 1268 | $r->script_load(script) 1269 | 1270 | Load the specified Lua script into the script cache. (see L) 1271 | 1272 | =head1 CONNECTION 1273 | 1274 | =head2 auth 1275 | 1276 | $r->auth(password) 1277 | 1278 | Authenticate to the server (see L) 1279 | 1280 | $r->auth(username, password) 1281 | 1282 | Authenticate to the server using Redis 6.0+ ACL System (see L) 1283 | 1284 | =head2 echo 1285 | 1286 | $r->echo(message) 1287 | 1288 | Echo the given string (see L) 1289 | 1290 | =head2 ping 1291 | 1292 | $r->ping() 1293 | 1294 | Ping the server (see L) 1295 | 1296 | =head2 quit 1297 | 1298 | $r->quit() 1299 | 1300 | Close the connection (see L) 1301 | 1302 | =head2 select 1303 | 1304 | $r->select(index) 1305 | 1306 | Change the selected database for the current connection (see L) 1307 | 1308 | =head1 SERVER 1309 | 1310 | =head2 bgrewriteaof 1311 | 1312 | $r->bgrewriteaof() 1313 | 1314 | Asynchronously rewrite the append-only file (see L) 1315 | 1316 | =head2 bgsave 1317 | 1318 | $r->bgsave() 1319 | 1320 | Asynchronously save the dataset to disk (see L) 1321 | 1322 | =head2 client_getname 1323 | 1324 | $r->client_getname() 1325 | 1326 | Get the current connection name (see L) 1327 | 1328 | =head2 client_kill 1329 | 1330 | $r->client_kill([ip:port], [ID client-id], [TYPE normal|slave|pubsub], [ADDR ip:port], [SKIPME yes/no]) 1331 | 1332 | Kill the connection of a client (see L) 1333 | 1334 | =head2 client_list 1335 | 1336 | $r->client_list() 1337 | 1338 | Get the list of client connections (see L) 1339 | 1340 | =head2 client_pause 1341 | 1342 | $r->client_pause(timeout) 1343 | 1344 | Stop processing commands from clients for some time (see L) 1345 | 1346 | =head2 client_setname 1347 | 1348 | $r->client_setname(connection-name) 1349 | 1350 | Set the current connection name (see L) 1351 | 1352 | =head2 cluster_slots 1353 | 1354 | $r->cluster_slots() 1355 | 1356 | Get array of Cluster slot to node mappings (see L) 1357 | 1358 | =head2 command 1359 | 1360 | $r->command() 1361 | 1362 | Get array of Redis command details (see L) 1363 | 1364 | =head2 command_count 1365 | 1366 | $r->command_count() 1367 | 1368 | Get total number of Redis commands (see L) 1369 | 1370 | =head2 command_getkeys 1371 | 1372 | $r->command_getkeys() 1373 | 1374 | Extract keys given a full Redis command (see L) 1375 | 1376 | =head2 command_info 1377 | 1378 | $r->command_info(command-name [command-name ...]) 1379 | 1380 | Get array of specific Redis command details (see L) 1381 | 1382 | =head2 config_get 1383 | 1384 | $r->config_get(parameter) 1385 | 1386 | Get the value of a configuration parameter (see L) 1387 | 1388 | =head2 config_resetstat 1389 | 1390 | $r->config_resetstat() 1391 | 1392 | Reset the stats returned by INFO (see L) 1393 | 1394 | =head2 config_rewrite 1395 | 1396 | $r->config_rewrite() 1397 | 1398 | Rewrite the configuration file with the in memory configuration (see L) 1399 | 1400 | =head2 config_set 1401 | 1402 | $r->config_set(parameter, value) 1403 | 1404 | Set a configuration parameter to the given value (see L) 1405 | 1406 | =head2 dbsize 1407 | 1408 | $r->dbsize() 1409 | 1410 | Return the number of keys in the selected database (see L) 1411 | 1412 | =head2 debug_object 1413 | 1414 | $r->debug_object(key) 1415 | 1416 | Get debugging information about a key (see L) 1417 | 1418 | =head2 debug_segfault 1419 | 1420 | $r->debug_segfault() 1421 | 1422 | Make the server crash (see L) 1423 | 1424 | =head2 flushall 1425 | 1426 | $r->flushall() 1427 | 1428 | Remove all keys from all databases (see L) 1429 | 1430 | =head2 flushdb 1431 | 1432 | $r->flushdb() 1433 | 1434 | Remove all keys from the current database (see L) 1435 | 1436 | =head2 info 1437 | 1438 | $r->info([section]) 1439 | 1440 | Get information and statistics about the server (see L) 1441 | 1442 | =head2 lastsave 1443 | 1444 | $r->lastsave() 1445 | 1446 | Get the UNIX time stamp of the last successful save to disk (see L) 1447 | 1448 | =head2 lindex 1449 | 1450 | $r->lindex(key, index) 1451 | 1452 | Get an element from a list by its index (see L) 1453 | 1454 | =head2 linsert 1455 | 1456 | $r->linsert(key, BEFORE|AFTER, pivot, value) 1457 | 1458 | Insert an element before or after another element in a list (see L) 1459 | 1460 | =head2 llen 1461 | 1462 | $r->llen(key) 1463 | 1464 | Get the length of a list (see L) 1465 | 1466 | =head2 lpop 1467 | 1468 | $r->lpop(key) 1469 | 1470 | Remove and get the first element in a list (see L) 1471 | 1472 | =head2 lpush 1473 | 1474 | $r->lpush(key, value [value ...]) 1475 | 1476 | Prepend one or multiple values to a list (see L) 1477 | 1478 | =head2 lpushx 1479 | 1480 | $r->lpushx(key, value) 1481 | 1482 | Prepend a value to a list, only if the list exists (see L) 1483 | 1484 | =head2 lrange 1485 | 1486 | $r->lrange(key, start, stop) 1487 | 1488 | Get a range of elements from a list (see L) 1489 | 1490 | =head2 lrem 1491 | 1492 | $r->lrem(key, count, value) 1493 | 1494 | Remove elements from a list (see L) 1495 | 1496 | =head2 lset 1497 | 1498 | $r->lset(key, index, value) 1499 | 1500 | Set the value of an element in a list by its index (see L) 1501 | 1502 | =head2 ltrim 1503 | 1504 | $r->ltrim(key, start, stop) 1505 | 1506 | Trim a list to the specified range (see L) 1507 | 1508 | =head2 monitor 1509 | 1510 | $r->monitor() 1511 | 1512 | Listen for all requests received by the server in real time (see L) 1513 | 1514 | =head2 role 1515 | 1516 | $r->role() 1517 | 1518 | Return the role of the instance in the context of replication (see L) 1519 | 1520 | =head2 rpop 1521 | 1522 | $r->rpop(key) 1523 | 1524 | Remove and get the last element in a list (see L) 1525 | 1526 | =head2 rpoplpush 1527 | 1528 | $r->rpoplpush(source, destination) 1529 | 1530 | Remove the last element in a list, append it to another list and return it (see L) 1531 | 1532 | =head2 rpush 1533 | 1534 | $r->rpush(key, value [value ...]) 1535 | 1536 | Append one or multiple values to a list (see L) 1537 | 1538 | =head2 rpushx 1539 | 1540 | $r->rpushx(key, value) 1541 | 1542 | Append a value to a list, only if the list exists (see L) 1543 | 1544 | =head2 save 1545 | 1546 | $r->save() 1547 | 1548 | Synchronously save the dataset to disk (see L) 1549 | 1550 | =head2 shutdown 1551 | 1552 | $r->shutdown([NOSAVE], [SAVE]) 1553 | 1554 | Synchronously save the dataset to disk and then shut down the server (see L) 1555 | 1556 | =head2 slaveof 1557 | 1558 | $r->slaveof(host, port) 1559 | 1560 | Make the server a slave of another instance, or promote it as master (see L) 1561 | 1562 | =head2 slowlog 1563 | 1564 | $r->slowlog(subcommand, [argument]) 1565 | 1566 | Manages the Redis slow queries log (see L) 1567 | 1568 | =head2 sync 1569 | 1570 | $r->sync() 1571 | 1572 | Internal command used for replication (see L) 1573 | 1574 | =head2 time 1575 | 1576 | $r->time() 1577 | 1578 | Return the current server time (see L) 1579 | 1580 | =head1 ACKNOWLEDGEMENTS 1581 | 1582 | The following persons contributed to this project (random order): 1583 | 1584 | =over 1585 | 1586 | =item * 1587 | 1588 | Aaron Crane (pipelining and AUTOLOAD caching support) 1589 | 1590 | =item * 1591 | 1592 | Dirk Vleugels 1593 | 1594 | =item * 1595 | 1596 | Flavio Poletti 1597 | 1598 | =item * 1599 | 1600 | Jeremy Zawodny 1601 | 1602 | =item * 1603 | 1604 | sunnavy at bestpractical.com 1605 | 1606 | =item * 1607 | 1608 | Thiago Berlitz Rondon 1609 | 1610 | =item * 1611 | 1612 | Ulrich Habel 1613 | 1614 | =item * 1615 | 1616 | Ivan Kruglov 1617 | 1618 | =item * 1619 | 1620 | Steffen Mueller 1621 | 1622 | =back 1623 | 1624 | =head1 AUTHORS 1625 | 1626 | =over 4 1627 | 1628 | =item * 1629 | 1630 | Pedro Melo 1631 | 1632 | =item * 1633 | 1634 | Damien Krotkine 1635 | 1636 | =back 1637 | 1638 | =head1 COPYRIGHT AND LICENSE 1639 | 1640 | This software is Copyright (c) 2015 by Pedro Melo, Damien Krotkine. 1641 | 1642 | This is free software, licensed under: 1643 | 1644 | The Artistic License 2.0 (GPL Compatible) 1645 | 1646 | 1647 | =cut 1648 | 1649 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Redis 2 | author = Pedro Melo 3 | author = Damien Krotkine 4 | license = Artistic_2_0 5 | copyright_holder = Pedro Melo, Damien Krotkine 6 | copyright_year = 2015 7 | 8 | ; -- version from git 9 | ;version = 1.993 10 | 11 | [Git::NextVersion] 12 | ;first_version = 1.962 13 | 14 | [MetaJSON] 15 | [MetaResources] 16 | homepage = https://github.com/PerlRedis/perl-redis 17 | bugtracker.web = https://github.com/PerlRedis/perl-redis/issues 18 | repository.web = https://github.com/PerlRedis/perl-redis 19 | repository.url = https://github.com/PerlRedis/perl-redis.git 20 | repository.type = git 21 | 22 | [GatherDir] 23 | exclude_match = redis-server-* 24 | exclude_match = t/redis-server-* 25 | exclude_match = sentinel-* 26 | exclude_match = t/sentinel-* 27 | [PruneCruft] 28 | [ManifestSkip] 29 | [MetaYAML] 30 | [License] 31 | [Readme] 32 | [ExtraTests] 33 | [ExecDir] 34 | [ShareDir] 35 | [Manifest] 36 | [TestRelease] 37 | [ConfirmRelease] 38 | [UploadToCPAN] 39 | 40 | 41 | [ModuleBuildTiny] 42 | [MakeMaker::Fallback] 43 | eumm_version = 6.63_03 44 | [PkgVersion] 45 | [PodWeaver] 46 | [Prepender] 47 | copyright = 1 48 | [MinimumPerl] 49 | [Test::Compile] 50 | [MetaTests] 51 | [PodCoverageTests] 52 | [Prereqs] 53 | Try::Tiny = 0 54 | IO::Socket::Timeout = 0.29 55 | [Prereqs / TestRequires] 56 | Test::SharedFork = 0 57 | Digest::SHA = 0 58 | IO::String = 0 59 | IPC::Cmd = 0 60 | Test::Deep = 0 61 | Test::Fatal = 0 62 | Test::More = 0.98 63 | Test::TCP = 1.19 64 | ; -- release 65 | [NextRelease] 66 | [CheckChangeLog] 67 | [Git::Tag] 68 | [Git::Check] 69 | [Git::Commit] 70 | [Git::Push] 71 | 72 | [Run::AfterRelease] 73 | run = perldoc -u %d%plib%pRedis.pm > README.pod 74 | -------------------------------------------------------------------------------- /lib/Redis/Hash.pm: -------------------------------------------------------------------------------- 1 | package Redis::Hash; 2 | 3 | # ABSTRACT: tie Perl hashes to Redis hashes 4 | # VERSION 5 | # AUTHORITY 6 | 7 | use strict; 8 | use warnings; 9 | use Tie::Hash; 10 | use base qw/Redis Tie::StdHash/; 11 | 12 | 13 | sub TIEHASH { 14 | my ($class, $prefix, @rest) = @_; 15 | my $self = $class->new(@rest); 16 | 17 | $self->{prefix} = $prefix ? "$prefix:" : ''; 18 | 19 | return $self; 20 | } 21 | 22 | sub STORE { 23 | my ($self, $key, $value) = @_; 24 | $self->set($self->{prefix} . $key, $value); 25 | } 26 | 27 | sub FETCH { 28 | my ($self, $key) = @_; 29 | $self->get($self->{prefix} . $key); 30 | } 31 | 32 | sub FIRSTKEY { 33 | my $self = shift; 34 | $self->{prefix_keys} = [$self->keys($self->{prefix} . '*')]; 35 | $self->NEXTKEY; 36 | } 37 | 38 | sub NEXTKEY { 39 | my $self = shift; 40 | 41 | my $key = shift @{ $self->{prefix_keys} }; 42 | return unless defined $key; 43 | 44 | my $p = $self->{prefix}; 45 | $key =~ s/^$p// if $p; 46 | return $key; 47 | } 48 | 49 | sub EXISTS { 50 | my ($self, $key) = @_; 51 | $self->exists($self->{prefix} . $key); 52 | } 53 | 54 | sub DELETE { 55 | my ($self, $key) = @_; 56 | $self->del($self->{prefix} . $key); 57 | } 58 | 59 | sub CLEAR { 60 | my ($self) = @_; 61 | $self->del($_) for $self->keys($self->{prefix} . '*'); 62 | $self->{prefix_keys} = []; 63 | } 64 | 65 | 66 | 1; ## End of Redis::Hash 67 | 68 | 69 | =head1 SYNOPSYS 70 | 71 | ## Create fake hash using keys like 'hash_prefix:KEY' 72 | tie %my_hash, 'Redis::Hash', 'hash_prefix', @Redis_new_parameters; 73 | 74 | ## Treat the entire Redis database as a hash 75 | tie %my_hash, 'Redis::Hash', undef, @Redis_new_parameters; 76 | 77 | $value = $my_hash{$key}; 78 | $my_hash{$key} = $value; 79 | 80 | @keys = keys %my_hash; 81 | @values = values %my_hash; 82 | 83 | %my_hash = reverse %my_hash; 84 | 85 | %my_hash = (); 86 | 87 | 88 | =head1 DESCRIPTION 89 | 90 | Ties a Perl hash to Redis. Note that it doesn't use Redis Hashes, but 91 | implements a fake hash using regular keys like "prefix:KEY". 92 | 93 | If no C is given, it will tie the entire Redis database as a hash. 94 | 95 | Future versions will also allow you to use real Redis hash structures. 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /lib/Redis/List.pm: -------------------------------------------------------------------------------- 1 | package Redis::List; 2 | 3 | # ABSTRACT: tie Perl arrays to Redis lists 4 | # VERSION 5 | # AUTHORITY 6 | 7 | use strict; 8 | use warnings; 9 | use base qw/Redis Tie::Array/; 10 | 11 | 12 | sub TIEARRAY { 13 | my ($class, $list, @rest) = @_; 14 | my $self = $class->new(@rest); 15 | 16 | $self->{list} = $list; 17 | 18 | return $self; 19 | } 20 | 21 | sub FETCH { 22 | my ($self, $index) = @_; 23 | $self->lindex($self->{list}, $index); 24 | } 25 | 26 | sub FETCHSIZE { 27 | my ($self) = @_; 28 | $self->llen($self->{list}); 29 | } 30 | 31 | sub STORE { 32 | my ($self, $index, $value) = @_; 33 | $self->lset($self->{list}, $index, $value); 34 | } 35 | 36 | sub STORESIZE { 37 | my ($self, $count) = @_; 38 | $self->ltrim($self->{list}, 0, $count); 39 | 40 | # if $count > $self->FETCHSIZE; 41 | } 42 | 43 | sub CLEAR { 44 | my ($self) = @_; 45 | $self->del($self->{list}); 46 | } 47 | 48 | sub PUSH { 49 | my $self = shift; 50 | my $list = $self->{list}; 51 | 52 | $self->rpush($list, $_) for @_; 53 | } 54 | 55 | sub POP { 56 | my $self = shift; 57 | $self->rpop($self->{list}); 58 | } 59 | 60 | sub SHIFT { 61 | my ($self) = @_; 62 | $self->lpop($self->{list}); 63 | } 64 | 65 | sub UNSHIFT { 66 | my $self = shift; 67 | my $list = $self->{list}; 68 | 69 | $self->lpush($list, $_) for @_; 70 | } 71 | 72 | sub SPLICE { 73 | my ($self, $offset, $length) = @_; 74 | $self->lrange($self->{list}, $offset, $length); 75 | 76 | # FIXME rest of @_ ? 77 | } 78 | 79 | sub EXTEND { 80 | my ($self, $count) = @_; 81 | $self->rpush($self->{list}, '') for ($self->FETCHSIZE .. ($count - 1)); 82 | } 83 | 84 | sub DESTROY { $_[0]->quit } 85 | 86 | 1; ## End of Redis::List 87 | 88 | =head1 SYNOPSYS 89 | 90 | tie @my_list, 'Redis::List', 'list_name', @Redis_new_parameters; 91 | 92 | $value = $my_list[$index]; 93 | $my_list[$index] = $value; 94 | 95 | $count = @my_list; 96 | 97 | push @my_list, 'values'; 98 | $value = pop @my_list; 99 | unshift @my_list, 'values'; 100 | $value = shift @my_list; 101 | 102 | ## NOTE: fourth parameter of splice is *NOT* supported for now 103 | @other_list = splice(@my_list, 2, 3); 104 | 105 | @my_list = (); 106 | 107 | 108 | =cut 109 | -------------------------------------------------------------------------------- /lib/Redis/Sentinel.pm: -------------------------------------------------------------------------------- 1 | package Redis::Sentinel; 2 | 3 | # ABSTRACT: Redis Sentinel interface 4 | 5 | use warnings; 6 | use strict; 7 | 8 | use Carp; 9 | 10 | use base qw(Redis); 11 | 12 | sub new { 13 | my ($class, %args) = @_; 14 | # these args are not allowed when contacting a sentinel 15 | delete @args{qw(sentinels service)}; 16 | 17 | $class->SUPER::new(%args); 18 | } 19 | 20 | sub get_service_address { 21 | my ($self, $service) = @_; 22 | my ($ip, $port) = $self->sentinel('get-master-addr-by-name', $service); 23 | defined $ip 24 | or return; 25 | $ip eq 'IDONTKNOW' 26 | and return $ip; 27 | return "$ip:$port"; 28 | } 29 | 30 | sub get_masters { 31 | map { +{ @$_ }; } @{ shift->sentinel('masters') || [] }; 32 | } 33 | 34 | 1; 35 | 36 | __END__ 37 | 38 | =head1 SYNOPSIS 39 | 40 | my $sentinel = Redis::Sentinel->new( ... ); 41 | my $service_address = $sentinel->get_service_address('mymaster'); 42 | my @masters = $sentinel->get_masters; 43 | 44 | =head1 DESCRIPTION 45 | 46 | This is a subclass of the Redis module, specialized into connecting to a 47 | Sentinel instance. Inherits from the C package; 48 | 49 | =head1 CONSTRUCTOR 50 | 51 | =head2 new 52 | 53 | See C in L. All parameters are supported, except C 54 | and C, which are silently ignored. 55 | 56 | =head1 METHODS 57 | 58 | All the methods of the C package are supported, plus the additional following methods: 59 | 60 | =head2 get_service_address 61 | 62 | Takes the name of a service as parameter, and returns either void (emptly list) 63 | if the master couldn't be found, the string 'IDONTKNOW' if the service is in 64 | the sentinel config but cannot be reached, or the string C<"$ip:$port"> if the 65 | service were found. 66 | 67 | =head2 get_masters 68 | 69 | Returns a list of HashRefs representing all the master redis instances that 70 | this sentinel monitors. 71 | 72 | =cut 73 | -------------------------------------------------------------------------------- /scripts/publish.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | 5 | use Redis; 6 | 7 | my $pub = Redis->new(); 8 | 9 | my $channel = $ARGV[0] || die "usage: $0 channel\n"; 10 | 11 | print "#$channel > "; 12 | while () { 13 | chomp; 14 | $channel = $1 if s/\s*\#(\w+)\s*//; # remove channel from message 15 | my $nr = $pub->publish($channel, $_); 16 | print "#$channel $nr> "; 17 | } 18 | 19 | -------------------------------------------------------------------------------- /scripts/redis-benchmark.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use warnings; 4 | use strict; 5 | use Benchmark qw/:all/; 6 | use lib 'lib'; 7 | use Redis; 8 | use Redis::Hash; 9 | 10 | my $r = Redis->new; 11 | 12 | my %hash; 13 | tie %hash, 'Redis::Hash', 'hash'; 14 | 15 | my $i = 0; 16 | 17 | timethese( 18 | -5, 19 | { '00_ping' => sub { $r->ping }, 20 | '10_set' => sub { $r->set('foo', $i++) }, 21 | '11_set_r' => sub { $r->set('bench-' . rand(), rand()) }, 22 | '20_get' => sub { $r->get('foo') }, 23 | '21_get_r' => sub { $r->get('bench-' . rand()) }, 24 | '30_incr' => sub { $r->incr('counter') }, 25 | '30_incr_r' => sub { $r->incr('bench-' . rand()) }, 26 | '40_lpush' => sub { $r->lpush('mylist', 'bar') }, 27 | '40_lpush' => sub { $r->lpush('mylist', 'bar') }, 28 | '50_lpop' => sub { $r->lpop('mylist') }, 29 | '90_h_set' => sub { $hash{ 'test' . rand() } = rand() }, 30 | '90_h_get' => sub { my $a = $hash{ 'test' . rand() }; }, 31 | } 32 | ); 33 | -------------------------------------------------------------------------------- /t/01-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | my $n; 22 | is( 23 | exception { $n = Redis->new(server => $srv, 24 | name => 'no_auto_connect', 25 | no_auto_connect_on_new => 1, 26 | ssl => $use_ssl, 27 | SSL_verify_mode => 0) }, 28 | undef, 'Got an unconnected object', 29 | ); 30 | ok(!$n->ping, "ping doesn't work yet"); 31 | $n->connect; 32 | ok($n->ping, "ping works after connection"); 33 | 34 | my $o; 35 | is( 36 | exception { $o = Redis->new(server => $srv, 37 | name => 'my_name_is_glorious', 38 | ssl => $use_ssl, 39 | SSL_verify_mode => 0) }, 40 | undef, 'connected to our test redis-server', 41 | ); 42 | ok($o->ping, 'ping'); 43 | 44 | 45 | ## Commands operating on string values 46 | 47 | ok($o->set(foo => 'bar'), 'set foo => bar'); 48 | 49 | ok(!$o->setnx(foo => 'bar'), 'setnx foo => bar fails'); 50 | 51 | cmp_ok($o->get('foo'), 'eq', 'bar', 'get foo = bar'); 52 | 53 | ok($o->set(foo => ''), 'set foo => ""'); 54 | 55 | cmp_ok($o->get('foo'), 'eq', '', 'get foo = ""'); 56 | 57 | ok($o->set(foo => 'baz'), 'set foo => baz'); 58 | 59 | cmp_ok($o->get('foo'), 'eq', 'baz', 'get foo = baz'); 60 | 61 | my $euro = "\x{20ac}"; 62 | ok ord($euro) > 255, "assume \$eur is wide character"; 63 | ok ! eval { $o->set(utf8 => $euro); 1 }, "accepts only binary data, thus crashes on strings with characters > 255"; 64 | like "$@", qr/command sent is not an octet sequence in the native encoding/i, ".. and crashes on syswrite call"; 65 | 66 | ok ! defined $o->get('utf8'), ".. and does not write actual data"; 67 | 68 | ok($o->set('test-undef' => 42), 'set test-undef'); 69 | ok($o->exists('test-undef'), 'exists undef'); 70 | 71 | # Big sized keys 72 | for my $size (10_000, 100_000, 500_000, 1_000_000, 2_500_000) { 73 | my $v = 'a' x $size; 74 | ok($o->set('big_key', $v), "set with value size $size ok"); 75 | is($o->get('big_key'), $v, "... and get was ok to"); 76 | } 77 | 78 | $o->del('non-existant'); 79 | ok(!$o->exists('non-existant'), 'exists non-existant'); 80 | ok(!defined $o->get('non-existant'), 'get non-existant'); 81 | 82 | my $key_next = 3; 83 | ok($o->set('key-next' => 0), 'key-next = 0'); 84 | ok($o->set('key-left' => $key_next), 'key-left'); 85 | is_deeply([$o->mget('foo', 'key-next', 'key-left')], ['baz', 0, 3], 'mget'); 86 | 87 | my @keys; 88 | foreach my $id (0 .. $key_next) { 89 | my $key = 'key-' . $id; 90 | push @keys, $key; 91 | ok($o->set($key => $id), "set $key"); 92 | ok($o->exists($key), "exists $key"); 93 | is($o->get($key), $id, "get $key"); 94 | cmp_ok($o->incr('key-next'), '==', $id + 1, 'incr'); 95 | cmp_ok($o->decr('key-left'), '==', $key_next - $id - 1, 'decr'); 96 | } 97 | is($o->get('key-next'), $key_next + 1, 'key-next'); 98 | 99 | ok($o->set('test-incrby', 0), 'test-incrby'); 100 | ok($o->set('test-decrby', 0), 'test-decry'); 101 | foreach (1 .. 3) { 102 | is($o->incrby('test-incrby', 3), $_ * 3, 'incrby 3'); 103 | is($o->decrby('test-decrby', 7), -($_ * 7), 'decrby 7'); 104 | } 105 | 106 | ok($o->del($_), "del $_") foreach map {"key-$_"} ('next', 'left'); 107 | ok(!$o->del('non-existing'), 'del non-existing'); 108 | 109 | cmp_ok($o->type('foo'), 'eq', 'string', 'type'); 110 | 111 | is($o->keys('key-*'), $key_next + 1, 'key-*'); 112 | is_deeply([sort $o->keys('key-*')], [sort @keys], 'keys'); 113 | 114 | ok(my $key = $o->randomkey, 'randomkey'); 115 | 116 | ok($o->rename('test-incrby', 'test-renamed'), 'rename'); 117 | ok($o->exists('test-renamed'), 'exists test-renamed'); 118 | 119 | eval { $o->rename('test-decrby', 'test-renamed', 1) }; 120 | ok($@, 'rename to existing key'); 121 | 122 | ok(my $nr_keys = $o->dbsize, 'dbsize'); 123 | 124 | like( 125 | exception { $o->lpush('foo', 'bar') }, 126 | qr/\[lpush\] (?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value,/, 127 | 'Error responses throw exception' 128 | ); 129 | 130 | 131 | ## Commands operating on lists 132 | 133 | my $list = 'test-list'; 134 | 135 | $o->del($list); 136 | 137 | ok($o->rpush($list => "r$_"), 'rpush') foreach (1 .. 3); 138 | 139 | ok($o->lpush($list => "l$_"), 'lpush') foreach (1 .. 2); 140 | 141 | cmp_ok($o->type($list), 'eq', 'list', 'type'); 142 | cmp_ok($o->llen($list), '==', 5, 'llen'); 143 | 144 | is_deeply([$o->lrange($list, 0, 1)], ['l2', 'l1'], 'lrange'); 145 | 146 | ok($o->ltrim($list, 1, 2), 'ltrim'); 147 | cmp_ok($o->llen($list), '==', 2, 'llen after ltrim'); 148 | 149 | cmp_ok($o->lindex($list, 0), 'eq', 'l1', 'lindex'); 150 | cmp_ok($o->lindex($list, 1), 'eq', 'r1', 'lindex'); 151 | 152 | ok($o->lset($list, 0, 'foo'), 'lset'); 153 | cmp_ok($o->lindex($list, 0), 'eq', 'foo', 'verified'); 154 | 155 | ok($o->lrem($list, 1, 'foo'), 'lrem'); 156 | cmp_ok($o->llen($list), '==', 1, 'llen after lrem'); 157 | 158 | cmp_ok($o->lpop($list), 'eq', 'r1', 'lpop'); 159 | 160 | ok(!$o->rpop($list), 'rpop'); 161 | 162 | 163 | ## Commands operating on sets 164 | 165 | my $set = 'test-set'; 166 | $o->del($set); 167 | 168 | ok($o->sadd($set, 'foo'), 'sadd'); 169 | ok(!$o->sadd($set, 'foo'), 'sadd'); 170 | cmp_ok($o->scard($set), '==', 1, 'scard'); 171 | ok($o->sismember($set, 'foo'), 'sismember'); 172 | 173 | cmp_ok($o->type($set), 'eq', 'set', 'type is set'); 174 | 175 | ok($o->srem($set, 'foo'), 'srem'); 176 | ok(!$o->srem($set, 'foo'), 'srem again'); 177 | cmp_ok($o->scard($set), '==', 0, 'scard'); 178 | 179 | $o->del($_) foreach qw( test-set1 test-set2 ); 180 | $o->sadd('test-set1', $_) foreach ('foo', 'bar', 'baz'); 181 | $o->sadd('test-set2', $_) foreach ('foo', 'baz', 'xxx'); 182 | 183 | my $inter = [sort('foo', 'baz')]; 184 | 185 | is_deeply([sort $o->sinter('test-set1', 'test-set2')], $inter, 'sinter'); 186 | 187 | ok($o->sinterstore('test-set-inter', 'test-set1', 'test-set2'), 'sinterstore'); 188 | 189 | cmp_ok($o->scard('test-set-inter'), '==', $#$inter + 1, 'cardinality of intersection'); 190 | 191 | is_deeply([$o->sdiff('test-set1', 'test-set2')], ['bar'], 'sdiff'); 192 | ok($o->sdiffstore(qw( test-set-diff test-set1 test-set2 )), 'sdiffstore'); 193 | is($o->scard('test-set-diff'), 1, 'cardinality of diff'); 194 | 195 | my @union = sort qw( foo bar baz xxx ); 196 | is_deeply([sort $o->sunion(qw( test-set1 test-set2 ))], \@union, 'sunion'); 197 | ok($o->sunionstore(qw( test-set-union test-set1 test-set2 )), 'sunionstore'); 198 | is($o->scard('test-set-union'), scalar(@union), 'cardinality of union'); 199 | 200 | my $first_rand = $o->srandmember('test-set-union'); 201 | ok(defined $first_rand, 'srandmember result is defined'); 202 | ok(scalar grep { $_ eq $first_rand } @union, 'srandmember'); 203 | my $second_rand = $o->spop('test-set-union'); 204 | ok(defined $first_rand, 'spop result is defined'); 205 | ok(scalar grep { $_ eq $second_rand } @union, 'spop'); 206 | is($o->scard('test-set-union'), scalar(@union) - 1, 'new cardinality of union'); 207 | 208 | $o->del('test_set3'); 209 | my @test_set3 = sort qw( foo bar baz ); 210 | $o->sadd('test-set3', $_) foreach @test_set3; 211 | is_deeply([sort $o->smembers('test-set3')], \@test_set3, 'smembers'); 212 | 213 | $o->del('test-set4'); 214 | $o->smove(qw( test-set3 test-set4 ), $_) foreach @test_set3; 215 | is($o->scard('test-set3'), 0, 'repeated smove depleted source'); 216 | is($o->scard('test-set4'), scalar(@test_set3), 'repeated smove populated destination'); 217 | is_deeply([sort $o->smembers('test-set4')], \@test_set3, 'smembers'); 218 | 219 | 220 | ## Commands operating on zsets (sorted sets) 221 | # TODO: ZUNIONSTORE, ZINTERSTORE, SORT, tests w/multiple values having the same score 222 | 223 | my $zset = 'test-zset'; 224 | $o->del($zset); 225 | 226 | ok($o->zadd($zset, 0, 'foo')); 227 | ok(!$o->zadd($zset, 1, 'foo')); # 0 returned because foo is already in the set 228 | 229 | is($o->zscore($zset, 'foo'), 1); 230 | 231 | ok($o->zincrby($zset, 1, 'foo')); 232 | is($o->zscore($zset, 'foo'), 2); 233 | 234 | ok($o->zincrby($zset, 1, 'bar')); 235 | is($o->zscore($zset, 'bar'), 1); # bar was new, so its score got set to the increment 236 | 237 | SKIP: { 238 | eval { $o->zrank($zset, 'bar') }; 239 | skip "zrank not implemented in this redis", 4 if $@ && $@ =~ /unknown command/; 240 | is($o->zrank($zset, 'bar'), 0); 241 | is($o->zrank($zset, 'foo'), 1); 242 | 243 | is($o->zrevrank($zset, 'bar'), 1); 244 | is($o->zrevrank($zset, 'foo'), 0); 245 | } 246 | 247 | ok($o->zadd($zset, 2.1, 'baz')); # we now have bar foo baz 248 | 249 | is_deeply([$o->zrange($zset, 0, 1)], [qw/bar foo/]); 250 | is_deeply([$o->zrevrange($zset, 0, 1)], [qw/baz foo/]); 251 | 252 | 253 | my $withscores = { $o->zrevrange($zset, 0, 1, 'WITHSCORES') }; 254 | 255 | # this uglyness gets around floating point weirdness in the return (I.E. 2.1000000000000001); 256 | my $rounded_withscores = { 257 | map { $_ => 0 + sprintf("%0.5f", $withscores->{$_}) } 258 | keys %$withscores 259 | }; 260 | 261 | is_deeply($rounded_withscores, { baz => 2.1, foo => 2 }); 262 | 263 | is_deeply([$o->zrangebyscore($zset, 2, 3)], [qw/foo baz/]); 264 | 265 | SKIP: { 266 | eval { $o->zcount($zset, 2, 3) }; 267 | skip "zcount not implemented in this redis", 1 if $@ && $@ =~ /unknown command/; 268 | is($o->zcount($zset, 2, 3), 2); 269 | } 270 | 271 | is($o->zcard($zset), 3); 272 | 273 | ok($o->del($zset)); # cleanup 274 | 275 | my $score = 0.1; 276 | my @zkeys = (qw/foo bar baz qux quux quuux quuuux quuuuux/); 277 | 278 | ok($o->zadd($zset, $score++, $_)) for @zkeys; 279 | is_deeply([$o->zrangebyscore($zset, 0, 8)], \@zkeys); 280 | 281 | SKIP: { 282 | my $retval = eval { $o->zremrangebyrank($zset, 5, 8) }; 283 | skip "zremrangebyrank not implemented in this redis", 5 if $@ && $@ =~ /unknown command/; 284 | is($retval, 3); # remove quux and up 285 | is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]); 286 | 287 | is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar 288 | is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[2 .. 4]]); 289 | 290 | # only left with 3 291 | is($o->zcard($zset), 3); 292 | } 293 | 294 | ok($o->del($zset)); # cleanup 295 | 296 | 297 | ## Commands operating on hashes 298 | 299 | my $hash = 'test-hash'; 300 | $o->del($hash); 301 | 302 | SKIP: { 303 | my $retval = eval { $o->hset($hash, foo => 'bar') }; 304 | skip "hset not implemented in this redis", 20 if $@ && $@ =~ /unknown command/; 305 | ok($retval); 306 | is($o->hget($hash, 'foo'), 'bar'); 307 | ok($o->hexists($hash, 'foo')); 308 | ok($o->hdel($hash, 'foo')); 309 | ok(!$o->hexists($hash, 'foo')); 310 | 311 | ok($o->hincrby($hash, incrtest => 1)); 312 | is($o->hget($hash, 'incrtest'), 1); 313 | 314 | is($o->hincrby($hash, incrtest => -1), 0); 315 | is($o->hget($hash, 'incrtest'), 0); 316 | 317 | ok($o->hdel($hash, 'incrtest')); #cleanup 318 | 319 | ok($o->hsetnx($hash, setnxtest => 'baz')); 320 | ok(!$o->hsetnx($hash, setnxtest => 'baz')); # already exists, 0 returned 321 | 322 | ok($o->hdel($hash, 'setnxtest')); #cleanup 323 | 324 | ok($o->hmset($hash, foo => 1, bar => 2, baz => 3, qux => 4)); 325 | 326 | is_deeply([$o->hmget($hash, qw/foo bar baz/)], [1, 2, 3]); 327 | 328 | is($o->hlen($hash), 4); 329 | 330 | is_deeply([$o->hkeys($hash)], [qw/foo bar baz qux/]); 331 | is_deeply([$o->hvals($hash)], [qw/1 2 3 4/]); 332 | is_deeply({ $o->hgetall($hash) }, { foo => 1, bar => 2, baz => 3, qux => 4 }); 333 | 334 | ok($o->del($hash)); # remove entire hash 335 | } 336 | 337 | ## Multiple databases handling commands 338 | 339 | ok($o->select(1), 'select'); 340 | ok($o->select(0), 'select'); 341 | 342 | ok($o->move('foo', 1), 'move'); 343 | ok(!$o->exists('foo'), 'gone'); 344 | 345 | ok($o->select(1), 'select'); 346 | ok($o->exists('foo'), 'exists'); 347 | 348 | ok($o->flushdb, 'flushdb'); 349 | cmp_ok($o->dbsize, '==', 0, 'empty'); 350 | 351 | 352 | ## Sorting 353 | 354 | ok($o->lpush('test-sort', $_), "put $_") foreach (1 .. 4); 355 | cmp_ok($o->llen('test-sort'), '==', 4, 'llen'); 356 | 357 | is_deeply([$o->sort('test-sort')], [1, 2, 3, 4], 'sort'); 358 | is_deeply([$o->sort('test-sort', 'DESC')], [4, 3, 2, 1], 'sort DESC'); 359 | 360 | 361 | ## "Persistence control commands" 362 | 363 | ok($o->save, 'save'); 364 | ok($o->bgsave, 'bgsave'); 365 | ok($o->lastsave, 'lastsave'); 366 | 367 | #ok( $o->shutdown, 'shutdown' ); 368 | 369 | 370 | ## Remote server control commands 371 | 372 | ok(my $info = $o->info, 'info'); 373 | isa_ok($info, 'HASH', '... yields a hash'); 374 | ok(keys %$info, '... nonempty'); 375 | unlike(join("\n", keys %$info), qr/#/, '... with no comments in the keys'); 376 | unlike(join("\n", keys %$info), qr/\n\n|\A\n|\n\z/, '... with no blank lines in the keys'); 377 | 378 | 379 | ## Connection handling 380 | 381 | ok($o->ping, 'ping() is true'); 382 | ok($o->quit, 'quit'); 383 | ok(!$o->quit, 'quit again, ok'); 384 | ok(!$o->ping, '... but after quit() returns false'); 385 | 386 | $o = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 387 | ok($o->shutdown(), 'shutdown() once is ok'); 388 | ok(!$o->shutdown(), '... twice also lives, but returns false'); 389 | ok(!$o->ping(), 'ping() will be false after shutdown()'); 390 | 391 | # Shutdown the SSL tunnel if it is used 392 | $t->() if $t; 393 | # and wait for the server to shutdown 394 | sleep(1); 395 | 396 | like( 397 | exception { Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0) }, 398 | qr/Could not connect to Redis server at $srv/, 399 | 'Failed connection throws exception' 400 | ); 401 | 402 | 403 | ## All done 404 | done_testing(); 405 | -------------------------------------------------------------------------------- /t/02-responses.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Test::Deep; 8 | use IO::String; 9 | use Redis; 10 | use lib 't/tlib'; 11 | use Test::SpawnRedisServer; 12 | 13 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 14 | 15 | my ($c, $t, $srv) = redis(); 16 | END { 17 | $c->() if $c; 18 | $t->() if $t; 19 | } 20 | 21 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 22 | 23 | ok(my $r = Redis->new(server => $srv, 24 | ssl => $use_ssl, 25 | SSL_verify_mode => 0), 'connected to our test redis-server'); 26 | 27 | sub r { 28 | $r->{sock} = IO::String->new(join('', map {"$_\r\n"} @_)); 29 | $r->{__buf} = ''; 30 | } 31 | 32 | ## -ERR responses 33 | r('-you must die!!'); 34 | is_deeply([$r->__read_response('cmd')], [undef, 'you must die!!'], 'Error response detected'); 35 | 36 | 37 | ## +TEXT responses 38 | my $m; 39 | r('+all your text are belong to us'); 40 | is_deeply([$r->__read_response('cmd')], ['all your text are belong to us', undef], 'Text response ok'); 41 | 42 | 43 | ## :NUMBER responses 44 | r(':234'); 45 | is_deeply([$r->__read_response('cmd')], [234, undef], 'Integer response ok'); 46 | 47 | 48 | ## $SIZE PAYLOAD responses 49 | r('$19', "Redis\r\nis\r\ngreat!\r\n"); 50 | is_deeply([$r->__read_response('cmd')], ["Redis\r\nis\r\ngreat!\r\n", undef], 'Size+payload response ok'); 51 | 52 | r('$0', ""); 53 | is_deeply([$r->__read_response('cmd')], ['', undef], 'Zero-size+payload response ok'); 54 | 55 | r('$-1'); 56 | is_deeply([$r->__read_response('cmd')], [undef, undef], 'Negative-size+payload response ok'); 57 | 58 | 59 | ## Multi-bulk responses 60 | my @m; 61 | r('*4', '$5', 'Redis', ':42', '$-1', '+Cool stuff'); 62 | cmp_deeply([$r->__read_response('cmd')], [['Redis', 42, undef, 'Cool stuff'], undef], 'Simple multi-bulk response ok'); 63 | 64 | 65 | ## Nested Multi-bulk responses 66 | r('*5', '$5', 'Redis', ':42', '*4', ':1', ':2', '$4', 'hope', '*2', ':4', ':5', '$-1', '+Cool stuff'); 67 | cmp_deeply( 68 | [$r->__read_response('cmd')], 69 | [['Redis', 42, [1, 2, 'hope', [4, 5]], undef, 'Cool stuff'], undef], 70 | 'Nested multi-bulk response ok' 71 | ); 72 | 73 | 74 | ## Nil multi-bulk responses 75 | r('*-1'); 76 | is_deeply([$r->__read_response('cmd')], [undef, undef], 'Read a NIL multi-bulk response'); 77 | 78 | 79 | ## Multi-bulk responses with nested error 80 | r('*3', '$5', 'Redis', '-you must die!!', ':42'); 81 | like( 82 | exception { $r->__read_response('cmd') }, 83 | qr/\[cmd\] you must die!!/, 84 | 'Nested errors must usually throw exceptions' 85 | ); 86 | 87 | r('*3', '$5', 'Redis', '-you must die!!', ':42'); 88 | is_deeply( 89 | [$r->__read_response('cmd', 1)], 90 | [[['Redis', undef], [undef, 'you must die!!'], [42, undef]], undef,], 91 | 'Nested errors must be collected in collect-errors mode' 92 | ); 93 | 94 | 95 | done_testing(); 96 | -------------------------------------------------------------------------------- /t/03-pubsub.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Test::Deep; 8 | use Redis; 9 | use lib 't/tlib'; 10 | use Test::SpawnRedisServer qw( redis reap ); 11 | 12 | use constant DEFAULT_DELAY => 5; 13 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 14 | 15 | my ($c, $t, $srv) = redis(); 16 | END { 17 | $c->() if $c; 18 | $t->() if $t; 19 | } 20 | 21 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 22 | 23 | { 24 | my $r = Redis->new(server => $srv, 25 | ssl => $use_ssl, 26 | SSL_verify_mode => 0); 27 | eval { $r->publish( 'aa', 'v1' ) }; 28 | plan 'skip_all' => "pubsub not implemented on this redis server" if $@ && $@ =~ /unknown command/; 29 | } 30 | 31 | my ($another_kill_switch, $yet_another_kill_switch); 32 | my ($another_kill_switch_stunnel, $yet_another_kill_switch_stunnel); 33 | END { 34 | $_ and $_->() for ($another_kill_switch, 35 | $yet_another_kill_switch, 36 | $another_kill_switch_stunnel, 37 | $yet_another_kill_switch_stunnel) 38 | } 39 | 40 | subtest 'basics' => sub { 41 | my %got; 42 | ok(my $pub = Redis->new(server => $srv, 43 | ssl => $use_ssl, 44 | SSL_verify_mode => 0), 'connected to our test redis-server (pub)'); 45 | ok(my $sub = Redis->new(server => $srv, 46 | ssl => $use_ssl, 47 | SSL_verify_mode => 0), 'connected to our test redis-server (sub)'); 48 | 49 | is($pub->publish('aa', 'v1'), 0, "No subscribers to 'aa' topic"); 50 | 51 | my $db_size = -1; 52 | $sub->dbsize(sub { $db_size = $_[0] }); 53 | 54 | 55 | ## Basic pubsub 56 | my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; 57 | $sub->subscribe('aa', 'bb', $sub_cb); 58 | is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); 59 | 60 | is($db_size, 0, 'subscribing processes pending queued commands'); 61 | 62 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 63 | cmp_deeply(\%got, { 'aa' => 'v1:aa' }, "... for the expected topic, 'aa'"); 64 | 65 | my $sub_cb2 = sub { my ($v, $t, $s) = @_; $got{"2$s"} = uc("$v:$t") }; 66 | $sub->subscribe('aa', $sub_cb2); 67 | is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); 68 | 69 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 70 | cmp_deeply(\%got, { 'aa' => 'v1:aa', '2aa' => 'V1:AA' }, "... for the expected topic, 'aa', with two handlers"); 71 | 72 | 73 | ## Trick subscribe with other messages 74 | my $psub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; 75 | %got = (); 76 | is($pub->publish('aa', 'v2'), 1, "Delivered to 1 subscriber of topic 'aa'"); 77 | $sub->psubscribe('a*', 'c*', $psub_cb); 78 | cmp_deeply( 79 | \%got, 80 | { 'aa' => 'v2:aa', '2aa' => 'V2:AA' }, 81 | '... received message while processing psubscribe(), two handlers' 82 | ); 83 | 84 | is($pub->publish('aa', 'v3'), 2, "Delivered to 2 subscriber of topic 'aa'"); 85 | is($sub->wait_for_messages(1), 2, '... yep, got the expected 2 messages'); 86 | cmp_deeply( 87 | \%got, 88 | { 'aa' => 'v3:aa', 'a*' => 'v3:aa', '2aa' => 'V3:AA' }, 89 | "... for the expected subs, 'aa' and 'a*', three handlers total" 90 | ); 91 | 92 | 93 | ## Test subscribe/psubscribe diffs 94 | %got = (); 95 | is($pub->publish('aaa', 'v4'), 1, "Delivered to 1 subscriber of topic 'aaa'"); 96 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 97 | cmp_deeply(\%got, { 'a*' => 'v4:aaa' }, "... for the expected sub, 'a*'"); 98 | 99 | 100 | ## Subscriber mode status 101 | is($sub->is_subscriber, 4, 'Current subscriber has 4 subscriptions active'); 102 | is($pub->is_subscriber, 0, '... the publisher has none'); 103 | 104 | 105 | ## Unsubscribe 106 | $sub->unsubscribe('xx', sub { }); 107 | is($sub->is_subscriber, 4, "No match to our subscriptions, unsubscribe doesn't change active count"); 108 | 109 | $sub->unsubscribe('aa', $sub_cb); 110 | is($sub->is_subscriber, 4, "unsubscribe ok, active count is still 4, another handler is alive"); 111 | 112 | $sub->unsubscribe('aa', $sub_cb2); 113 | is($sub->is_subscriber, 3, "unsubscribe done, active count is now 3, both handlers are done"); 114 | 115 | $pub->publish('aa', 'v5'); 116 | %got = (); 117 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 118 | cmp_deeply(\%got, { 'a*', 'v5:aa' }, "... for the expected key, 'a*'"); 119 | 120 | $sub->unsubscribe('a*', $psub_cb); 121 | is($sub->is_subscriber, 3, "unsubscribe with topic wildcard failed, active count is now 3"); 122 | 123 | $pub->publish('aa', 'v6'); 124 | %got = (); 125 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 126 | cmp_deeply(\%got, { 'a*', 'v6:aa' }, "... for the expected key, 'a*'"); 127 | 128 | $sub->unsubscribe('bb', $sub_cb); 129 | is($sub->is_subscriber, 2, "unsubscribe with 'bb' ok, active count is now 2"); 130 | 131 | $sub->punsubscribe('a*', $psub_cb); 132 | is($sub->is_subscriber, 1, "punsubscribe with 'a*' ok, active count is now 1"); 133 | 134 | is($pub->publish('aa', 'v6'), 0, "Publish to 'aa' now gives 0 deliveries"); 135 | %got = (); 136 | is($sub->wait_for_messages(1), 0, '... yep, no messages delivered'); 137 | cmp_deeply(\%got, {}, '... and an empty messages recorded set'); 138 | 139 | is($sub->is_subscriber, 1, 'Still some pending subcriptions active'); 140 | for my $cmd (qw) { 141 | like( 142 | exception { $sub->$cmd }, 143 | qr/Cannot use command '(?i:$cmd)' while in SUBSCRIBE mode/, 144 | ".. still an error to try \U$cmd\E while in SUBSCRIBE mode" 145 | ); 146 | } 147 | $sub->punsubscribe('c*', $psub_cb); 148 | is($sub->is_subscriber, 0, '... but none anymore'); 149 | 150 | is(exception { $sub->info }, undef, 'Other commands ok after we leave subscriber_mode'); 151 | }; 152 | 153 | subtest 'zero_topic' => sub { 154 | my %got; 155 | my $pub = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 156 | my $sub = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 157 | 158 | my $db_size = -1; 159 | $sub->dbsize(sub { $db_size = $_[0] }); 160 | 161 | my $bad_topic = '0'; 162 | 163 | my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; 164 | $sub->psubscribe("$bad_topic*", 'xx', $sub_cb); 165 | is($pub->publish($bad_topic, 'vBAD'), 1, "Delivered to 1 subscriber of topic '$bad_topic'"); 166 | 167 | is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); 168 | cmp_deeply(\%got, { "$bad_topic*" => "vBAD:$bad_topic" }, "... for the expected topic, '$bad_topic'"); 169 | }; 170 | 171 | 172 | subtest 'server is killed while waiting for subscribe' => sub { 173 | my ($another_kill_switch, $another_kill_switch_stunnel, $another_server) = redis(); 174 | 175 | my $pid = fork(); 176 | BAIL_OUT("Fork failed, aborting") unless defined $pid; 177 | 178 | if ($pid) { ## parent, we'll wait for the child to die quickly 179 | ok(my $sync = Redis->new(server => $srv, 180 | ssl => $use_ssl, 181 | SSL_verify_mode => 0), 'connected to our test redis-server (sync parent)'); 182 | BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); 183 | 184 | ok($another_kill_switch->(), "pub/sub redis server killed"); 185 | 186 | if ($another_kill_switch_stunnel) { 187 | ok($another_kill_switch_stunnel->(), "stunnel killed"); 188 | } 189 | 190 | note("parent killed pub/sub redis server, signal child to proceed"); 191 | $sync->lpush('wake_up_child', 'the redis-server is dead, do your thing'); 192 | 193 | note("parent waiting for child $pid..."); 194 | my $failed = reap($pid, 5); 195 | if ($failed) { 196 | fail("wait_for_messages() hangs when the server goes away..."); 197 | kill(9, $pid); 198 | reap($pid) and fail('... failed to reap the dead child'); 199 | } 200 | else { 201 | pass("wait_for_messages() properly detects a server that dies"); 202 | } 203 | } 204 | else { ## child 205 | my $sync = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 206 | my $sub = Redis->new(server => $another_server, ssl => $use_ssl, SSL_verify_mode => 0); 207 | $sub->subscribe('chan', sub { }); 208 | 209 | note("child is ready to test, signal parent to kill our server"); 210 | $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); 211 | die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); 212 | 213 | ## This is the test, next wait_for_messages() should not block 214 | note("now, check wait_for_messages(), should die..."); 215 | like( 216 | exception { $sub->wait_for_messages(0) }, 217 | qr/EOF from server/, 218 | "properly died with EOF" 219 | ); 220 | exit(0); 221 | } 222 | }; 223 | 224 | subtest 'server is restarted while waiting for subscribe' => sub { 225 | my @ret = redis(); 226 | my ($another_kill_switch, $another_kill_switch_stunnel, $another_server) = @ret; 227 | pop @ret; 228 | my $port = pop @ret; 229 | 230 | my $pid = fork(); 231 | BAIL_OUT("Fork failed, aborting") unless defined $pid; 232 | 233 | if ($pid) { ## parent, we'll wait for the child to die quickly 234 | 235 | ok(my $sync = Redis->new(server => $srv, 236 | ssl => $use_ssl, 237 | SSL_verify_mode => 0), 'PARENT: connected to our test redis-server (sync parent)'); 238 | BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); 239 | 240 | ok($another_kill_switch->(), "PARENT: pub/sub redis server killed"); 241 | 242 | if ($another_kill_switch_stunnel) { 243 | ok($another_kill_switch_stunnel->(), "stunnel killed"); 244 | } 245 | 246 | note("PARENT: killed pub/sub redis server, signal child to proceed"); 247 | $sync->lpush('wake_up_child', 'the redis-server is dead, waiting before respawning it'); 248 | 249 | sleep DEFAULT_DELAY; 250 | 251 | # relaunch it on the same port 252 | my ($yet_another_kill_switch, $yet_another_kill_switch_stunnel) = redis(port => $port); 253 | my $pub = Redis->new(server => $another_server, ssl => $use_ssl, SSL_verify_mode => 0); 254 | 255 | note("PARENT: has relaunched the server..."); 256 | sleep DEFAULT_DELAY; 257 | 258 | is($pub->publish('chan', 'v1'), 1, "PARENT: published and the child is subscribed"); 259 | 260 | note("PARENT: waiting for child $pid..."); 261 | my $failed = reap($pid, 5); 262 | if ($failed) { 263 | fail("PARENT: wait_for_messages() hangs when the server goes away..."); 264 | kill(9, $pid); 265 | reap($pid) and fail('PARENT: ... failed to reap the dead child'); 266 | } 267 | else { 268 | pass("PARENT: child has properly quit after wait_for_messages()"); 269 | } 270 | ok($yet_another_kill_switch->(), "PARENT: pub/sub redis server killed"); 271 | 272 | if ($yet_another_kill_switch_stunnel) { 273 | ok($yet_another_kill_switch_stunnel->(), "stunnel killed"); 274 | } 275 | } 276 | else { ## child 277 | my $sync = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 278 | my $sub = Redis->new(server => $another_server, 279 | ssl => $use_ssl, 280 | SSL_verify_mode => 0, 281 | reconnect => 10, 282 | on_connect => sub { note "CHILD: reconnected (with a 10s timeout)"; } 283 | ); 284 | 285 | my %got; 286 | $sub->subscribe('chan', sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }); 287 | 288 | note("CHILD: is ready to test, signal parent to restart our server"); 289 | $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); 290 | die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); 291 | 292 | ## This is the test, wait_for_messages() should reconnect to the respawned server 293 | while (1) { 294 | note("CHILD: launch wait_for_messages(2), with reconnect..."); 295 | my $r = $sub->wait_for_messages(2); 296 | $r and last; 297 | note("CHILD: after 2 sec, nothing yet, retrying"); 298 | } 299 | note("CHILD: child received the message"); 300 | cmp_deeply(\%got, { 'chan' => 'v1:chan' }, "CHILD: the message is what we want"); 301 | exit(0); 302 | } 303 | }; 304 | 305 | ## And we are done 306 | done_testing(); 307 | -------------------------------------------------------------------------------- /t/04-pipeline.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | use Test::Deep; 11 | 12 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 13 | 14 | my ($c, $t, $srv) = redis(); 15 | END { 16 | $c->() if $c; 17 | $t->() if $t; 18 | } 19 | 20 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 21 | 22 | { 23 | my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 24 | eval { $r->multi( ); }; 25 | plan 'skip_all' => "multi without arguments not implemented on this redis server" if $@ && $@ =~ /unknown command/; 26 | } 27 | 28 | 29 | ok(my $r = Redis->new(server => $srv, 30 | ssl => $use_ssl, 31 | SSL_verify_mode => 0), 'connected to our test redis-server'); 32 | 33 | sub pipeline_ok { 34 | my ($desc, @commands) = @_; 35 | my (@responses, @expected_responses); 36 | for my $cmd (@commands) { 37 | my ($method, $args, $expected, $expected_err) = @$cmd; 38 | push @expected_responses, [$expected, $expected_err]; 39 | $r->$method(@$args, sub { push @responses, [@_] }); 40 | } 41 | $r->wait_all_responses; 42 | 43 | cmp_deeply(\@responses, \@expected_responses, $desc); 44 | } 45 | 46 | pipeline_ok 'single-command pipeline', ([set => [foo => 'bar'], 'OK'],); 47 | 48 | pipeline_ok 'pipeline with embedded error', 49 | ([set => [clunk => 'eth'], 'OK'], [oops => [], undef, re(qr{^ERR unknown command .OOPS.})], [get => ['clunk'], 'eth'],); 50 | 51 | pipeline_ok 'keys in pipelined mode', 52 | ([keys => ['*'], bag(qw)], [keys => [], undef, q[ERR wrong number of arguments for 'keys' command]],); 53 | 54 | pipeline_ok 'info in pipelined mode', 55 | ( 56 | [info => [], code(sub { ref $_[0] eq 'HASH' && keys %{ $_[0] } })], 57 | $r->info->{redis_version} ge '7.0.0' ? ( 58 | [ info => [qw], 59 | {}, 60 | ], 61 | ) : ( 62 | [ info => [qw], 63 | undef, 64 | re(qr{^ERR (?:syntax error|wrong number of arguments for 'info' command)$}) 65 | ], 66 | ) 67 | ); 68 | 69 | pipeline_ok 'pipeline with multi-bulk reply', 70 | ([hmset => [kapow => (a => 1, b => 2, c => 3)], 'OK'], [hmget => [kapow => qw], [3, 2, 1]],); 71 | 72 | pipeline_ok 'large pipeline', 73 | ( 74 | (map { [hset => [zzapp => $_ => -$_], 1] } 1 .. 5000), 75 | [hmget => [zzapp => (1 .. 5000)], [reverse -5000 .. -1]], 76 | [del => ['zzapp'], 1], 77 | ); 78 | 79 | subtest 'synchronous request with pending pipeline' => sub { 80 | my $clunk; 81 | is($r->get('clunk', sub { $clunk = $_[0] }), 1, 'queue a request'); 82 | is($r->set('kapow', 'zzapp', sub { }), 1, 'queue another request'); 83 | is($r->get('kapow'), 'zzapp', 'synchronous request has expected return'); 84 | is($clunk, 'eth', 'synchronous request processes pending ones'); 85 | }; 86 | 87 | subtest 'transaction with error and pipeline' => sub { 88 | my @responses; 89 | my $s = sub { push @responses, [@_] }; 90 | $r->multi($s); 91 | $r->set(clunk => 'eth', $s); 92 | $r->rpush(clunk => 'oops', $s); 93 | $r->get('clunk', $s); 94 | $r->exec($s); 95 | $r->wait_all_responses; 96 | 97 | is(shift(@responses)->[0], 'OK' , 'multi started' ); 98 | is(shift(@responses)->[0], 'QUEUED', 'queued'); 99 | is(shift(@responses)->[0], 'QUEUED', 'queued'); 100 | is(shift(@responses)->[0], 'QUEUED', 'queued'); 101 | my $resp = shift @responses; 102 | is ($resp->[0]->[0]->[0], 'OK', 'set'); 103 | is ($resp->[0]->[1]->[0], undef, 'bad rpush value should be undef'); 104 | like ($resp->[0]->[1]->[1], 105 | qr/(?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value/, 106 | 'bad rpush should give an error'); 107 | is ($resp->[0]->[2]->[0], 'eth', 'get should work'); 108 | }; 109 | 110 | subtest 'transaction with error and no pipeline' => sub { 111 | is($r->multi, 'OK', 'multi'); 112 | is($r->set('clunk', 'eth'), 'QUEUED', 'transactional SET'); 113 | is($r->rpush('clunk', 'oops'), 'QUEUED', 'transactional bad RPUSH'); 114 | is($r->get('clunk'), 'QUEUED', 'transactional GET'); 115 | like( 116 | exception { $r->exec }, 117 | qr{\[exec\] (?:WRONGTYPE|ERR) Operation against a key holding the wrong kind of value,}, 118 | 'synchronous EXEC dies for intervening error' 119 | ); 120 | }; 121 | 122 | 123 | subtest 'wait_one_response' => sub { 124 | my $first; 125 | my $second; 126 | 127 | $r->get('a', sub { $first++ }); 128 | $r->get('a', sub { $second++ }); 129 | $r->get('a', sub { $first++ }); 130 | $r->get('a', sub { $second++ }); 131 | 132 | $r->wait_one_response(); 133 | is($first, 1, 'after first wait_one_response(), first callback called'); 134 | is($second, undef, '... but not the second one'); 135 | 136 | $r->wait_one_response(); 137 | is($first, 1, 'after second wait_one_response(), first callback was not called again'); 138 | is($second, 1, '... but the second one was called'); 139 | 140 | $r->wait_all_responses(); 141 | is($first, 2, 'after final wait_all_responses(), first callback was called again'); 142 | is($second, 2, '... the second one was also called'); 143 | 144 | $r->wait_one_response(); 145 | is($first, 2, 'after final wait_one_response(), first callback was not called again'); 146 | is($second, 2, '... nor was the second one'); 147 | }; 148 | 149 | 150 | done_testing(); 151 | -------------------------------------------------------------------------------- /t/05-nonblock.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Redis; 7 | use lib 't/tlib'; 8 | use Test::SpawnRedisServer; 9 | 10 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 11 | 12 | my ($c, $t, $srv, undef, undef, undef, undef, undef, $sock_temp_file) = redis(); 13 | 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | subtest 'non-block TCP' => sub { 22 | ok(my $r = Redis->new(server => $srv, 23 | ssl => $use_ssl, 24 | SSL_verify_mode => 0), 'connected to our test redis-server via TCP'); 25 | 26 | ## Try to read from server (nothing sent, so nothing to read) 27 | ## But kill if we block 28 | local $SIG{ALRM} = sub { kill 9, $$ }; 29 | alarm(2); 30 | ok(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block"); 31 | alarm(0); 32 | }; 33 | 34 | 35 | subtest 'non-block UNIX' => sub { 36 | ok(my $r = Redis->new(sock => $sock_temp_file), 'connected to our test redis-server via UNIX'); 37 | 38 | ## Try to read from server (nothing sent, so nothing to read) 39 | ## But kill if we block 40 | local $SIG{ALRM} = sub { kill 9, $$ }; 41 | alarm(2); 42 | ok(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block"); 43 | alarm(0); 44 | }; 45 | 46 | 47 | done_testing(); 48 | -------------------------------------------------------------------------------- /t/06-on-connect.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(timeout => 1); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | subtest 'on_connect' => sub { 22 | my $r; 23 | ok($r = Redis->new(server => $srv, 24 | on_connect => sub { shift->incr('on_connect') }, 25 | ssl => $use_ssl, 26 | SSL_verify_mode => 0), 27 | 'connected to our test redis-server'); 28 | is($r->get('on_connect'), 1, '... on_connect code was run'); 29 | 30 | ok($r = Redis->new(server => $srv, 31 | on_connect => sub { shift->incr('on_connect') }, 32 | ssl => $use_ssl, 33 | SSL_verify_mode => 0), 34 | 'new connection is up and running'); 35 | is($r->get('on_connect'), 2, '... on_connect code was run again'); 36 | 37 | ok($r = Redis->new(reconnect => 1, 38 | server => $srv, 39 | on_connect => sub { shift->incr('on_connect') }, 40 | ssl => $use_ssl, 41 | SSL_verify_mode => 0), 42 | 'new connection with reconnect enabled'); 43 | is($r->get('on_connect'), 3, '... on_connect code one again perfect'); 44 | 45 | $r->quit; 46 | is($r->get('on_connect'), 4, '... on_connect code works after reconnect also'); 47 | }; 48 | 49 | 50 | done_testing(); 51 | -------------------------------------------------------------------------------- /t/07-reconnect.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Time::HiRes qw(gettimeofday tv_interval); 8 | use Redis; 9 | use lib 't/tlib'; 10 | use Test::SpawnRedisServer; 11 | use Net::EmptyPort qw(empty_port); 12 | 13 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 14 | 15 | my ($c, $t, $srv) = redis(timeout => 1); 16 | END { 17 | $c->() if $c; 18 | $t->() if $t; 19 | } 20 | 21 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 22 | 23 | subtest 'Command without connection, no reconnect' => sub { 24 | ok(my $r = Redis->new(reconnect => 0, 25 | server => $srv, 26 | ssl => $use_ssl, 27 | SSL_verify_mode => 0), 'connected to our test redis-server'); 28 | ok($r->quit, 'close connection to the server'); 29 | 30 | like(exception { $r->set(reconnect => 1) }, qr{Not connected to any server}, 'send ping without reconnect',); 31 | }; 32 | 33 | subtest 'Command without connection or timeout, with database change, with reconnect' => sub { 34 | ok(my $r = Redis->new(reconnect => 2, 35 | server => $srv, 36 | ssl => $use_ssl, 37 | SSL_verify_mode => 0), 'connected to our test redis-server'); 38 | 39 | ok($r->select(4), 'send command with reconnect'); 40 | ok($r->set(reconnect => $$), 'send command with reconnect'); 41 | ok($r->quit, 'close connection to the server'); 42 | is($r->get('reconnect'), $$, 'reconnect with read errors before write'); 43 | }; 44 | 45 | 46 | subtest 'Reconnection discards pending commands' => sub { 47 | ok(my $r = Redis->new(reconnect => 2, 48 | server => $srv, 49 | ssl => $use_ssl, 50 | SSL_verify_mode => 0), 'connected to our test redis-server'); 51 | 52 | my $processed_pending = 0; 53 | $r->dbsize(sub { $processed_pending++ }); 54 | 55 | ok(close(delete $r->{sock}), 'evilly close connection to the server'); 56 | ok($r->set(foo => 'bar'), 'send command with reconnect'); 57 | is($processed_pending, 0, 'pending command discarded on reconnect'); 58 | 59 | }; 60 | 61 | subtest 'Conservative Reconnection dies on pending commands' => sub { 62 | ok(my $r = Redis->new(reconnect => 2, 63 | conservative_reconnect => 1, 64 | server => $srv, 65 | ssl => $use_ssl, 66 | SSL_verify_mode => 0), 67 | 'connected to our test redis-server'); 68 | 69 | my $processed_pending = 0; 70 | $r->dbsize(sub { $processed_pending++ }); 71 | 72 | ok(close(delete $r->{sock}), 'evilly close connection to the server'); 73 | like(exception { $r->set(foo => 'bar') }, 74 | qr{while responses are pending and conservative reconnect mode enabled}, 75 | 'send command with reconnect and conservative_reconnect should raise an exception'); 76 | 77 | is($processed_pending, 0, 'pending command never arrived'); 78 | 79 | }; 80 | 81 | 82 | subtest 'INFO commands with extra logic triggers reconnect' => sub { 83 | ok(my $r = Redis->new(reconnect => 2, 84 | server => $srv, 85 | ssl => $use_ssl, 86 | SSL_verify_mode => 0), 'connected to our test redis-server'); 87 | 88 | ok($r->quit, 'close connection to the server'); 89 | 90 | my $info = $r->info; 91 | is(ref $info, 'HASH', 'reconnect on INFO command'); 92 | }; 93 | 94 | 95 | subtest 'KEYS commands with extra logic triggers reconnect' => sub { 96 | ok(my $r = Redis->new(reconnect => 2, 97 | server => $srv, 98 | ssl => $use_ssl, 99 | SSL_verify_mode => 0), 'connected to our test redis-server'); 100 | 101 | ok($r->flushdb, 'delete all keys'); 102 | ok($r->set(reconnect => $$), 'set known key'); 103 | 104 | ok($r->quit, 'close connection to the server'); 105 | 106 | my @keys = $r->keys('*'); 107 | is_deeply(\@keys, ['reconnect'], 'reconnect on KEYS command'); 108 | }; 109 | 110 | 111 | subtest "Bad commands don't trigger reconnect" => sub { 112 | ok(my $r = Redis->new(reconnect => 2, 113 | server => $srv, 114 | ssl => $use_ssl, 115 | SSL_verify_mode => 0), 'connected to our test redis-server'); 116 | 117 | my $prev_sock = "$r->{sock}"; 118 | like( 119 | exception { $r->set(bad => reconnect => 1) }, 120 | qr{ERR wrong number of arguments for 'set' command|ERR syntax error}, 121 | 'Bad commands still die', 122 | ); 123 | is("$r->{sock}", $prev_sock, "... and don't trigger a reconnect"); 124 | }; 125 | 126 | 127 | subtest 'Reconnect code clears sockect ASAP' => sub { 128 | ok(my $r = Redis->new(reconnect => 3, 129 | server => $srv, 130 | ssl => $use_ssl, 131 | SSL_verify_mode => 0), 'connected to our test redis-server'); 132 | _wait_for_redis_timeout(); 133 | is(exception { $r->quit }, undef, "Quit doesn't die if we are already disconnected"); 134 | }; 135 | 136 | 137 | subtest "Reconnect gives up after timeout" => sub { 138 | ok(my $r = Redis->new(reconnect => 3, 139 | server => $srv, 140 | ssl => $use_ssl, 141 | SSL_verify_mode => 0), 'connected to our test redis-server'); 142 | $c->() if $c; ## Make sure the server is dead 143 | $t->() if $t; ## Make sure the tunnel is down 144 | 145 | my $t0 = [gettimeofday]; 146 | like( 147 | exception { $r->set(reconnect => 1) }, 148 | qr{Could not connect to Redis server at}, 149 | 'Eventually it gives up and dies', 150 | ); 151 | ok(tv_interval($t0) > 3, '... minimum value for the reconnect reached'); 152 | }; 153 | 154 | subtest "Reconnect during transaction" => sub { 155 | $c->() if $c; ## Make sure previous server is dead 156 | $t->() if $t; ## Make sure previous tunnel is down 157 | 158 | my $port = empty_port(); 159 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); 160 | ok(my $r = Redis->new(reconnect => 3, 161 | server => $srv, 162 | ssl => $use_ssl, 163 | SSL_verify_mode => 0), 'connected to our test redis-server'); 164 | 165 | ok($r->multi(), 'start transacion'); 166 | ok($r->set('reconnect_1' => 1), 'set first key'); 167 | 168 | $c->() if $c; 169 | $t->() if $t; 170 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); 171 | 172 | like(exception { $r->set('reconnect_2' => 2) }, qr{reconnect disabled inside transaction}, 'set second key'); 173 | 174 | $r->connect(); #reconnect 175 | is($r->exists('reconnect_1'), 0, 'key "reconnect_1" should not exist'); 176 | is($r->exists('reconnect_2'), 0, 'key "reconnect_2" should not exist'); 177 | }; 178 | 179 | subtest "Reconnect works after WATCH + MULTI + EXEC" => sub { 180 | $c->() if $c; ## Make sure previous server is dead 181 | $t->() if $t; ## Make sure previous tunnel is down 182 | 183 | my $port = empty_port(); 184 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); 185 | ok(my $r = Redis->new(reconnect => 3, 186 | server => $srv, 187 | ssl => $use_ssl, 188 | SSL_verify_mode => 0), 'connected to our test redis-server'); 189 | 190 | ok($r->set('watch' => 'watch'), 'set watch key'); 191 | ok($r->watch('watch'), 'start watching key'); 192 | ok($r->multi(), 'start transacion'); 193 | ok($r->set('reconnect' => 1), 'set key'); 194 | ok($r->exec(), 'execute transaction'); 195 | 196 | $c->() if $c; 197 | $t->() if $t; 198 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); 199 | 200 | ok($r->set('reconnect' => 1), 'setting key should not fail'); 201 | }; 202 | 203 | subtest "Reconnect works after WATCH + MULTI + DISCARD" => sub { 204 | $c->() if $c; ## Make sure previous server is dead 205 | $t->() if $t; ## Make sure previous tunnel is down 206 | 207 | my $port = empty_port(); 208 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); 209 | ok(my $r = Redis->new(reconnect => 3, 210 | server => $srv, 211 | ssl => $use_ssl, 212 | SSL_verify_mode => 0), 'connected to our test redis-server'); 213 | 214 | ok($r->set('watch' => 'watch'), 'set watch key'); 215 | ok($r->watch('watch'), 'start watching key'); 216 | ok($r->multi(), 'start transacion'); 217 | ok($r->set('reconnect' => 1), 'set key'); 218 | ok($r->discard(), 'dscard transaction'); 219 | 220 | $c->() if $c; 221 | $t->() if $t; 222 | ok(($c, $t, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); 223 | 224 | ok($r->set('reconnect' => 1), 'setting second key should not fail'); 225 | }; 226 | 227 | my ($c2, $t2, $srv2) = redis(); 228 | END { 229 | $c2->() if $c2; 230 | $t2->() if $t2; 231 | } 232 | 233 | subtest 'Reconnection by read timeout discards pending commands' => sub { 234 | ok(my $r = Redis->new(server => $srv2, 235 | read_timeout => 1, 236 | reconnect => 1, 237 | ssl => $use_ssl, 238 | SSL_verify_mode => 0), 'connected to our test redis-server'); 239 | 240 | ok($r->set(foo => 'bar'), 'set foo bar'); 241 | 242 | eval { $r->debug(sleep => 4) }; 243 | ok $@, 'sleep command is timeout'; 244 | 245 | diag 'waiting for sleep command'; 246 | sleep 4; 247 | is($r->get('foo'), 'bar', 'the value of key foo is bar'); 248 | }; 249 | 250 | done_testing(); 251 | 252 | 253 | sub _wait_for_redis_timeout { 254 | ## Redis will timeout clients after 100 internal server loops, at 255 | ## least 10 seconds (even with a timeout 1 on the config) so we sleep 256 | ## a bit more hoping the timeout did happen. Not perfect, patches 257 | ## welcome 258 | diag('Sleeping 11 seconds, waiting for Redis to timeout...'); 259 | sleep(11); 260 | } 261 | -------------------------------------------------------------------------------- /t/08-unix-socket.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | my ($c, undef, undef, undef, undef, undef, undef, undef, $sock_temp_file) = redis(); 12 | END { $c->() if $c } 13 | 14 | my $conn = sub { 15 | my @args = @_; 16 | 17 | my $r; 18 | is( 19 | exception { 20 | $r = Redis->new(sock => $sock_temp_file, @args); 21 | }, 22 | undef, 23 | 'Connected to the Redis server ok', 24 | ); 25 | 26 | return $r; 27 | }; 28 | 29 | 30 | subtest 'basic tests' => sub { 31 | my $r = $conn->(); 32 | 33 | ok($r->set(xpto => '42'), '... set command via UNIX ok'); 34 | is($r->get('xpto'), '42', '... and get command ok too'); 35 | 36 | is(exception { $r->quit }, undef, 'Connection closed ok'); 37 | like(exception { $r->get('xpto') }, qr!Not connected to any server!, 'Command failed ok, no reconnect',); 38 | }; 39 | 40 | 41 | subtest 'reconnect over UNIX daemon' => sub { 42 | my $r = $conn->(reconnect => 2); 43 | ok($r->quit, '... and connection closed ok'); 44 | 45 | is(exception { $r->set(xpto => '43') }, undef, 'set command via UNIX ok, reconnected fine'); 46 | is($r->get('xpto'), '43', '... and get command ok too'); 47 | }; 48 | 49 | 50 | done_testing(); 51 | -------------------------------------------------------------------------------- /t/09-env-redis-server.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv, undef, undef, undef, undef, undef, $sock_temp_file) = redis(); 14 | 15 | END { 16 | $c->() if $c; 17 | $t->() if $t; 18 | } 19 | 20 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 21 | 22 | subtest 'REDIS_SERVER TCP' => sub { 23 | my $n = time(); 24 | my $r = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 25 | $r->set($$ => $n); 26 | 27 | local $ENV{REDIS_SERVER} = $srv; 28 | is(exception { $r = Redis->new(ssl => $use_ssl, SSL_verify_mode => 0) }, 29 | undef, "Direct IP/Port address on REDIS_SERVER works ($srv)",); 30 | is($r->get($$), $n, '... connected to the expected server'); 31 | 32 | $ENV{REDIS_SERVER} = "tcp:$srv"; 33 | is(exception { $r = Redis->new(ssl => $use_ssl, SSL_verify_mode => 0) }, 34 | undef, 'Direct IP/Port address (with tcp prefix) on REDIS_SERVER works',); 35 | is($r->get($$), $n, '... connected to the expected server'); 36 | }; 37 | 38 | subtest 'REDIS_SERVER TCP with undef sock' => sub { 39 | my $n = time(); 40 | my $r = Redis->new(server => $srv, sock => undef); 41 | $r->set($$ => $n); 42 | 43 | local $ENV{REDIS_SERVER} = $srv; 44 | is(exception { $r = Redis->new }, undef, "Direct IP/Port address on REDIS_SERVER works ($srv)",); 45 | is($r->get($$), $n, '... connected to the expected server'); 46 | 47 | $ENV{REDIS_SERVER} = "tcp:$srv"; 48 | is(exception { $r = Redis->new }, undef, 'Direct IP/Port address (with tcp prefix) on REDIS_SERVER works',); 49 | is($r->get($$), $n, '... connected to the expected server'); 50 | }; 51 | 52 | 53 | subtest 'REDIS_SERVER UNIX' => sub { 54 | my $srv = $ENV{TEST_REDIS_SERVER_SOCK_PATH}; 55 | plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' 56 | unless $srv; 57 | 58 | my $n = time(); 59 | my $r = Redis->new(sock => $srv); 60 | $r->set($$ => $n); 61 | 62 | local $ENV{REDIS_SERVER} = $srv; 63 | is(exception { $r = Redis->new }, undef, 'UNIX path on REDIS_SERVER works',); 64 | is($r->get($$), $n, '... connected to the expected server'); 65 | 66 | $ENV{REDIS_SERVER} = "unix:$srv"; 67 | is(exception { $r = Redis->new }, undef, 'UNIX path (with unix prefix) on REDIS_SERVER works',); 68 | is($r->get($$), $n, '... connected to the expected server'); 69 | }; 70 | 71 | 72 | done_testing(); 73 | -------------------------------------------------------------------------------- /t/10-tie-list.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Redis::List; 7 | use lib 't/tlib'; 8 | use Test::SpawnRedisServer; 9 | 10 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 11 | 12 | my ($c, $t, $srv) = redis(); 13 | END { 14 | $c->() if $c; 15 | $t->() if $t; 16 | } 17 | 18 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 19 | 20 | ## Setup 21 | my @my_list; 22 | ok(my $redis = tie(@my_list, 'Redis::List', 'my_list', 23 | server => $srv, 24 | ssl => $use_ssl, 25 | SSL_verify_mode => 0), 'tied to our test redis-server'); 26 | ok($redis->ping, 'pinged fine'); 27 | isa_ok($redis, 'Redis::List'); 28 | 29 | 30 | ## Direct access 31 | subtest 'direct access' => sub { 32 | @my_list = (); 33 | is_deeply(\@my_list, [], 'empty list ok'); 34 | 35 | @my_list = ('foo', 'bar', 'baz'); 36 | is_deeply(\@my_list, ['foo', 'bar', 'baz'], 'Set multiple values ok'); 37 | 38 | $my_list[1] = 'BAR'; 39 | is_deeply(\@my_list, ['foo', 'BAR', 'baz'], 'Set single value ok'); 40 | 41 | is($my_list[2]++, 'baz', 'get single value ok'); 42 | is(++$my_list[2], 'bbb', '... even with post/pre-increments'); 43 | }; 44 | 45 | 46 | ## List functions 47 | subtest 'list functions' => sub { 48 | my $v; 49 | 50 | ok($v = shift(@my_list), 'shift ok'); 51 | is($v, 'foo', '... expected value'); 52 | is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); 53 | 54 | ok(push(@my_list, $v), 'push ok'); 55 | is_deeply(\@my_list, ['BAR', 'bbb', 'foo'], '... resulting list as expected'); 56 | 57 | ok($v = pop(@my_list), 'pop ok'); 58 | is($v, 'foo', '... expected value'); 59 | is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); 60 | 61 | ok(unshift(@my_list, $v), 'unshift ok'); 62 | is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... resulting list as expected'); 63 | 64 | ok(my @s = splice(@my_list, 1, 2), 'splice ok'); 65 | is_deeply([@s], ['BAR', 'bbb'], '... resulting list as expected'); 66 | is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... original list as expected'); 67 | }; 68 | 69 | 70 | ## Cleanup 71 | @my_list = (); 72 | is_deeply(\@my_list, [], 'empty list ok'); 73 | 74 | done_testing(); 75 | -------------------------------------------------------------------------------- /t/11-timeout.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | use Test::SpawnRedisTimeoutServer; 11 | use Errno qw(ETIMEDOUT EWOULDBLOCK); 12 | use POSIX qw(strerror); 13 | use Carp; 14 | use IO::Socket::INET; 15 | use Test::TCP; 16 | 17 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 18 | 19 | subtest 'server replies quickly enough' => sub { 20 | my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(0); 21 | my $redis = Redis->new(server => '127.0.0.1:' . $server->port, 22 | read_timeout => 1, 23 | ssl => SSL_AVAILABLE, 24 | SSL_verify_mode => 0); 25 | ok($redis); 26 | my $res = $redis->get('foo');; 27 | is $res, 42, "the code didn't died, as expected"; 28 | }; 29 | 30 | subtest "server doesn't replies quickly enough" => sub { 31 | my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(10); 32 | my $redis = Redis->new(server => '127.0.0.1:' . $server->port, 33 | read_timeout => 1, 34 | ssl => SSL_AVAILABLE, 35 | SSL_verify_mode => 0); 36 | ok($redis); 37 | like( 38 | exception { $redis->get('foo'); }, 39 | qr/Error while reading from Redis server:/, 40 | "the code died as expected", 41 | ); 42 | }; 43 | 44 | subtest "server doesn't respond at connection (cnx_timeout)" => sub { 45 | SKIP: { 46 | skip "This subtest is failing on some platforms", 4; 47 | my $server = Test::TCP->new(code => sub { 48 | my $port = shift; 49 | 50 | my %args = ( 51 | Listen => 1, 52 | LocalPort => $port, 53 | LocalAddr => '127.0.0.1', 54 | ); 55 | 56 | my $socket_class = 'IO::Socket::INET'; 57 | 58 | if ( SSL_AVAILABLE ) { 59 | $socket_class = 'IO::Socket::SSL'; 60 | 61 | $args{SSL_cert_file} = 't/stunnel/cert.pem'; 62 | $args{SSL_key_file} = 't/stunnel/key.pem'; 63 | } 64 | 65 | my $sock = $socket_class->new(%args) or croak "fail to listen on port $port"; 66 | while(1) { 67 | sleep(1); 68 | }; 69 | }); 70 | 71 | my $redis; 72 | my $start_time = time; 73 | isnt( 74 | exception { $redis = Redis->new(server => '127.0.0.1:' . $server->port, 75 | cnx_timeout => 1, 76 | ssl => SSL_AVAILABLE, SSL_verify_mode => 0); }, 77 | undef, 78 | "the code died", 79 | ); 80 | ok(time - $start_time >= 1, "gave up late enough"); 81 | ok(time - $start_time < 5, "gave up soon enough"); 82 | ok(!$redis, 'redis was not set'); 83 | } 84 | }; 85 | 86 | done_testing; 87 | 88 | -------------------------------------------------------------------------------- /t/12-scan-callback.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | my $o; 22 | is( 23 | exception { $o = Redis->new(server => $srv, 24 | name => 'my_name_is_glorious', 25 | ssl => $use_ssl, 26 | SSL_verify_mode => 0) }, 27 | undef, 'connected to our test redis-server', 28 | ); 29 | 30 | my %vals = ( 31 | foo => 1, 32 | bar => 2, 33 | baz => 3, 34 | quux => 4, 35 | ); 36 | 37 | $o->set($_, $vals{$_}) for keys %vals; 38 | 39 | subtest 'shotgun scan' => sub { 40 | my @trace; 41 | $o->scan_callback(sub { push @trace, $_[0] }); 42 | 43 | is_deeply( [sort @trace], [sort keys %vals], 'all keys scanned once' ); 44 | }; 45 | 46 | subtest 'scan with pattern' => sub { 47 | my @trace; 48 | $o->scan_callback('ba*', sub { push @trace, $_[0] }); 49 | 50 | is_deeply( [sort @trace], [sort qw[bar baz]], 'only selected keys scanned once' ); 51 | }; 52 | 53 | $o->hset( "hash", "foo", 42 ); 54 | $o->hset( "hash", "bar", 137 ); 55 | 56 | subtest 'shotgun hscan' => sub { 57 | my %copy; 58 | 59 | $o->hscan_callback( "hash", sub { 60 | my ($key, $value) = @_; 61 | $copy{$key} += $value; 62 | }); 63 | 64 | is_deeply \%copy, { foo => 42, bar => 137 }, 'each key processed exactly once'; 65 | }; 66 | 67 | subtest 'hscan with pattern' => sub { 68 | my %copy; 69 | 70 | $o->hscan_callback( "hash", "ba*", sub { 71 | my ($key, $value) = @_; 72 | $copy{$key} += $value; 73 | }); 74 | 75 | is_deeply \%copy, { bar => 137 }, 'only matching keys processed exactly once'; 76 | }; 77 | 78 | 79 | subtest 'sscan (iteration over set)' => sub { 80 | my @keys = qw( foo bar quux x:1 x:2 x:3 ); 81 | my %set = map { $_ => 1 } @keys; 82 | my %restricted = map { $_ => 1 } grep { /^x:/ } @keys; 83 | 84 | $o->sadd( "zfc", @keys ); 85 | 86 | { 87 | my %copy; 88 | $o->sscan_callback( "zfc", sub { 89 | my $entry = shift; 90 | $copy{$entry}++; 91 | }); 92 | is_deeply \%copy, \%set, 'all values in set listed exactly once'; 93 | }; 94 | 95 | { 96 | my %copy; 97 | $o->sscan_callback( "zfc", "x:*", sub { 98 | my $entry = shift; 99 | $copy{$entry}++; 100 | }); 101 | is_deeply \%copy, \%restricted, 'only matching values in set listed exactly once'; 102 | }; 103 | }; 104 | 105 | done_testing; 106 | -------------------------------------------------------------------------------- /t/20-tie-hash.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Deep; 7 | use Redis::Hash; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | ## Setup 22 | my %my_hash; 23 | ok(my $redis = tie(%my_hash, 'Redis::Hash', 'my_hash', 24 | server => $srv, 25 | ssl => $use_ssl, 26 | SSL_verify_mode => 0), 'tied to our test redis-server'); 27 | ok($redis->ping, 'pinged fine'); 28 | isa_ok($redis, 'Redis::Hash'); 29 | 30 | 31 | ## Direct access 32 | subtest 'direct access' => sub { 33 | %my_hash = (); 34 | cmp_deeply(\%my_hash, {}, 'empty list ok'); 35 | 36 | %my_hash = (a => 'foo', b => 'bar', c => 'baz'); 37 | cmp_deeply(\%my_hash, { a => 'foo', b => 'bar', c => 'baz' }, 'Set multiple values ok'); 38 | 39 | $my_hash{b} = 'BAR'; 40 | cmp_deeply(\%my_hash, { a => 'foo', b => 'BAR', c => 'baz' }, 'Set single value ok'); 41 | 42 | is($my_hash{c}++, 'baz', 'get single value ok'); 43 | is(++$my_hash{c}, 'bbb', '... even with post/pre-increments'); 44 | }; 45 | 46 | 47 | ## Hash functions 48 | subtest 'hash functions' => sub { 49 | ok(my @keys = keys(%my_hash), 'keys ok'); 50 | cmp_deeply(\@keys, bag(qw( a b c )), '... resulting list as expected'); 51 | 52 | ok(my @values = values(%my_hash), 'values ok'); 53 | cmp_deeply(\@values, bag(qw( foo BAR bbb )), '... resulting list as expected'); 54 | 55 | %my_hash = reverse %my_hash; 56 | cmp_deeply(\%my_hash, { foo => 'a', BAR => 'b', bbb => 'c' }, 'reverse() worked'); 57 | }; 58 | 59 | 60 | ## Cleanup 61 | %my_hash = (); 62 | cmp_deeply(\%my_hash, {}, 'empty list ok'); 63 | 64 | done_testing(); 65 | -------------------------------------------------------------------------------- /t/30-scripts.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Redis; 7 | use lib 't/tlib'; 8 | use Test::SpawnRedisServer; 9 | use Digest::SHA qw(sha1_hex); 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | my $o = Redis->new(server => $srv, ssl => $use_ssl, SSL_verify_mode => 0); 22 | 23 | ## Make sure SCRIPT commands are available 24 | eval { $o->script_flush }; 25 | if ($@ && $@ =~ /ERR unknown command 'SCRIPT',/) { 26 | $c->(); 27 | $t->(); 28 | plan skip_all => 'This redis-server lacks scripting support'; 29 | } 30 | 31 | 32 | ## Commands related to Lua scripting 33 | 34 | # Specifically, these commands test multi-word commands 35 | ok($o->set(foo => 'bar'), 'set foo => bar'); 36 | 37 | my $script = "return 1"; 38 | my $script_sha = sha1_hex($script); 39 | my @ret = $o->script_exists($script_sha); 40 | ok(@ret && $ret[0] == 0, "script exists returns false"); 41 | @ret = $o->script_load($script); 42 | ok(@ret && $ret[0] eq $script_sha, "script load returns the sha1 of the script"); 43 | ok($o->script_exists($script_sha), "script exists returns true after loading"); 44 | ok($o->evalsha($script_sha, 0), "evalsha returns true with the sha1 of the script"); 45 | ok($o->eval($script, 0), "eval returns true"); 46 | 47 | ## All done 48 | done_testing(); 49 | -------------------------------------------------------------------------------- /t/42-client_cmds.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Redis; 7 | use lib 't/tlib'; 8 | use Test::SpawnRedisServer; 9 | 10 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 11 | 12 | my ($c, $t, $srv) = redis(requires_version => '2.6.9'); 13 | END { 14 | $c->() if $c; 15 | $t->() if $t; 16 | } 17 | 18 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 19 | 20 | subtest 'client_{set|get}name commands' => sub { 21 | ok(my $r = Redis->new(server => $srv, 22 | ssl => $use_ssl, 23 | SSL_verify_mode => 0), 'connected to our test redis-server'); 24 | 25 | my @clients = $r->client_list; 26 | is(@clients, 1, 'one client listed'); 27 | like($clients[0], qr/\s+name=\s+/, '... no name set yet'); 28 | 29 | is($r->client_setname('my_preccccious'), 'OK', "client_setname() is supported, no errors"); 30 | is($r->client_getname, 'my_preccccious', '... client_getname() returns new connection name'); 31 | 32 | @clients = $r->client_list; 33 | like($clients[0], qr/\s+name=my_preccccious\s+/, '... no name set yet'); 34 | }; 35 | 36 | 37 | subtest 'client name via constructor' => sub { 38 | ok(my $r = Redis->new(server => $srv, 39 | name => 'buuu', 40 | ssl => $use_ssl, 41 | SSL_verify_mode => 0), 'connected to our test redis-server, with a name'); 42 | is($r->client_getname, 'buuu', '...... name was properly set'); 43 | 44 | ok($r = Redis->new(server => $srv, 45 | name => sub {"cache-for-$$"}, 46 | ssl => $use_ssl, 47 | SSL_verify_mode => 0), '... with a dynamic name'); 48 | is($r->client_getname, "cache-for-$$", '...... name was properly set'); 49 | 50 | ok($r = Redis->new(server => $srv, 51 | name => sub {undef}, 52 | ssl => $use_ssl, 53 | SSL_verify_mode => 0), '... with a dynamic name, but returning undef'); 54 | is($r->client_getname, undef, '...... name was not set'); 55 | 56 | my $generation = 0; 57 | for (1 .. 3) { 58 | ok($r = Redis->new(server => $srv, 59 | name => sub { "gen-$$-" . ++$generation }, 60 | ssl => $use_ssl, SSL_verify_mode => 0), 61 | "Using dynamic name, for generation $generation"); 62 | my $n = "gen-$$-$generation"; 63 | is($r->client_getname, $n, "... name was set properly, '$n'"); 64 | } 65 | }; 66 | 67 | 68 | done_testing(); 69 | -------------------------------------------------------------------------------- /t/44-no-unicode-bug.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Redis; 8 | use lib 't/tlib'; 9 | use Test::SpawnRedisServer; 10 | 11 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 12 | 13 | my ($c, $t, $srv) = redis(); 14 | END { 15 | $c->() if $c; 16 | $t->() if $t; 17 | } 18 | 19 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 20 | 21 | ok(my $r = Redis->new(server => $srv, 22 | ssl => $use_ssl, 23 | SSL_verify_mode => 0), 'connected to our test redis-server'); 24 | my $s2 = my $s1 = "test\x{80}"; 25 | utf8::upgrade($s1); # no need to use 'use utf8' to call this 26 | utf8::downgrade($s2); # no need to use 'use utf8' to call this 27 | ok ($s1 eq $s2, 'assume test string are considered identical by perl'); 28 | $r->set($s1 => 42); 29 | is $r->get($s2), 42, "same binary strings should point to same keys"; 30 | 31 | ## All done 32 | done_testing(); 33 | -------------------------------------------------------------------------------- /t/50-fork_safe.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Redis; 5 | use lib 't/tlib'; 6 | use Test::SpawnRedisServer; 7 | use Test::SharedFork; 8 | 9 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 10 | 11 | my ($c, $t, $srv) = redis(); 12 | END { 13 | $c->() if $c; 14 | $t->() if $t; 15 | } 16 | 17 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 18 | 19 | my $o = Redis->new(server => $srv, 20 | name => 'my_name_is_glorious', 21 | ssl => $use_ssl, 22 | SSL_verify_mode => 0); 23 | is $o->info->{connected_clients}, 1; 24 | my $localport = $o->{sock}->sockport; 25 | 26 | note "fork safe"; { 27 | if (my $pid = fork) { 28 | $o->incr("test-fork"); 29 | is $o->{sock}->sockport, $localport, "same port on parent"; 30 | waitpid($pid, 0); 31 | } 32 | else { 33 | $o->incr("test-fork"); 34 | isnt $o->{sock}->sockport, $localport, "different port on child"; 35 | is $o->info->{connected_clients}, 2, "2 clients connected"; 36 | exit 0; 37 | } 38 | 39 | is $o->get('test-fork'), 2; 40 | }; 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/60-sentinel.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | use Test::More; 6 | use Test::Fatal; 7 | use Test::Deep; 8 | use Redis; 9 | use Redis::Sentinel; 10 | use lib 't/tlib'; 11 | use Test::SpawnRedisServer; 12 | 13 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL } || 0; 14 | 15 | # Sentinel mode does not support SSL/TLS yet. 16 | my @ret = redis(no_ssl => 1); 17 | my $redis_port = pop @ret; 18 | my ($c, $t, $redis_addr) = @ret; 19 | END { 20 | diag 'shutting down redis'; 21 | $c->() if $c; 22 | $t->() if $t; 23 | } 24 | 25 | my $use_ssl = $t ? SSL_AVAILABLE : 0; 26 | 27 | diag "redis address : $redis_addr\n"; 28 | 29 | my @ret2 = sentinel( redis_port => $redis_port ); 30 | my $sentinel_port = pop @ret2; 31 | my ($c2, $sentinel_addr) = @ret2; 32 | END { diag 'shutting down sentinel'; $c2->() if $c2 } 33 | 34 | my @ret3 = sentinel( redis_port => $redis_port ); 35 | my $sentinel2_port = pop @ret3; 36 | my ($c3, $sentinel2_addr) = @ret3; 37 | END { diag 'shutting down sentinel2'; $c3->() if $c3 } 38 | 39 | diag "sentinel address: $sentinel_addr\n"; 40 | diag "sentinel2 address: $sentinel2_addr\n"; 41 | 42 | diag("wait 3 sec for the sentinels and the master to gossip"); 43 | sleep 3; 44 | 45 | { 46 | # check basic sentinel command 47 | my $sentinel = Redis::Sentinel->new(server => $sentinel_addr); 48 | my $got = ($sentinel->get_masters())[0]; 49 | 50 | cmp_deeply($got, superhashof({ name => 'mymaster', 51 | ip => '127.0.0.1', 52 | port => $redis_port, 53 | flags => 'master', 54 | 'role-reported' => 'master', 55 | 'config-epoch' => 0, 56 | 'num-slaves' => 0, 57 | 'num-other-sentinels' => 1, 58 | quorum => 2, 59 | }), 60 | "sentinel has proper config of its master" 61 | ); 62 | } 63 | 64 | { 65 | my $sentinel = Redis::Sentinel->new(server => $sentinel_addr); 66 | my $address = $sentinel->get_service_address('mymaster'); 67 | is $address, "127.0.0.1:$redis_port", "found service mymaster"; 68 | } 69 | 70 | { 71 | my $sentinel = Redis::Sentinel->new(server => $sentinel_addr); 72 | my $address = $sentinel->get_service_address('mywrongmaster'); 73 | is $address, undef, "didn't found service mywrongmaster"; 74 | } 75 | 76 | { 77 | # connect to the master via the sentinel 78 | my $redis = Redis->new(sentinels => [ $sentinel_addr ], service => 'mymaster'); 79 | is_deeply({ map { $_ => 1 } @{$redis->{sentinels} || []} }, 80 | { $sentinel_addr => 1, $sentinel2_addr => 1}, 81 | "Redis client has connected and updated its sentinels"); 82 | 83 | } 84 | 85 | done_testing(); 86 | -------------------------------------------------------------------------------- /t/stunnel/cert.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIFWTCCA0GgAwIBAgIJAJmwzHYpCw2LMA0GCSqGSIb3DQEBCwUAMEIxCzAJBgNV 3 | BAYTAlhYMRUwEwYDVQQHDAxEZWZhdWx0IENpdHkxHDAaBgNVBAoME0RlZmF1bHQg 4 | Q29tcGFueSBMdGQwIBcNMTgwNTIzMDg1NjQ3WhgPMjExODA0MjkwODU2NDdaMEIx 5 | CzAJBgNVBAYTAlhYMRUwEwYDVQQHDAxEZWZhdWx0IENpdHkxHDAaBgNVBAoME0Rl 6 | ZmF1bHQgQ29tcGFueSBMdGQwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoIC 7 | AQDF+A5aMg5G2e/QdIify9P/p6ypUd8wuwdE/AFwVtis/GZaxidIf+s9uu5SogS6 8 | Qkka8fptdSRPark0vgg+ov7sJNzCCKvaUo+CkFlx+sljl5lAikpmrW67YyQDTcH7 9 | kcrKVIfSxMHRXEZMfCjB/GTeYgVtJwNDOAqCAssiI4WLlpGD490r/sZYhOe26DET 10 | GbjbS9VPYG4eR2h4UFiXhAn9g04MKVFJI+R+suKcAqngJviGLUsGBBvUjsHbFzkt 11 | IyndEH5H1WZ/twE27iDjlaaJL3onFxw1US0OKTAVxsS99gISV1Lv3+Md0lsvdiDi 12 | QeyApePjnCOdzWAgZWBL2D4LoECjoO8Put7udB2Es1/r3vzl3u3l9jTece+sU+cE 13 | N6nYSaVDr2Ftp7jnHUE+J8CQEifFBgQBPKMbNh2nb2tlZb4A5QiPh//AZe3NkbQV 14 | wNIETw1JS0mxh7leKZJqQlhTQnxVJpdEVHBz5k1/R3iU5H5jGwAsO2EudH/5/p2F 15 | 5xInTqbrEJV0lWlMEPEZ7mX3VAgmI0oKOEC2he2opdVIK9S0USySWiFR2C4CQMxb 16 | 0ID9Ou8xXJTUZLW3KFcXOnBtc09PDo/t4QKK47fkrfYGQmefc9pklD5uLorBeKvt 17 | Faq8MUWCGVGy7DpCOZtQgTxn/leMHH32MC6Yno6V317c1wIDAQABo1AwTjAdBgNV 18 | HQ4EFgQU3csnTCuLU1pv61r/aYOnfF4kKEgwHwYDVR0jBBgwFoAU3csnTCuLU1pv 19 | 61r/aYOnfF4kKEgwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAgEAQnI1 20 | Li1F+rN+0UHTB2Bif+iOX6nXWRZDe5ULOkHGyxlFFdQJp2Kd+O9AK6dqyb6v1pLJ 21 | x3RbHx0VhtCVC4Ebwe4AtPyzr25Chlhzel6gOVeul1V0GkGQoew55sfJyWJWJz6j 22 | lwOxws6EePBVGUIs7wpDeoyGJu+aJ6sbQ3IYwRR6EF+12v6/DvUcECAechdY6uNY 23 | yswMs7nrShv2WM8Wcp1PSvdSAEjqSZYkSOAe+NSLw1bx4roHWFiE9StGaHxeI1O9 24 | p4KZ/ljUsX+xo3w4xWZX5vAqlBBqPo4kUdZhwlW2wyG1yLDi4A8zgFOs6hqQ59XQ 25 | 2UIwrqdiWzur9jsLUiZbXkPwiqF7mc1+U1GV/oU7/ahsfLNc3siE6Gt/1c6PJzuH 26 | 0KM2xfMS+4IXTXQrwIZNB3fVUdpttpPHRLaK2XkZcxxT7yR9nldIvaytsUuhz7S4 27 | GlEVqebNxXngocNaMRCkZ2lMcYCbvrqer0KxFFfblR8BJkFvUPBa3vRizsWuD9bp 28 | 8iQdrPx3n1WhTR61octOptc+6+wPTxpitkd40zw0QBtpHh0W3/soTk/5JoLGWBCS 29 | 7Q9lUjyVvswIAefCt/ki9F/a8nb+/v8fx4rfgtaXNNPJiBM4buHkr9vMr6eFvyxb 30 | e/3z0X7Fw6ARAIRp/vnOzGDpRxpyA77+LXwAkqs= 31 | -----END CERTIFICATE----- 32 | -------------------------------------------------------------------------------- /t/stunnel/key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIJJwIBAAKCAgEAxfgOWjIORtnv0HSIn8vT/6esqVHfMLsHRPwBcFbYrPxmWsYn 3 | SH/rPbruUqIEukJJGvH6bXUkT2q5NL4IPqL+7CTcwgir2lKPgpBZcfrJY5eZQIpK 4 | Zq1uu2MkA03B+5HKylSH0sTB0VxGTHwowfxk3mIFbScDQzgKggLLIiOFi5aRg+Pd 5 | K/7GWITntugxExm420vVT2BuHkdoeFBYl4QJ/YNODClRSSPkfrLinAKp4Cb4hi1L 6 | BgQb1I7B2xc5LSMp3RB+R9Vmf7cBNu4g45WmiS96JxccNVEtDikwFcbEvfYCEldS 7 | 79/jHdJbL3Yg4kHsgKXj45wjnc1gIGVgS9g+C6BAo6DvD7re7nQdhLNf69785d7t 8 | 5fY03nHvrFPnBDep2EmlQ69hbae45x1BPifAkBInxQYEATyjGzYdp29rZWW+AOUI 9 | j4f/wGXtzZG0FcDSBE8NSUtJsYe5XimSakJYU0J8VSaXRFRwc+ZNf0d4lOR+YxsA 10 | LDthLnR/+f6dhecSJ06m6xCVdJVpTBDxGe5l91QIJiNKCjhAtoXtqKXVSCvUtFEs 11 | klohUdguAkDMW9CA/TrvMVyU1GS1tyhXFzpwbXNPTw6P7eECiuO35K32BkJnn3Pa 12 | ZJQ+bi6KwXir7RWqvDFFghlRsuw6QjmbUIE8Z/5XjBx99jAumJ6Old9e3NcCAwEA 13 | AQKCAgBxdtzzASGBpkN23HO58p8NNlMVsKEVUvy1oyJH+t6xNvCLMmsteHOhq9QQ 14 | dF/1SSyRTwNTXQJ0qhyAiDI9hDpLqk0EwOeOeCdck9NQKobml+r0PM6rztdae1YW 15 | tqhpwYPTN2Opf6/+iL6Z88eAd2JwuwmVJ/kMu7/6CBPY+zb9bEz2pNEM+DdCYNpV 16 | 0PrfkayLtAkMN56lqBPOcW51WO5I6MsA2WWHYBUEMQ8Ej9pBaNSkQq1vQ0eYKkId 17 | ik/w+OhzlZJrJXpb1M3TZ+RdzFXo5tdCNFKslFwYc67lrEjy/17smDQm29FWNEyj 18 | BTePtm0QxwO4XrNjLGTd7Hymu8fC7ACrer16MkIe8OxsqMckJoPtiR3GaOryHD2D 19 | cqFG84y0zzmsNT1QAQdT4ITyA5nU1AQgR5i2Nsu+cvd1hnjNCEhSJM/d22dYQWEX 20 | cGrJELxaPCkpl40l796WJvQ0dbwKqbrRrS86ZgjxA+s4bQ0TLBXGqBSEXB/BePCF 21 | hUMjL0+zlhG54tWL74FZ5RBs50SkG2c0O9X9fY/tJ0jqifmeZ2/YaP3MQUHh+MUd 22 | BuRbNq8IAnrFuqKihM5xQ3rRXfJzdOnvNd0EbcuJs8wGmzbmttIFraHYMFY01p9j 23 | lP+DeLdO5nliOkxc17jTPoXQcHdgPGSz7QK7S8kOOVPljaGw0QKCAQEA496cSRLG 24 | 35n8ed24WYlcSVY3t3E/PBwnB4zArRPZFwiWIyIVmAqH6A982oB4NZolB9La/N3v 25 | FDls8xtIkr7aD6iSV1JFtzbUdmIIi2aOeEkhWfotRmFWEs83uRFBHG68pMldPVuQ 26 | PZf1SaKiAYy3E/eDAMfgr/NWkrpz8qlGJZUJMg5/nlrOnKDAohrYEZ+kxiJWZ82N 27 | uGfHb8AhQi2eJjU+FPJL77uUOycE08pOQ/436TjNP2S+hGbhcJowp+hGBLGUF1dg 28 | Vam267l+ula8+fqtFiLZNG0FP8RTYmUxIUP96iieckYmiNpJ4lU/XGO0MvAC4Vve 29 | COYtHHjDLdaglQKCAQEA3mh+QyYWx12+vvIo+kYi4Z1wMfXHG+bjjsGFNxoXpLb0 30 | yFIBBYN9K76zQTUG0yQckaNbgBkRhUQej6Drrqd6HPmfQybK2YOVhnF/XGg1G0VT 31 | YXGPFeL2g4J5YtEYgVupahivehvZ5HiDUocmOSqUioa4bJUzGapoXRbldrg6xwtH 32 | 3Uj3UlY+1YMBIc6fztVgCOubZYrmDzFdnEpw5HOGFYBGkAq/5lPju/m3BdA+yjO/ 33 | kgDsP7LS/mJy9o/KZG8JWm7d5x8TMFIch62GI56ebDqJYlBVUDVC17XTidSrIfo3 34 | rNZpy5zN1D16Qq8Zbfad/KHqImALUsbAB7UGVIVQuwKCAQB9ZKLcE1kc8r/c0AYC 35 | P3RpZuiCKe+CRHu1y967X5C2/CKicr8vS5w+N0edddSwqoJ2K7IWNIq7tl4d6YWm 36 | OyAEPd9J7hwvFh0UiB3rmCQOTS/tM552fFnBQAaJ8NTDsKxegfCtMxXMzzJLsxMz 37 | hxu4ARw18cfTCzU4ySHFByFyzPCiexf/LDlGN6/JhLwh9pfV8E9cD+FM+M7mz/N9 38 | V10P6XygSjU/Vxna8z3Uzh8Di4F49aj8mZO9iF/GdxMPUuI08wNrVMnOWfYvAYSb 39 | Rd/4L9nPtJ2SG+wniwHXw5ellqTDllaay7+oz3aY9hBH5xXicfEj0kn82603Xb0K 40 | HHGBAoIBAAUXJyyqRoMxphgAuudfi5TWYacDFReSZUrzKvVj536hoWCkX9mcdNT3 41 | fGrVp95VSUIcFxALgtcmA/0NldddhfH71KVY0fPAiz+UgXHAANcq8wmb68Z4d2Pz 42 | LIwSdRkg2/PNtNZ6pLYR/A97gGh2jQfOpZH2qEDCIblfuMjK1q2PmIl8Dg0YZD/G 43 | y9PWQtodECGkIt5kG3fljVryaTsRWdRMJ1FMra+74859nK7JYWaHYK8azk127lVc 44 | M31pNRyvXetv9ixADdRhTL3ePt+51a5seJCDfjBjx6/gPYM+FtykOXn/PlSmth9R 45 | eObl0xMtPdh2bEF1KU0vt111yztMAdkCggEAYU+g86VRCMMysr21B++CVOwxebe5 46 | FhkNrDXtemFn58ZXqcjHU+MMgqvf6jjWW4n820jiJF1kZTviZdWLtCckjJRAExs2 47 | YIgIIXgTsiSj/FTsGJRE7SYRabLgu++rEIB+/T1x5fihFxL9zfuQazSIkp2TTdD1 48 | nsCvdDsjNIA8a02aNqo8CCOhcZgY4UtjAV7HpTzCnA9UTorRVmEBJeYtYrRHfla8 49 | Gb05bepCQ74H0R5UDZaH9i0H27qqVkBZs0Nca4AbZ/IqGG5oIm/FIW4+owh/noR1 50 | CED3mN9bvEBTZzm4jxVtbFrr9Ffpx3Fvi8/MA77/q3uD5E8DiLajRt0rGQ== 51 | -----END RSA PRIVATE KEY----- 52 | -------------------------------------------------------------------------------- /t/tlib/Test/SpawnRedisServer.pm: -------------------------------------------------------------------------------- 1 | package # Hide from PAUSE 2 | Test::SpawnRedisServer; 3 | 4 | use strict; 5 | use warnings; 6 | use Redis; 7 | use File::Temp; 8 | use IPC::Cmd qw(can_run); 9 | use POSIX ":sys_wait_h"; 10 | use base qw( Exporter ); 11 | 12 | use Net::EmptyPort qw(empty_port); 13 | 14 | use constant SSL_WAIT => 2; # Wait a bit till the mock secure tunnel is up 15 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL }; 16 | 17 | our @EXPORT = qw( redis sentinel ); 18 | our @EXPORT_OK = qw( redis reap ); 19 | 20 | sub redis { 21 | my %params = ( 22 | timeout => 120, 23 | @_, 24 | ); 25 | 26 | my $use_ssl = $ENV{USE_SSL} ? SSL_AVAILABLE : 0; 27 | 28 | # Sentinel mode does not support SSL/TLS yet so we have this 29 | # option to explicitly turn off SSL/TLS in testing. 30 | $use_ssl = 0 if $params{no_ssl}; 31 | 32 | my $port = empty_port(); 33 | 34 | my $local_port = $port; 35 | 36 | my $stunnel_port = empty_port(); 37 | 38 | if ( ! $use_ssl ) { 39 | # Use this specific port in non-TLS mode 40 | $params{port} 41 | and $local_port = $params{port}; 42 | } else { 43 | # Reuse the same port if it is specified 44 | $params{port} 45 | and $stunnel_port = $params{port}; 46 | } 47 | 48 | my $addr = "127.0.0.1:$local_port"; 49 | 50 | unlink("redis-server-$addr.log"); 51 | unlink('dump.rdb'); 52 | 53 | # Spawn the tunnel first so that we know if we can test SSL/TLS setup 54 | my $stunnel_addr = "127.0.0.1:$stunnel_port"; 55 | 56 | my ($ver, $c, $t); 57 | 58 | if ( $use_ssl ) { 59 | Test::More::diag("Spawn stunnel $stunnel_addr:$addr") if $ENV{REDIS_DEBUG}; 60 | 61 | my ($stunnel_fh, $stunnel_fn) = File::Temp::tempfile(); 62 | 63 | $stunnel_fh->print("pid= 64 | debug = 0 65 | foreground = yes 66 | 67 | [redis] 68 | accept = $stunnel_port 69 | connect = $addr 70 | cert = t/stunnel/cert.pem 71 | key = t/stunnel/key.pem 72 | "); 73 | $stunnel_fh->flush; 74 | 75 | my $stunnel_path = $ENV{STUNNEL_PATH} || 'stunnel'; 76 | if (!can_run($stunnel_path)) { 77 | Test::More::diag("Could not find binary stunnel, revert to plain text Redis server"); 78 | 79 | $addr = $stunnel_addr; 80 | $local_port = $stunnel_port; 81 | 82 | $use_ssl = 0; 83 | } 84 | else { 85 | eval { $t = spawn_tunnel($stunnel_path, $stunnel_fn) }; 86 | 87 | if (my $e = $@) { 88 | reap(); 89 | Test::More::diag("Could not start stunnel, revert to plain text Redis server: $@"); 90 | $use_ssl = 0 91 | } 92 | } 93 | 94 | sleep(SSL_WAIT) if $use_ssl; 95 | } 96 | 97 | my ($fh, $fn) = File::Temp::tempfile(); 98 | 99 | my (undef, $sock_temp_file) = File::Temp::tempfile(); 100 | 101 | $fh->print(" 102 | timeout $params{timeout} 103 | appendonly no 104 | daemonize no 105 | port $local_port 106 | bind 127.0.0.1 107 | unixsocket $sock_temp_file 108 | unixsocketperm 700 109 | loglevel debug 110 | logfile FOOredis-server-$addr.log 111 | "); 112 | $fh->flush; 113 | 114 | Test::More::diag("Spawn Redis at $addr, cfg $fn") if $ENV{REDIS_DEBUG}; 115 | 116 | my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server'; 117 | if (!can_run($redis_server_path)) { 118 | Test::More::plan skip_all => "Could not find binary redis-server"; 119 | return; 120 | } 121 | 122 | eval { ($ver, $c) = spawn_server($redis_server_path, $fn, $addr) }; 123 | if (my $e = $@) { 124 | reap(); 125 | Test::More::plan skip_all => "Could not start redis-server: $@"; 126 | return; 127 | } 128 | 129 | if (my $rvs = $params{requires_version}) { 130 | if (!defined $ver) { 131 | $c->(); 132 | Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version"; 133 | return; 134 | } 135 | 136 | my ($v1, $v2, $v3) = split(/[.]/, $ver); 137 | my ($r1, $r2, $r3) = split(/[.]/, $rvs); 138 | if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) { 139 | $c->(); 140 | Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver"; 141 | return; 142 | } 143 | } 144 | 145 | if ( $use_ssl ) { 146 | # Connect to Redis through stunnel 147 | return ($c, $t, $stunnel_addr, $ver, split(/[.]/, $ver), $stunnel_port, $sock_temp_file); 148 | } else { 149 | # Connect to Redis directly 150 | return ($c, undef, $addr, $ver, split(/[.]/, $ver), $local_port, $sock_temp_file); 151 | } 152 | } 153 | 154 | sub sentinel { 155 | my %params = ( 156 | timeout => 120, 157 | @_, 158 | ); 159 | 160 | my ($fh, $fn) = File::Temp::tempfile(); 161 | 162 | my $port = empty_port(); 163 | 164 | my $local_port = $port; 165 | $params{port} 166 | and $local_port = $params{port}; 167 | 168 | my $redis_port = $params{redis_port} 169 | or die "need a redis port"; 170 | 171 | my $addr = "127.0.0.1:$local_port"; 172 | 173 | unlink("redis-sentinel-$addr.log"); 174 | 175 | $fh->print(" 176 | port $local_port 177 | 178 | sentinel monitor mymaster 127.0.0.1 $redis_port 2 179 | sentinel down-after-milliseconds mymaster 2000 180 | sentinel failover-timeout mymaster 4000 181 | 182 | logfile sentinel-$addr.log 183 | 184 | "); 185 | $fh->flush; 186 | 187 | my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server'; 188 | if (!can_run($redis_server_path)) { 189 | Test::More::plan skip_all => "Could not find binary redis-server"; 190 | return; 191 | } 192 | 193 | my ($ver, $c); 194 | eval { ($ver, $c) = spawn_server($redis_server_path, $fn, '--sentinel', $addr) }; 195 | if (my $e = $@) { 196 | reap(); 197 | Test::More::plan skip_all => "Could not start redis-sentinel: $@"; 198 | return; 199 | } 200 | 201 | if (my $rvs = $params{requires_version}) { 202 | if (!defined $ver) { 203 | $c->(); 204 | Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version"; 205 | return; 206 | } 207 | 208 | my ($v1, $v2, $v3) = split(/[.]/, $ver); 209 | my ($r1, $r2, $r3) = split(/[.]/, $rvs); 210 | if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) { 211 | $c->(); 212 | Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver"; 213 | return; 214 | } 215 | } 216 | 217 | return ($c, $addr, $ver, split(/[.]/, $ver), $local_port); 218 | } 219 | 220 | sub spawn_server { 221 | my $addr = pop; 222 | my $pid = fork(); 223 | if ($pid) { ## Parent 224 | require Test::More; 225 | Test::More::diag("Starting server with pid $pid") if $ENV{REDIS_DEBUG}; 226 | 227 | my $redis = Redis->new(server => $addr, reconnect => 5, every => 200); 228 | my $version = $redis->info->{redis_version}; 229 | my $alive = $$; 230 | 231 | my $c = sub { 232 | return unless $alive; 233 | return unless $$ == $alive; ## only our creator can kill us 234 | 235 | Test::More::diag("Killing server at $pid") if $ENV{REDIS_DEBUG}; 236 | kill(15, $pid); 237 | 238 | my $failed = reap($pid); 239 | Test::More::diag("Failed to kill server at $pid") 240 | if $ENV{REDIS_DEBUG} and $failed; 241 | unlink("redis-server-$addr.log"); 242 | unlink("redis-sentinel-$addr.log"); 243 | unlink('dump.rdb'); 244 | $alive = 0; 245 | 246 | return !$failed; 247 | }; 248 | 249 | return $version => $c; 250 | } 251 | elsif (defined $pid) { ## Child 252 | exec(@_); 253 | warn "## In child Failed exec of '@_': $!, "; 254 | exit(1); 255 | } 256 | 257 | die "Could not fork(): $!"; 258 | } 259 | 260 | sub spawn_tunnel { 261 | my ($stunnel, $stunnel_cfg) = @_; 262 | 263 | my $cmd = "$stunnel $stunnel_cfg"; 264 | 265 | my $pid = fork(); 266 | if ($pid) { 267 | require Test::More; 268 | Test::More::diag("Starting stunnel $cmd pid $pid") if $ENV{REDIS_DEBUG}; 269 | 270 | my $alive = $$; 271 | 272 | my $c = sub { 273 | return unless $alive; 274 | return unless $$ == $alive; ## only our creator can kill us 275 | 276 | Test::More::diag("Killing stunnel at $pid") if $ENV{REDIS_DEBUG}; 277 | kill(15, $pid); 278 | 279 | my $failed = reap($pid); 280 | Test::More::diag("Failed to kill stunnel at $pid") 281 | if $ENV{REDIS_DEBUG} and $failed; 282 | $alive = 0; 283 | 284 | return !$failed; 285 | }; 286 | 287 | return $c; 288 | } 289 | elsif (defined $pid) { 290 | exec($cmd); 291 | warn "## In child Failed exec of '$cmd': $!, "; 292 | exit(1); 293 | } 294 | 295 | die "Could not fork() stunnel: $!"; 296 | } 297 | 298 | sub reap { 299 | my ($pid, $limit) = @_; 300 | $pid = -1 unless $pid; 301 | $limit = 3 unless $limit; 302 | 303 | my $try = 0; 304 | local $?; 305 | while ($try++ < $limit) { 306 | my $ok = waitpid($pid, WNOHANG); 307 | $try = 0, last if $ok > 0; 308 | sleep(1); 309 | } 310 | 311 | return $try; 312 | } 313 | 314 | 1; 315 | -------------------------------------------------------------------------------- /t/tlib/Test/SpawnRedisTimeoutServer.pm: -------------------------------------------------------------------------------- 1 | package # Hide from PAUSE 2 | Test::SpawnRedisTimeoutServer; 3 | 4 | use strict; 5 | use warnings; 6 | use Test::TCP; 7 | 8 | use constant SSL_AVAILABLE => eval { require IO::Socket::SSL }; 9 | 10 | sub create_server_with_timeout { 11 | my $timeout = shift; 12 | 13 | Test::TCP->new( 14 | code => sub { 15 | my $port = shift; 16 | 17 | my %args = ( 18 | Listen => 5, 19 | Timeout => 1, 20 | Reuse => 1, 21 | Blocking => 1, 22 | LocalPort => $port, 23 | ); 24 | 25 | my $socket_class = 'IO::Socket::INET'; 26 | 27 | if ( SSL_AVAILABLE ) { 28 | $socket_class = 'IO::Socket::SSL'; 29 | 30 | $args{SSL_cert_file} = 't/stunnel/cert.pem'; 31 | $args{SSL_key_file} = 't/stunnel/key.pem'; 32 | } 33 | 34 | my $socket = $socket_class->new(%args) 35 | or die "failed to connect to RedisTimeoutServer: $!"; 36 | 37 | my $buffer; 38 | while (1) { 39 | my $client = $socket->accept(); 40 | 41 | next unless defined $client; 42 | 43 | if (defined (my $got = <$client>)) { 44 | sleep $timeout; 45 | $client->print("+42\r\n"); 46 | } 47 | } 48 | }, 49 | ); 50 | } 51 | 1; 52 | -------------------------------------------------------------------------------- /tools/benchmarks/read_vs_sysread.pl: -------------------------------------------------------------------------------- 1 | use 5.18.1; 2 | 3 | use Time::HiRes qw(gettimeofday tv_interval); 4 | 5 | my $total_bytes = 5_000_000; 6 | my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); 7 | 8 | foreach my $length (@lengths) { 9 | 10 | my $packet_nb = int($total_bytes / $length); 11 | my %results; 12 | 13 | my $method = "read"; 14 | if (my $pid = open(my $kid, "|-")) { 15 | # parent 16 | my $data = 'x' x $length; 17 | my $i = $packet_nb; 18 | my $t0 = [gettimeofday]; 19 | while ($i--) { 20 | print $kid $data; 21 | } 22 | close($kid) or warn "kid exited with $?"; 23 | my $elapsed = tv_interval ($t0); # equivalent code 24 | say "$method: $packet_nb packets of size $length : $elapsed sec"; 25 | $results{$method}{$length} = $elapsed; 26 | } else { 27 | # child 28 | my $data; 29 | my $i = 0; 30 | while ($i < $packet_nb) { 31 | read STDIN, $data, $length, $i*$length; 32 | $i++; 33 | } 34 | length($data) eq $length * $packet_nb 35 | or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; 36 | exit; # don't forget this 37 | } 38 | 39 | my $method = "sysread"; 40 | if (my $pid = open(my $kid, "|-")) { 41 | # parent 42 | my $data = 'x' x $length; 43 | my $i = $packet_nb; 44 | my $t0 = [gettimeofday]; 45 | while ($i--) { 46 | syswrite $kid, $data, $length; 47 | } 48 | close($kid) or warn "kid exited with $?"; 49 | my $elapsed = tv_interval ($t0); # equivalent code 50 | say "$method: $packet_nb packets of size $length : $elapsed sec"; 51 | $results{$method}{$length} = $elapsed; 52 | } else { 53 | # child 54 | my $data; 55 | my $i = 0; 56 | while ($i < $packet_nb) { 57 | sysread STDIN, $data, $length, $i*$length; 58 | $i++; 59 | } 60 | length($data) eq $length * $packet_nb 61 | or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; 62 | exit; # don't forget this 63 | } 64 | 65 | } 66 | -------------------------------------------------------------------------------- /tools/benchmarks/readline_vs_sysread_vs_recv/client-readline.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Time::HiRes; 6 | use IO::Socket::INET; 7 | 8 | my $exp_cnt = $ARGV[0]; 9 | my $exp_len = $ARGV[1]; 10 | my $start_time = Time::HiRes::time(); 11 | 12 | my $sock = IO::Socket::INET->new( 13 | PeerAddr => 'localhost', 14 | PeerPort => '1234', 15 | Proto => 'tcp', 16 | ); 17 | 18 | die $! unless $sock; 19 | die $! unless print $sock "$exp_cnt,$exp_len\n"; 20 | $exp_len += 1; 21 | 22 | my $cnt = 0; 23 | while (my $line = <$sock>) { 24 | my $len = length($line); 25 | print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; 26 | ++$cnt; 27 | } 28 | 29 | printf "%.5f\n", (Time::HiRes::time() - $start_time); 30 | print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; 31 | -------------------------------------------------------------------------------- /tools/benchmarks/readline_vs_sysread_vs_recv/client-recv.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Time::HiRes; 6 | use IO::Socket::INET; 7 | 8 | my $exp_cnt = $ARGV[0]; 9 | my $exp_len = $ARGV[1]; 10 | my $start_time = Time::HiRes::time(); 11 | 12 | my $sock = IO::Socket::INET->new( 13 | PeerAddr => 'localhost', 14 | PeerPort => '1234', 15 | Proto => 'tcp', 16 | ); 17 | 18 | die $! unless $sock; 19 | $sock->send("$exp_cnt,$exp_len\n"); 20 | $exp_len += 1; 21 | 22 | my $cnt = 0; 23 | while (my $line = read_line($sock)) { 24 | my $len = length($line); 25 | print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; 26 | ++$cnt; 27 | } 28 | 29 | printf "%.5f\n", (Time::HiRes::time() - $start_time); 30 | print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; 31 | exit 0; 32 | 33 | # implementation of application layer buffering 34 | # general concept: 35 | # 1. try read 4K block of data 36 | # 2. scan if for \n 37 | # 3. if found, return line 38 | # 4. go to step 1 39 | 40 | my $str; 41 | my $potential_data_in_str; 42 | sub read_line { 43 | my $sock = shift; 44 | 45 | if ($str && $potential_data_in_str) { 46 | my $idx = index($str, "\n"); 47 | if ($idx >= 0) { 48 | return substr($str, 0, $idx + 1, ''); 49 | } 50 | 51 | $potential_data_in_str = 0; 52 | } 53 | 54 | while (1) { 55 | my $buf; 56 | my $res = $sock->recv($buf, 4096); 57 | return unless defined $res; 58 | return unless $buf; 59 | 60 | my $idx = index($buf, "\n"); 61 | if ($idx >= 0) { 62 | my $line = $str ? $str . substr($buf, 0, $idx + 1, '') 63 | : substr($buf, 0, $idx + 1, ''); 64 | 65 | $str = $buf; 66 | $potential_data_in_str = 1; 67 | return $line; 68 | } else { 69 | $str .= $buf; 70 | } 71 | } 72 | } 73 | -------------------------------------------------------------------------------- /tools/benchmarks/readline_vs_sysread_vs_recv/client-sysread.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Time::HiRes; 6 | use IO::Socket::INET; 7 | 8 | my $exp_cnt = $ARGV[0]; 9 | my $exp_len = $ARGV[1]; 10 | my $start_time = Time::HiRes::time(); 11 | 12 | my $sock = IO::Socket::INET->new( 13 | PeerAddr => 'localhost', 14 | PeerPort => '1234', 15 | Proto => 'tcp', 16 | ); 17 | 18 | die $! unless $sock; 19 | die $! unless print $sock "$exp_cnt,$exp_len\n"; 20 | $exp_len += 1; 21 | 22 | my $cnt = 0; 23 | while (my $line = read_line($sock)) { 24 | my $len = length($line); 25 | print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; 26 | ++$cnt; 27 | } 28 | 29 | printf "%.5f\n", (Time::HiRes::time() - $start_time); 30 | print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; 31 | exit 0; 32 | 33 | # implementation of application layer buffering 34 | # general concept: 35 | # 1. try read 4K block of data 36 | # 2. scan if for \n 37 | # 3. if found, return line 38 | # 4. go to step 1 39 | 40 | my $str; 41 | my $potential_data_in_str; 42 | sub read_line { 43 | my $sock = shift; 44 | 45 | if ($str && $potential_data_in_str) { 46 | my $idx = index($str, "\n"); 47 | if ($idx >= 0) { 48 | return substr($str, 0, $idx + 1, ''); 49 | } 50 | 51 | $potential_data_in_str = 0; 52 | } 53 | 54 | while (1) { 55 | my $buf; 56 | my $len = sysread($sock, $buf, 4096); 57 | return unless defined $len; 58 | return unless $len; 59 | 60 | my $idx = index($buf, "\n"); 61 | if ($idx >= 0) { 62 | my $line = $str ? $str . substr($buf, 0, $idx + 1, '') 63 | : substr($buf, 0, $idx + 1, ''); 64 | 65 | $str = $buf; 66 | $potential_data_in_str = 1; 67 | return $line; 68 | } else { 69 | $str .= $buf; 70 | } 71 | } 72 | } 73 | -------------------------------------------------------------------------------- /tools/benchmarks/readline_vs_sysread_vs_recv/run.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | if (my $pid = fork()) { 7 | #parent 8 | print "starting server-generator\n"; 9 | system('./server-generator.pl'); 10 | kill 'KILL', $pid; 11 | } else { 12 | #child 13 | sleep(1); 14 | 15 | $| = 1; 16 | my $total_bytes = 5_000_000; 17 | my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); 18 | 19 | foreach my $length (@lengths) { 20 | my $cnt = int($total_bytes / $length); 21 | printf "--- # of lines: %d --- len of line: %d bytes ---\n", $cnt, $length; 22 | 23 | my $rl_res = `./client-readline.pl $cnt $length`; 24 | chomp $rl_res; 25 | print "readline: $rl_res sec\n"; 26 | 27 | my $sr_res = `./client-sysread.pl $cnt $length`; 28 | chomp $sr_res; 29 | print "sysread: $sr_res sec\n"; 30 | 31 | my $rc_res = `./client-recv.pl $cnt $length`; 32 | chomp $rc_res; 33 | print "recv: $rc_res sec\n"; 34 | } 35 | 36 | print "hit ctrl+c to stop the server\n"; 37 | } 38 | -------------------------------------------------------------------------------- /tools/benchmarks/readline_vs_sysread_vs_recv/server-generator.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use IO::Socket::INET; 6 | 7 | $| = 1; 8 | my $sock = IO::Socket::INET->new( 9 | Listen => 5, 10 | LocalAddr => 'localhost', 11 | LocalPort => 1234, 12 | Proto => 'tcp', 13 | ReuseAddr => 1, 14 | ); 15 | 16 | die $! unless $sock; 17 | die $! unless $sock->listen(); 18 | 19 | while (my $client = $sock->accept()) { 20 | my $line = <$client>; 21 | chomp $line; 22 | 23 | my ($cnt, $len) = split(',', $line); 24 | next unless $cnt || $len; 25 | 26 | for (my $i = 1; $i <= $cnt; ++$i) { 27 | print $client '.' x $len, "\n"; 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /tools/html_doc_scrapper.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use 5.10.1; 4 | 5 | my %exclude = map { $_ => 1 } 6 | qw(publish subscribe unsubscribe psubscribe punsubscribe ); 7 | 8 | my %hash; 9 | my (@groups, $group, $command, @args, $text); 10 | my ($in_section, $in_nav, $in_args); 11 | 12 | while (my $line = <>) { 13 | chomp $line; 14 | 15 | $line =~ m|
| 16 | and $in_section=1, next; 17 | $in_section && $line =~ m|| 22 | and $in_section = 0, $in_nav = 0, next; 23 | 24 | $line =~ m|li data-group="(.+?)".+?">| 25 | and $group = $1, 26 | next; 27 | $line =~ m|href="/commands/(.+?)">.+?| 28 | and $command=$1, @args=(), next; 29 | $line =~ m|| 30 | and $in_args = 1, next; 31 | $in_args && $line =~ m|| 32 | and $in_args = 0, next; 33 | $in_args 34 | and push(@args, $line =~ s/^\s+|\s+$//rg), 35 | next; 36 | ( ($text) = $line =~ m|(.+?)| ) 37 | && ! $exclude{$command} 38 | and $hash{$group}{$command =~ s/-/_/gr} = { 39 | text => $text, 40 | synopsis => '$r->' . ($command =~ s/-/_/gr). '(' 41 | . join(', ', @args) 42 | . ')', 43 | ref => $command, 44 | }, 45 | @args = (); 46 | } 47 | 48 | my $pod = ''; 49 | foreach (@groups) { 50 | my ($group, $name) = @$_; 51 | $pod .= "=head1 " . uc($name) . "\n\n"; 52 | foreach my $command (sort keys %{$hash{$group}}) { 53 | my %h = %{$hash{$group}{$command}}; 54 | $pod .= "=head2 $command\n\n" 55 | . " $h{synopsis}\n\n" 56 | . $h{text} . " (see L)\n\n"; 57 | } 58 | } 59 | say $pod; 60 | --------------------------------------------------------------------------------