pax_global_header00006660000000000000000000000064133353432300014511gustar00rootroot0000000000000052 comment=df7deb730619cc4be0d6957d6f81e157eb7c2985 libredis-fast-perl-0.22+dfsg/000077500000000000000000000000001333534323000160435ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/Build.PL000066400000000000000000000034451333534323000173450ustar00rootroot00000000000000# ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use warnings; use utf8; BEGIN { push @INC, '.' } use builder::MyBuilder; use File::Basename; use File::Spec; my %args = ( license => 'perl_5', dynamic_config => 0, configure_requires => { 'Module::Build' => '0.4005', }, requires => { 'Time::HiRes' => '0', 'Try::Tiny' => '0', 'perl' => '5.008001', }, recommends => { }, suggests => { }, build_requires => { }, test_requires => { 'Digest::SHA' => '0', 'File::Temp' => '0', 'Parallel::ForkManager' => '0', 'Test::Deep' => '0', 'Test::Fatal' => '0', 'Test::LeakTrace' => '0', 'Test::More' => '0.98', 'Test::SharedFork' => '0', 'Test::TCP' => '0', 'Test::UNIXSock' => '0', }, name => 'Redis-Fast', module_name => 'Redis::Fast', allow_pureperl => 0, script_files => [glob('script/*'), glob('bin/*')], PL_files => {}, test_files => ((-d '.git' || $ENV{RELEASE_TESTING}) && -d 'xt') ? 't/ xt/' : 't/', recursive_test_files => 1, ); if (-d 'share') { $args{share_dir} = 'share'; } my $builder = builder::MyBuilder->subclass( class => 'MyBuilder', code => q{ sub ACTION_distmeta { die "Do not run distmeta. Install Minilla and `minil install` instead.\n"; } sub ACTION_installdeps { die "Do not run installdeps. Run `cpanm --installdeps .` instead.\n"; } } )->new(%args); $builder->create_build_script(); libredis-fast-perl-0.22+dfsg/Changes000066400000000000000000000053761333534323000173510ustar00rootroot00000000000000Revision history for Redis 0.22 2018-08-12T06:26:24Z - Fix #80 Tests fail with redis-server 4.0.11 - Fix spelling error #79 (thanks @guimard) 0.21 2018-01-28T01:02:14Z - Fix reconnect behaviour differs from cpan Redis module #73 0.20 2017-02-25T22:48:26Z - Fix build issue on newer Perl 0.19 2016-12-20T11:33:33Z - support reconnecting on the specified error (thanks @yoheimuta) - experimental support of IPv6 - fix automatic refresh errors of sentinels list 0.18 2016-01-26T13:09:12Z - add missing dependencies (Test::UNIXSock, Parallel::ForkManager) 0.17 2016-01-23T06:29:53Z - use poll(2) instead of select(2) - hiredis is v0.13.3 now - fix some compiling warnings 0.16 2015-03-12T02:17:45Z - fix bad connection error handling #39 thx @celogeek 0.15 2015-03-10T14:10:54Z - use gmake for DragonflyBSD(thanks @nise-nabe) - support topic "0" in psubscribe - hiredis is v0.12.1 now - default connection unlimited time (-1) - use cnx_timeout for the connection instead of every 0.14 2014-12-07T13:34:06Z - Redis::Fast is now compatible with Redis.pm 1.976 - fix a link in pod because hiredis has moved(thanks @Csson !) - fix the test of password - fix inconsistency with binary strings 0.13 2014-10-16T11:07:31Z - support password option - fix deep recursion when maxclients is reached and reconnect, name, on_connect parameters used #21 - fix reconnect disabled inside transaction #22 0.12 2014-09-08T16:19:11Z - every option is in microseconds now - fix some tests - add missing dependencies (Try::Tiny, Test::SharedFork) - quit returns 1 if connection is available 0.11 2014-07-16T02:27:40Z - fix wrong read timeout - do not reconnect with read timeout 0.10 2014-07-16T00:55:29Z - no change - I release it by mistake 0.09 2014-07-08T15:46:39Z - fix double free - fix signal handling 0.08 2014-05-31T03:46:58Z - remove enconding/decoding feature - fix select database bug after reconnect 0.07 2014-05-17T07:19:34Z - Redis::Fast is now compatible with Redis.pm 1.974 - fix reconnect during transaction - Sentinel features (connections, timeouts, etc) support 0.06 2014-01-31T16:44:53Z - Fix memory leak of callback functions - Fix issue #5 does not play way with signals 0.05 2013-12-20T02:22:09Z - Fix memory leak of lists - PING commands trigers reconnect 0.04 2013-12-10T02:56:46Z - Fix memory leak - Fix dependance 0.03 2013-10-16T12:14:58Z - wait_for_messages will block forever if parameters are not given 0.02 2013-10-13T13:27:37Z - Remove needless module - Use gmake for building library on BSD platform except KFreeBSD - Improve reconnection 0.01 2013-10-10T16:46:27Z - First version libredis-fast-perl-0.22+dfsg/LICENSE000066400000000000000000000437651333534323000170670ustar00rootroot00000000000000This software is copyright (c) 2013 by Ichinose Shogo . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2013 by Ichinose Shogo . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2013 by Ichinose Shogo . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End libredis-fast-perl-0.22+dfsg/MANIFEST000066400000000000000000000042321333534323000171750ustar00rootroot00000000000000Build.PL Changes LICENSE META.json README.md builder/MyBuilder.pm cpanfile lib/Redis/Fast.pm lib/Redis/Fast/Hash.pm lib/Redis/Fast/List.pm lib/Redis/Fast/Sentinel.pm minil.toml scripts/publish.pl scripts/reconnect_on_error.pl scripts/redis-benchmark.pl src/Redis__Fast.xs t/01-basic.t t/02-responses.t t/03-pubsub.t t/04-pipeline.t t/05-nonblock.t t/06-on-connect.t t/07-reconnect-on-error.t t/07-reconnect.t t/08-unix-socket.t t/09-env-redis-server.t t/10-tie-list.t t/11-timeout.t t/20-tie-hash.t t/30-scripts.t t/42-client_cmds.t t/44-no-unicode-bug.t t/50-fork_safe.t t/51-leak.t t/53-blpop.t t/53-blpop_and_timeout.t t/53-deep-recursion.t t/53-fail-to-connect.t t/53-password.t t/53-signal.t t/53-timeout-length.t t/60-sentinel.t t/tlib/Test/SpawnRedisServer.pm t/tlib/Test/SpawnRedisTimeoutServer.pm tools/benchmarks/read_vs_sysread.pl tools/benchmarks/readline_vs_sysread_vs_recv/client-readline.pl tools/benchmarks/readline_vs_sysread_vs_recv/client-recv.pl tools/benchmarks/readline_vs_sysread_vs_recv/client-sysread.pl tools/benchmarks/readline_vs_sysread_vs_recv/run.pl tools/benchmarks/readline_vs_sysread_vs_recv/server-generator.pl typemap xt/release/kwalitee.t deps/hiredis/CHANGELOG.md deps/hiredis/COPYING deps/hiredis/Makefile deps/hiredis/README.md deps/hiredis/adapters/ae.h deps/hiredis/adapters/glib.h deps/hiredis/adapters/ivykis.h deps/hiredis/adapters/libev.h deps/hiredis/adapters/libevent.h deps/hiredis/adapters/libuv.h deps/hiredis/adapters/macosx.h deps/hiredis/adapters/qt.h deps/hiredis/async.c deps/hiredis/async.h deps/hiredis/dict.c deps/hiredis/dict.h deps/hiredis/examples/example-ae.c deps/hiredis/examples/example-glib.c deps/hiredis/examples/example-ivykis.c deps/hiredis/examples/example-libev.c deps/hiredis/examples/example-libevent.c deps/hiredis/examples/example-libuv.c deps/hiredis/examples/example-macosx.c deps/hiredis/examples/example-qt.cpp deps/hiredis/examples/example-qt.h deps/hiredis/examples/example.c deps/hiredis/fmacros.h deps/hiredis/hiredis.c deps/hiredis/hiredis.h deps/hiredis/net.c deps/hiredis/net.h deps/hiredis/read.c deps/hiredis/read.h deps/hiredis/sds.c deps/hiredis/sds.h deps/hiredis/test.c deps/hiredis/win32.h META.yml MANIFESTlibredis-fast-perl-0.22+dfsg/META.json000066400000000000000000000106141333534323000174660ustar00rootroot00000000000000{ "abstract" : "Perl binding for Redis database", "author" : [ "Ichinose Shogo " ], "dynamic_config" : 0, "generated_by" : "Minilla/v3.1.2", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Redis-Fast", "no_index" : { "directory" : [ "t", "xt", "inc", "share", "eg", "examples", "author", "builder", "deps" ] }, "prereqs" : { "configure" : { "requires" : { "File::Which" : "0", "Module::Build" : "0.4005", "Module::Build::XSUtil" : "0.02" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::Kwalitee" : "0", "Test::Kwalitee::Extra" : "0", "Test::MinimumVersion::Fast" : "0.04", "Test::PAUSE::Permissions" : "0.04", "Test::Pod" : "1.41", "Test::Spellunker" : "v0.2.7" } }, "runtime" : { "requires" : { "Time::HiRes" : "0", "Try::Tiny" : "0", "perl" : "5.008001" } }, "test" : { "requires" : { "Digest::SHA" : "0", "File::Temp" : "0", "Parallel::ForkManager" : "0", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::LeakTrace" : "0", "Test::More" : "0.98", "Test::SharedFork" : "0", "Test::TCP" : "0", "Test::UNIXSock" : "0" } } }, "provides" : { "Redis::Fast" : { "file" : "lib/Redis/Fast.pm", "version" : "0.22" }, "Redis::Fast::Hash" : { "file" : "lib/Redis/Fast/Hash.pm" }, "Redis::Fast::List" : { "file" : "lib/Redis/Fast/List.pm" }, "Redis::Fast::Sentinel" : { "file" : "lib/Redis/Fast/Sentinel.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/shogo82148/Redis-Fast/issues" }, "homepage" : "https://github.com/shogo82148/Redis-Fast", "repository" : { "url" : "git://github.com/shogo82148/Redis-Fast.git", "web" : "https://github.com/shogo82148/Redis-Fast" } }, "version" : "0.22", "x_contributors" : [ "Aaron Crane ", "Aaron Crane ", "Alex Kapranoff ", "Andreas Koenig ", "Celogeek ", "Damien Krotkine ", "David Steinbrunner ", "Dobrica Pavlinusic ", "Erik Carlsson ", "Flavio Poletti ", "Gregor Herrmann ", "Ivan Kruglov ", "Ivan Kruglov ", "Jeff Lavallee ", "Jose Luis Perez Diez ", "João Bolila ", "Masayuki Matsuki ", "Michael Klishin ", "Michiel Beijen ", "Pedro Melo ", "Rafael Garcia-Suarez ", "Steffen Mueller ", "Syohei YOSHIDA ", "Thiago Berlitz Rondon ", "U-LIFEBOOK\\Administrator ", "Ulrich Habel ", "Victor ", "Vincent ", "Volker Kroll ", "Xavier Guimard ", "Zugschlus ", "bj5004 ", "dams ", "hisaichi5518 ", "nise_nabe ", "perlpong ", "shogo82148 ", "sunnavy ", "xtab ", "yoheimuta ", "zhihong zhang ", "Ævar Arnfjörð Bjarmason " ], "x_serialization_backend" : "JSON::PP version 2.97001", "x_static_install" : 0 } libredis-fast-perl-0.22+dfsg/META.yml000066400000000000000000000060761333534323000173250ustar00rootroot00000000000000--- abstract: 'Perl binding for Redis database' author: - 'Ichinose Shogo ' build_requires: Digest::SHA: '0' File::Temp: '0' Parallel::ForkManager: '0' Test::Deep: '0' Test::Fatal: '0' Test::LeakTrace: '0' Test::More: '0.98' Test::SharedFork: '0' Test::TCP: '0' Test::UNIXSock: '0' configure_requires: File::Which: '0' Module::Build: '0.4005' Module::Build::XSUtil: '0.02' dynamic_config: 0 generated_by: 'Minilla/v3.1.2, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Redis-Fast no_index: directory: - t - xt - inc - share - eg - examples - author - builder - deps provides: Redis::Fast: file: lib/Redis/Fast.pm version: '0.22' Redis::Fast::Hash: file: lib/Redis/Fast/Hash.pm Redis::Fast::List: file: lib/Redis/Fast/List.pm Redis::Fast::Sentinel: file: lib/Redis/Fast/Sentinel.pm requires: Time::HiRes: '0' Try::Tiny: '0' perl: '5.008001' resources: bugtracker: https://github.com/shogo82148/Redis-Fast/issues homepage: https://github.com/shogo82148/Redis-Fast repository: git://github.com/shogo82148/Redis-Fast.git version: '0.22' x_contributors: - 'Aaron Crane ' - 'Aaron Crane ' - 'Alex Kapranoff ' - 'Andreas Koenig ' - 'Celogeek ' - 'Damien Krotkine ' - 'David Steinbrunner ' - 'Dobrica Pavlinusic ' - 'Erik Carlsson ' - 'Flavio Poletti ' - 'Gregor Herrmann ' - 'Ivan Kruglov ' - 'Ivan Kruglov ' - 'Jeff Lavallee ' - 'Jose Luis Perez Diez ' - 'João Bolila ' - 'Masayuki Matsuki ' - 'Michael Klishin ' - 'Michiel Beijen ' - 'Pedro Melo ' - 'Rafael Garcia-Suarez ' - 'Steffen Mueller ' - 'Syohei YOSHIDA ' - 'Thiago Berlitz Rondon ' - 'U-LIFEBOOK\Administrator ' - 'Ulrich Habel ' - 'Victor ' - 'Vincent ' - 'Volker Kroll ' - 'Xavier Guimard ' - 'Zugschlus ' - 'bj5004 ' - 'dams ' - 'hisaichi5518 ' - 'nise_nabe ' - 'perlpong ' - 'shogo82148 ' - 'sunnavy ' - 'xtab ' - 'yoheimuta ' - 'zhihong zhang ' - 'Ævar Arnfjörð Bjarmason ' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_static_install: 0 libredis-fast-perl-0.22+dfsg/README.md000066400000000000000000000202311333534323000173200ustar00rootroot00000000000000[![Build Status](https://travis-ci.org/shogo82148/Redis-Fast.svg?branch=master)](https://travis-ci.org/shogo82148/Redis-Fast) [![MetaCPAN Release](https://badge.fury.io/pl/Redis-Fast.svg)](https://metacpan.org/release/Redis-Fast) # NAME Redis::Fast - Perl binding for Redis database # SYNOPSIS ## Defaults to $ENV{REDIS_SERVER} or 127.0.0.1:6379 my $redis = Redis::Fast->new; my $redis = Redis::Fast->new(server => 'redis.example.com:8080'); ## Set the connection name (requires Redis 2.6.9) my $redis = Redis::Fast->new( server => 'redis.example.com:8080', name => 'my_connection_name', ); my $generation = 0; my $redis = Redis::Fast->new( server => 'redis.example.com:8080', name => sub { "cache-$$-".++$generation }, ); ## Use UNIX domain socket my $redis = Redis::Fast->new(sock => '/path/to/socket'); ## Enable auto-reconnect ## Try to reconnect every 500ms up to 60 seconds until success ## Die if you can't after that my $redis = Redis::Fast->new(reconnect => 60, every => 500_000); ## Try each 100ms up to 2 seconds (every is in microseconds) my $redis = Redis::Fast->new(reconnect => 2, every => 100_000); ## Disable the automatic utf8 encoding => much more performance ## !!!! This will be the default after 2.000, see ENCODING below my $redis = Redis::Fast->new(encoding => undef); ## Use all the regular Redis commands, they all accept a list of ## arguments ## See http://redis.io/commands for full list $redis->get('key'); $redis->set('key' => 'value'); $redis->sort('list', 'DESC'); $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}); ## Add a coderef argument to run a command in the background $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}, sub { my ($reply, $error) = @_; die "Oops, got an error: $error\n" if defined $error; print "$_\n" for @$reply; }); long_computation(); $redis->wait_all_responses; ## or $redis->wait_one_response(); ## Or run a large batch of commands in a pipeline my %hash = _get_large_batch_of_commands(); $redis->hset('h', $_, $hash{$_}, sub {}) for keys %hash; $redis->wait_all_responses; ## Publish/Subscribe $redis->subscribe( 'topic_1', 'topic_2', sub { my ($message, $topic, $subscribed_topic) = @_ ## $subscribed_topic can be different from topic if ## you use psubscribe() with wildcards } ); $redis->psubscribe('nasdaq.*', sub {...}); ## Blocks and waits for messages, calls subscribe() callbacks ## ... forever my $timeout = 10; $redis->wait_for_messages($timeout) while 1; ## ... until some condition my $keep_going = 1; ## other code will set to false to quit $redis->wait_for_messages($timeout) while $keep_going; $redis->publish('topic_1', 'message'); # DESCRIPTION `Redis::Fast` is a wrapper around Salvatore Sanfilippo's [hiredis](https://github.com/redis/hiredis) C client. It is compatible with [Redis.pm](https://github.com/melo/perl-redis). This version supports protocol 2.x (multi-bulk) or later of Redis available at [https://github.com/antirez/redis/](https://github.com/antirez/redis/). ## Reconnect on error Besides auto-reconnect when the connection is closed, `Redis::Fast` supports reconnecting on the specified errors by the `reconnect_on_error` option. Here's an example that will reconnect when receiving `READONLY` error: my $r = Redis::Fast->new( reconnect => 1, # The value greater than 0 is required reconnect_on_error => sub { my ($error, $ret, $command) = @_; if ($error =~ /READONLY You can't write against a read only slave/) { # force reconnect return 1; } # do nothing return -1; }, ); This feature is useful when using Amazon ElastiCache. Once failover happens, Amazon ElastiCache will switch the master we currently connected with to a slave, leading to the following writes fails with the error `READONLY`. Using `reconnect_on_error`, we can force the connection to reconnect on this error in order to connect to the new master. If your Elasticache Redis is enabled to be set an option for [close-on-slave-write](https://docs.aws.amazon.com/AmazonElastiCache/latest/UserGuide/ParameterGroups.Redis.html#ParameterGroups.Redis.2-8-23), this feature might be unnecessary. The return value of `reconnect_on_error` should be greater than `-2`. `-1` means that `Redis::Fast` behaves the same as without this option. `0` and greater than `0` means that `Redis::Fast` forces to reconnect and then wait for a next force reconnect until this value seconds elapse. This unit is a second, and the type is double. For example, 0.01 means 10 milliseconds. Note: This feature is not supported for the subscribed mode. # PERFORMANCE IN SYNCHRONIZE MODE ## Redis.pm Benchmark: running 00_ping, 10_set, 11_set_r, 20_get, 21_get_r, 30_incr, 30_incr_r, 40_lpush, 50_lpop, 90_h_get, 90_h_set for at least 5 CPU seconds... 00_ping: 8 wallclock secs ( 0.69 usr + 4.77 sys = 5.46 CPU) @ 5538.64/s (n=30241) 10_set: 8 wallclock secs ( 1.07 usr + 4.01 sys = 5.08 CPU) @ 5794.09/s (n=29434) 11_set_r: 7 wallclock secs ( 0.42 usr + 4.84 sys = 5.26 CPU) @ 5051.33/s (n=26570) 20_get: 8 wallclock secs ( 0.69 usr + 4.82 sys = 5.51 CPU) @ 5080.40/s (n=27993) 21_get_r: 7 wallclock secs ( 2.21 usr + 3.09 sys = 5.30 CPU) @ 5389.06/s (n=28562) 30_incr: 7 wallclock secs ( 0.69 usr + 4.73 sys = 5.42 CPU) @ 5671.77/s (n=30741) 30_incr_r: 7 wallclock secs ( 0.85 usr + 4.31 sys = 5.16 CPU) @ 5824.42/s (n=30054) 40_lpush: 8 wallclock secs ( 0.60 usr + 4.77 sys = 5.37 CPU) @ 5832.59/s (n=31321) 50_lpop: 7 wallclock secs ( 1.24 usr + 4.17 sys = 5.41 CPU) @ 5112.75/s (n=27660) 90_h_get: 7 wallclock secs ( 0.63 usr + 4.65 sys = 5.28 CPU) @ 5716.29/s (n=30182) 90_h_set: 7 wallclock secs ( 0.65 usr + 4.74 sys = 5.39 CPU) @ 5593.14/s (n=30147) ## Redis::Fast Redis::Fast is 50% faster than Redis.pm. Benchmark: running 00_ping, 10_set, 11_set_r, 20_get, 21_get_r, 30_incr, 30_incr_r, 40_lpush, 50_lpop, 90_h_get, 90_h_set for at least 5 CPU seconds... 00_ping: 9 wallclock secs ( 0.18 usr + 4.84 sys = 5.02 CPU) @ 7939.24/s (n=39855) 10_set: 10 wallclock secs ( 0.31 usr + 5.40 sys = 5.71 CPU) @ 7454.64/s (n=42566) 11_set_r: 9 wallclock secs ( 0.31 usr + 4.87 sys = 5.18 CPU) @ 7993.05/s (n=41404) 20_get: 10 wallclock secs ( 0.27 usr + 4.84 sys = 5.11 CPU) @ 8350.68/s (n=42672) 21_get_r: 10 wallclock secs ( 0.32 usr + 5.17 sys = 5.49 CPU) @ 8238.62/s (n=45230) 30_incr: 9 wallclock secs ( 0.23 usr + 5.27 sys = 5.50 CPU) @ 8221.82/s (n=45220) 30_incr_r: 8 wallclock secs ( 0.28 usr + 4.91 sys = 5.19 CPU) @ 8092.29/s (n=41999) 40_lpush: 9 wallclock secs ( 0.18 usr + 5.06 sys = 5.24 CPU) @ 8312.02/s (n=43555) 50_lpop: 9 wallclock secs ( 0.20 usr + 4.84 sys = 5.04 CPU) @ 8010.12/s (n=40371) 90_h_get: 9 wallclock secs ( 0.19 usr + 5.51 sys = 5.70 CPU) @ 7467.72/s (n=42566) 90_h_set: 8 wallclock secs ( 0.28 usr + 4.83 sys = 5.11 CPU) @ 7724.07/s (n=39470)o # PERFORMANCE IN PIPELINE MODE #!/usr/bin/perl use warnings; use strict; use Time::HiRes qw/time/; use Redis; my $count = 100000; { my $r = Redis->new; my $start = time; for(1..$count) { $r->set('hoge', 'fuga', sub{}); } $r->wait_all_responses; printf "Redis.pm:\n%.2f/s\n", $count / (time - $start); } { my $r = Redis::Fast->new; my $start = time; for(1..$count) { $r->set('hoge', 'fuga', sub{}); } $r->wait_all_responses; printf "Redis::Fast:\n%.2f/s\n", $count / (time - $start); } Redis::Fast is 4x faster than Redis.pm in pipeline mode. Redis.pm: 22588.95/s Redis::Fast: 81098.01/s # AUTHOR Ichinose Shogo # SEE ALSO - [Redis.pm](https://github.com/melo/perl-redis) # LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. libredis-fast-perl-0.22+dfsg/builder/000077500000000000000000000000001333534323000174715ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/builder/MyBuilder.pm000066400000000000000000000032061333534323000217240ustar00rootroot00000000000000package builder::MyBuilder; use strict; use warnings FATAL => 'all'; use 5.008005; use base 'Module::Build::XSUtil'; use Config; use File::Which qw(which); sub new { my ( $class, %args ) = @_; my $self = $class->SUPER::new( %args, generate_ppport_h => 'src/ppport.h', c_source => 'src', xs_files => { './src/Redis__Fast.xs' => './lib/Redis/Fast.xs', }, include_dirs => ['src', 'deps/hiredis'], extra_linker_flags => ["deps/hiredis/libhiredis$Config{lib_ext}"], $ENV{REDIS_DEBUG} ? ( extra_compiler_flags => [qw/-DDEBUG/] ) : (), test_requires => { "Digest::SHA" => "0", "File::Temp" => "0", "Parallel::ForkManager" => "0", "Test::Deep" => "0", "Test::Fatal" => "0", "Test::LeakTrace" => "0", "Test::More" => "0.98", "Test::SharedFork" => "0", "Test::TCP" => "0", "Test::UNIXSock" => "0", }, ); my $make; if ($^O =~ m/(bsd|dragonfly)$/ && $^O !~ m/gnukfreebsd$/) { my $gmake = which('gmake'); unless (defined $gmake) { print "'gmake' is necessary for BSD platform.\n"; exit 0; } $make = $gmake; } else { $make = $Config{make}; } if (-e '.git') { unless (-e 'deps/hiredis/Makefile') { $self->do_system('git','submodule','update','--init'); } } $self->do_system($make, '-C', 'deps/hiredis', 'static'); return $self; } 1; libredis-fast-perl-0.22+dfsg/cpanfile000066400000000000000000000011331333534323000175450ustar00rootroot00000000000000requires 'perl', '5.008001'; requires 'Try::Tiny'; requires 'Time::HiRes'; on 'configure' => sub{ requires 'Module::Build::XSUtil' => '>=0.02'; requires 'File::Which'; }; on 'test' => sub { requires 'Test::More', '0.98'; requires 'File::Temp'; requires 'Test::Deep'; requires 'Test::TCP'; requires 'Test::UNIXSock'; requires 'Parallel::ForkManager'; requires 'Test::Fatal'; requires 'Test::SharedFork'; requires 'Test::LeakTrace'; requires 'Digest::SHA'; }; on 'develop' => sub { requires 'Test::Kwalitee'; requires 'Test::Kwalitee::Extra'; }; libredis-fast-perl-0.22+dfsg/lib/000077500000000000000000000000001333534323000166115ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/lib/Redis/000077500000000000000000000000001333534323000176575ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/lib/Redis/Fast.pm000066400000000000000000000525131333534323000211200ustar00rootroot00000000000000package Redis::Fast; BEGIN { use XSLoader; our $VERSION = '0.22'; XSLoader::load __PACKAGE__, $VERSION; } use warnings; use strict; use Carp qw/confess/; use Encode; use Try::Tiny; use Scalar::Util qw(weaken); use Redis::Fast::Sentinel; # small utilities for handling host and port sub _join_host_port { my ($host, $port) = @_; return "[$host]:$port" if $host =~ /:/ || $host =~ /%/; return "$host:$port"; } sub _split_host_port { my $hostport = shift; if ($hostport =~ /\A\[([^\]]+)\]:([0-9]+)\z/) { return $1, $2; } return split /:/, $hostport; } sub _new_on_connect_cb { my ($self, $on_conn, $password, $name) = @_; weaken $self; my $handler = sub { # If we are in PubSub mode we shouldn't perform any command besides # (p)(un)subscribe if (! $self->is_subscriber) { defined $name and try { my $n = $name; $n = $n->($self) if ref($n) eq 'CODE'; $self->client_setname($n) if defined $n; }; my $data = $self->__get_data; defined $data->{current_database} and $self->select($data->{current_database}); } my $subscribers = $self->__get_data->{subscribers}; $self->__get_data->{subscribers} = {}; $self->__get_data->{cbs} = undef; foreach my $topic (CORE::keys(%{$subscribers})) { if ($topic =~ /(p?message):(.*)$/ ) { my ($key, $channel) = ($1, $2); my $subs = $subscribers->{$topic}; if ($key eq 'message') { $self->__subscription_cmd('', 0, subscribe => $channel, $_) for @$subs; } else { $self->__subscription_cmd('p', 0, psubscribe => $channel, $_) for @$subs; } } } defined $on_conn and $on_conn->($self); }; return sub { my $reconnect_stash = $self->__get_reconnect; if(defined $password) { my $err; $self->__set_reconnect(0); try { $self->auth($password); } catch { $err = $_; }; if(defined $err) { if($err =~ /ERR invalid password/) { # password setting is incorrect, no need to reconnect die("Redis server refused password"); } else { # it might be network error # invoke reconnect $self->__set_reconnect($reconnect_stash); return ; } } } try { # disable reconnection while executing on_connect handler $self->__set_reconnect(0); $handler->(); } catch { $self->quit(); } finally { $self->__set_reconnect($reconnect_stash); }; }; } sub _new_reconnect_on_error_cb { my ($self, $reconnect_on_error) = @_; weaken $self; if ($reconnect_on_error) { return sub { # The unit should be second and the type should be double. # -1 is a special value, it means that we do not reconnect. my $next_reconnect_interval = $reconnect_on_error->(@_); if ($next_reconnect_interval < -1) { warn "reconnect_on_error must not return a number less than -1"; # Reset a next_reconnect_interval and do not reconnect. $next_reconnect_interval = -1; } # Wait until next_reconnect_interval seconds elapse. $self->__set_next_reconnect_on_error_at($next_reconnect_interval); my $need_reconnect = 0; if (-1 < $next_reconnect_interval) { $need_reconnect = 1; } return $need_reconnect; }; } else { return; } } sub new { my $class = shift; my %args = @_; my $self = $class->_new; #$self->{debug} = $args{debug} || $ENV{REDIS_DEBUG}; ## Deal with REDIS_SERVER ENV if ($ENV{REDIS_SERVER} && !$args{sock} && !$args{server}) { if ($ENV{REDIS_SERVER} =~ m!^/!) { $args{sock} = $ENV{REDIS_SERVER}; } elsif ($ENV{REDIS_SERVER} =~ m!^unix:(.+)!) { $args{sock} = $1; } elsif ($ENV{REDIS_SERVER} =~ m!^(tcp:)?(.+)!) { $args{server} = $2; } } my $on_conn = $args{on_connect}; my $password = $args{password}; my $name = $args{name}; $self->__set_on_connect($self->_new_on_connect_cb($on_conn, $password, $name)); $self->__set_data({ subscribers => {}, sentinels_cnx_timeout => $args{sentinels_cnx_timeout}, sentinels_read_timeout => $args{sentinels_read_timeout}, sentinels_write_timeout => $args{sentinels_write_timeout}, no_sentinels_list_update => $args{no_sentinels_list_update}, }); if ($args{sock}) { $self->__connection_info_unix($args{sock}); } elsif ($args{sentinels}) { my $sentinels = $args{sentinels}; ref $sentinels eq 'ARRAY' or croak("'sentinels' param must be an ArrayRef"); defined($self->__get_data->{service} = $args{service}) or croak("Need 'service' name when using 'sentinels'!"); $self->__get_data->{sentinels} = $sentinels; my $on_build_sock = sub { my $data = $self->__get_data; my $sentinels = $data->{sentinels}; # try to connect to a sentinel my $status; foreach my $sentinel_address (@$sentinels) { my $sentinel = eval { Redis::Fast::Sentinel->new( server => $sentinel_address, cnx_timeout => ( exists $data->{sentinels_cnx_timeout} ? $data->{sentinels_cnx_timeout} : 0.1), read_timeout => ( exists $data->{sentinels_read_timeout} ? $data->{sentinels_read_timeout} : 1 ), write_timeout => ( exists $data->{sentinels_write_timeout} ? $data->{sentinels_write_timeout} : 1 ), ) } or next; my $server_address = $sentinel->get_service_address($data->{service}); defined $server_address or $status ||= "Sentinels don't know this service", next; $server_address eq 'IDONTKNOW' and $status = "service is configured in one Sentinel, but was never reached", next; # we found the service, set the server my ($server, $port) = _split_host_port $server_address; $self->__connection_info($server, $port); if (! $data->{no_sentinels_list_update} ) { # move the elected sentinel at the front of the list and add # additional sentinels my $idx = 2; my %h = ( ( map { $_ => $idx++ } @{$data->{sentinels}}), $sentinel_address => 1, ); $data->{sentinels} = [ ( sort { $h{$a} <=> $h{$b} } keys %h ), # sorted existing sentinels, grep { ! $h{$_}; } # list of unknown map { my $s = +{ @$_ }; _join_host_port($s->{ip}, $s->{port}); } # ip:port of $sentinel->sentinel( # sentinels sentinels => $data->{service} # for this service ) ]; } } }; $self->__set_on_build_sock($on_build_sock); } else { my ($server, $port) = _split_host_port($args{server} || '127.0.0.1:6379'); $self->__connection_info($server, $port); } #$self->{is_subscriber} = 0; #$self->{subscribers} = {}; $self->__set_reconnect($args{reconnect} || 0); $self->__set_every($args{every} || 1000); $self->__set_cnx_timeout($args{cnx_timeout} || -1); $self->__set_read_timeout($args{read_timeout} || -1); $self->__set_write_timeout($args{write_timeout} || -1); if (my $cb = $self->_new_reconnect_on_error_cb($args{reconnect_on_error})) { $self->__set_reconnect_on_error($cb); } $self->connect unless $args{no_auto_connect_on_new}; return $self; } ### Deal with common, general case, Redis commands our $AUTOLOAD; sub AUTOLOAD { my $command = $AUTOLOAD; $command =~ s/.*://; my @command = split /_/, uc $command; my $method = sub { my $self = shift; $self->__is_valid_command($command); my ($ret, $error) = $self->__std_cmd(@command, @_); confess "[$command] $error, " if defined $error; return (wantarray && ref $ret eq 'ARRAY') ? @$ret : $ret; }; # Save this method for future calls no strict 'refs'; *$AUTOLOAD = $method; goto $method; } sub __with_reconnect { my ($self, $cb) = @_; confess "not implemented"; } ### Commands with extra logic sub keys { my $self = shift; $self->__is_valid_command('keys'); my ($ret, $error) = $self->__keys(@_); confess "[keys] $error, " if defined $error; return $ret unless ref $ret eq 'ARRAY'; return @$ret; } sub ping { my $self = shift; $self->__is_valid_command('ping'); return unless $self->__sock; return scalar try { my ($ret, $error) = $self->__std_cmd('ping'); return if defined $error; return $ret; } catch { return ; }; } sub info { my $self = shift; $self->__is_valid_command('info'); my ($ret, $error) = $self->__info(@_); confess "[keys] $error, " if defined $error; return $ret unless ref $ret eq 'ARRAY'; return @$ret; } sub quit { my $self = shift; $self->__is_valid_command('quit'); $self->__quit(@_); } sub shutdown { my $self = shift; $self->__is_valid_command('shutdown'); $self->__shutdown(@_); } sub select { my $self = shift; my $database = shift; $self->__is_valid_command('select'); my ($ret, $error) = $self->__std_cmd('SELECT', $database, @_); confess "[SELECT] $error, " if defined $error; $self->__get_data->{current_database} = $database; return $ret; } sub __subscription_cmd { my $self = shift; my $pr = shift; my $unsub = shift; my $command = shift; my $cb = pop; weaken $self; confess("Missing required callback in call to $command(), ") unless ref($cb) eq 'CODE'; $self->wait_all_responses; while($self->__get_data->{cbs}) { $self->__wait_for_event(1); } my @subs = @_; @subs = $self->__process_unsubscribe_requests($cb, $pr, @subs) if $unsub; if(@subs) { $self->__get_data->{cbs} = { map { ("${pr}message:$_" => $cb) } @subs }; for my $sub(@subs) { $self->__send_subscription_cmd( $command, $sub, $self->__subscription_callbak, ); } while($self->__get_data->{cbs}) { $self->__wait_for_event(1); } } } sub __subscription_callbak { my $self = shift; my $cb = $self->__get_data->{callback}; return $cb if $cb; weaken $self; $cb = sub { my $cbs = $self->__get_data->{cbs}; if($cbs) { $self->__process_subscription_changes($cbs, @_); unless(%$cbs) { $self->__get_data->{cbs} = undef; } } else { $self->__process_pubsub_msg(@_); } }; $self->__get_data->{callback} = $cb; return $cb; } sub subscribe { shift->__subscription_cmd('', 0, subscribe => @_) } sub psubscribe { shift->__subscription_cmd('p', 0, psubscribe => @_) } sub unsubscribe { shift->__subscription_cmd('', 1, unsubscribe => @_) } sub punsubscribe { shift->__subscription_cmd('p', 1, punsubscribe => @_) } sub __process_unsubscribe_requests { my ($self, $cb, $pr, @unsubs) = @_; my $subs = $self->__get_data->{subscribers}; my @subs_to_unsubscribe; for my $sub (@unsubs) { my $key = "${pr}message:$sub"; next unless $subs->{$key} && @{ $subs->{$key} }; my $cbs = $subs->{$key} = [grep { $_ ne $cb } @{ $subs->{$key} }]; next if @$cbs; delete $subs->{$key}; push @subs_to_unsubscribe, $sub; } return @subs_to_unsubscribe; } sub __process_subscription_changes { my ($self, $expected, $m, $error) = @_; my $subs = $self->__get_data->{subscribers}; ## Deal with pending PUBLISH'ed messages if ($m->[0] =~ /^p?message$/) { $self->__process_pubsub_msg($m); return ; } my ($key, $unsub) = $m->[0] =~ m/^(p)?(un)?subscribe$/; $key .= "message:$m->[1]"; my $cb = delete $expected->{$key}; push @{ $subs->{$key} }, $cb unless $unsub; } sub __process_pubsub_msg { my ($self, $m) = @_; my $subs = $self->__get_data->{subscribers}; my $sub = $m->[1]; my $cbid = "$m->[0]:$sub"; my $data = pop @$m; my $topic = defined $m->[2] ? $m->[2] : $sub; if (!exists $subs->{$cbid}) { warn "Message for topic '$topic' ($cbid) without expected callback, "; return 0; } $_->($data, $topic, $sub) for @{ $subs->{$cbid} }; return 1; } sub __is_valid_command { my ($self, $cmd) = @_; confess("Cannot use command '$cmd' while in SUBSCRIBE mode, ") if $self->is_subscriber; } 1; # End of Redis.pm __END__ =encoding utf-8 =head1 NAME Redis::Fast - Perl binding for Redis database =head1 SYNOPSIS ## Defaults to $ENV{REDIS_SERVER} or 127.0.0.1:6379 my $redis = Redis::Fast->new; my $redis = Redis::Fast->new(server => 'redis.example.com:8080'); ## Set the connection name (requires Redis 2.6.9) my $redis = Redis::Fast->new( server => 'redis.example.com:8080', name => 'my_connection_name', ); my $generation = 0; my $redis = Redis::Fast->new( server => 'redis.example.com:8080', name => sub { "cache-$$-".++$generation }, ); ## Use UNIX domain socket my $redis = Redis::Fast->new(sock => '/path/to/socket'); ## Enable auto-reconnect ## Try to reconnect every 500ms up to 60 seconds until success ## Die if you can't after that my $redis = Redis::Fast->new(reconnect => 60, every => 500_000); ## Try each 100ms up to 2 seconds (every is in microseconds) my $redis = Redis::Fast->new(reconnect => 2, every => 100_000); ## Disable the automatic utf8 encoding => much more performance ## !!!! This will be the default after 2.000, see ENCODING below my $redis = Redis::Fast->new(encoding => undef); ## Use all the regular Redis commands, they all accept a list of ## arguments ## See http://redis.io/commands for full list $redis->get('key'); $redis->set('key' => 'value'); $redis->sort('list', 'DESC'); $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}); ## Add a coderef argument to run a command in the background $redis->sort(qw{list LIMIT 0 5 ALPHA DESC}, sub { my ($reply, $error) = @_; die "Oops, got an error: $error\n" if defined $error; print "$_\n" for @$reply; }); long_computation(); $redis->wait_all_responses; ## or $redis->wait_one_response(); ## Or run a large batch of commands in a pipeline my %hash = _get_large_batch_of_commands(); $redis->hset('h', $_, $hash{$_}, sub {}) for keys %hash; $redis->wait_all_responses; ## Publish/Subscribe $redis->subscribe( 'topic_1', 'topic_2', sub { my ($message, $topic, $subscribed_topic) = @_ ## $subscribed_topic can be different from topic if ## you use psubscribe() with wildcards } ); $redis->psubscribe('nasdaq.*', sub {...}); ## Blocks and waits for messages, calls subscribe() callbacks ## ... forever my $timeout = 10; $redis->wait_for_messages($timeout) while 1; ## ... until some condition my $keep_going = 1; ## other code will set to false to quit $redis->wait_for_messages($timeout) while $keep_going; $redis->publish('topic_1', 'message'); =head1 DESCRIPTION C is a wrapper around Salvatore Sanfilippo's L C client. It is compatible with L. This version supports protocol 2.x (multi-bulk) or later of Redis available at L. =head2 Reconnect on error Besides auto-reconnect when the connection is closed, C supports reconnecting on the specified errors by the C option. Here's an example that will reconnect when receiving C error: my $r = Redis::Fast->new( reconnect => 1, # The value greater than 0 is required reconnect_on_error => sub { my ($error, $ret, $command) = @_; if ($error =~ /READONLY You can't write against a read only slave/) { # force reconnect return 1; } # do nothing return -1; }, ); This feature is useful when using Amazon ElastiCache. Once failover happens, Amazon ElastiCache will switch the master we currently connected with to a slave, leading to the following writes fails with the error C. Using C, we can force the connection to reconnect on this error in order to connect to the new master. If your Elasticache Redis is enabled to be set an option for L, this feature might be unnecessary. The return value of C should be greater than C<-2>. C<-1> means that C behaves the same as without this option. C<0> and greater than C<0> means that C forces to reconnect and then wait for a next force reconnect until this value seconds elapse. This unit is a second, and the type is double. For example, 0.01 means 10 milliseconds. Note: This feature is not supported for the subscribed mode. =head1 PERFORMANCE IN SYNCHRONIZE MODE =head2 Redis.pm Benchmark: running 00_ping, 10_set, 11_set_r, 20_get, 21_get_r, 30_incr, 30_incr_r, 40_lpush, 50_lpop, 90_h_get, 90_h_set for at least 5 CPU seconds... 00_ping: 8 wallclock secs ( 0.69 usr + 4.77 sys = 5.46 CPU) @ 5538.64/s (n=30241) 10_set: 8 wallclock secs ( 1.07 usr + 4.01 sys = 5.08 CPU) @ 5794.09/s (n=29434) 11_set_r: 7 wallclock secs ( 0.42 usr + 4.84 sys = 5.26 CPU) @ 5051.33/s (n=26570) 20_get: 8 wallclock secs ( 0.69 usr + 4.82 sys = 5.51 CPU) @ 5080.40/s (n=27993) 21_get_r: 7 wallclock secs ( 2.21 usr + 3.09 sys = 5.30 CPU) @ 5389.06/s (n=28562) 30_incr: 7 wallclock secs ( 0.69 usr + 4.73 sys = 5.42 CPU) @ 5671.77/s (n=30741) 30_incr_r: 7 wallclock secs ( 0.85 usr + 4.31 sys = 5.16 CPU) @ 5824.42/s (n=30054) 40_lpush: 8 wallclock secs ( 0.60 usr + 4.77 sys = 5.37 CPU) @ 5832.59/s (n=31321) 50_lpop: 7 wallclock secs ( 1.24 usr + 4.17 sys = 5.41 CPU) @ 5112.75/s (n=27660) 90_h_get: 7 wallclock secs ( 0.63 usr + 4.65 sys = 5.28 CPU) @ 5716.29/s (n=30182) 90_h_set: 7 wallclock secs ( 0.65 usr + 4.74 sys = 5.39 CPU) @ 5593.14/s (n=30147) =head2 Redis::Fast Redis::Fast is 50% faster than Redis.pm. Benchmark: running 00_ping, 10_set, 11_set_r, 20_get, 21_get_r, 30_incr, 30_incr_r, 40_lpush, 50_lpop, 90_h_get, 90_h_set for at least 5 CPU seconds... 00_ping: 9 wallclock secs ( 0.18 usr + 4.84 sys = 5.02 CPU) @ 7939.24/s (n=39855) 10_set: 10 wallclock secs ( 0.31 usr + 5.40 sys = 5.71 CPU) @ 7454.64/s (n=42566) 11_set_r: 9 wallclock secs ( 0.31 usr + 4.87 sys = 5.18 CPU) @ 7993.05/s (n=41404) 20_get: 10 wallclock secs ( 0.27 usr + 4.84 sys = 5.11 CPU) @ 8350.68/s (n=42672) 21_get_r: 10 wallclock secs ( 0.32 usr + 5.17 sys = 5.49 CPU) @ 8238.62/s (n=45230) 30_incr: 9 wallclock secs ( 0.23 usr + 5.27 sys = 5.50 CPU) @ 8221.82/s (n=45220) 30_incr_r: 8 wallclock secs ( 0.28 usr + 4.91 sys = 5.19 CPU) @ 8092.29/s (n=41999) 40_lpush: 9 wallclock secs ( 0.18 usr + 5.06 sys = 5.24 CPU) @ 8312.02/s (n=43555) 50_lpop: 9 wallclock secs ( 0.20 usr + 4.84 sys = 5.04 CPU) @ 8010.12/s (n=40371) 90_h_get: 9 wallclock secs ( 0.19 usr + 5.51 sys = 5.70 CPU) @ 7467.72/s (n=42566) 90_h_set: 8 wallclock secs ( 0.28 usr + 4.83 sys = 5.11 CPU) @ 7724.07/s (n=39470)o =head1 PERFORMANCE IN PIPELINE MODE #!/usr/bin/perl use warnings; use strict; use Time::HiRes qw/time/; use Redis; my $count = 100000; { my $r = Redis->new; my $start = time; for(1..$count) { $r->set('hoge', 'fuga', sub{}); } $r->wait_all_responses; printf "Redis.pm:\n%.2f/s\n", $count / (time - $start); } { my $r = Redis::Fast->new; my $start = time; for(1..$count) { $r->set('hoge', 'fuga', sub{}); } $r->wait_all_responses; printf "Redis::Fast:\n%.2f/s\n", $count / (time - $start); } Redis::Fast is 4x faster than Redis.pm in pipeline mode. Redis.pm: 22588.95/s Redis::Fast: 81098.01/s =head1 AUTHOR Ichinose Shogo Eshogo82148@gmail.comE =head1 SEE ALSO =over 4 =item * L =back =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libredis-fast-perl-0.22+dfsg/lib/Redis/Fast/000077500000000000000000000000001333534323000205545ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/lib/Redis/Fast/Hash.pm000066400000000000000000000040631333534323000220000ustar00rootroot00000000000000package Redis::Fast::Hash; # ABSTRACT: tie Perl hashes to Redis hashes # VERSION # AUTHORITY use strict; use warnings; require Tie::Hash; require Redis::Fast; our @ISA = qw(Redis::Fast Tie::StdHash); sub TIEHASH { my ($class, $prefix, @rest) = @_; my $self = $class->new(@rest); $self->__set_data({}); $self->__get_data->{prefix} = $prefix ? "$prefix:" : ''; return $self; } sub STORE { my ($self, $key, $value) = @_; $self->set($self->__get_data->{prefix} . $key, $value); } sub FETCH { my ($self, $key) = @_; $self->get($self->__get_data->{prefix} . $key); } sub FIRSTKEY { my $self = shift; $self->__get_data->{prefix_keys} = [$self->keys($self->__get_data->{prefix} . '*')]; $self->NEXTKEY; } sub NEXTKEY { my $self = shift; my $key = shift @{ $self->__get_data->{prefix_keys} }; return unless defined $key; my $p = $self->__get_data->{prefix}; $key =~ s/^$p// if $p; return $key; } sub EXISTS { my ($self, $key) = @_; $self->exists($self->__get_data->{prefix} . $key); } sub DELETE { my ($self, $key) = @_; $self->del($self->__get_data->{prefix} . $key); } sub CLEAR { my ($self) = @_; $self->del($_) for $self->keys($self->__get_data->{prefix} . '*'); $self->__get_data->{prefix_keys} = []; } 1; ## End of Redis::Hash =head1 NAME Redis::Hash - tie Perl hashes to Redis hashes =head1 SYNOPSYS ## Create fake hash using keys like 'hash_prefix:KEY' tie %my_hash, 'Redis::Hash', 'hash_prefix', @Redis_new_parameters; ## Treat the entire Redis database as a hash tie %my_hash, 'Redis::Hash', undef, @Redis_new_parameters; $value = $my_hash{$key}; $my_hash{$key} = $value; @keys = keys %my_hash; @values = values %my_hash; %my_hash = reverse %my_hash; %my_hash = (); =head1 DESCRIPTION Ties a Perl hash to Redis. Note that it doesn't use Redis Hashes, but implements a fake hash using regular keys like "prefix:KEY". If no C is given, it will tie the entire Redis database as a hash. Future versions will also allow you to use real Redis hash structures. =cut libredis-fast-perl-0.22+dfsg/lib/Redis/Fast/List.pm000066400000000000000000000035321333534323000220300ustar00rootroot00000000000000package Redis::Fast::List; # ABSTRACT: tie Perl arrays to Redis lists # VERSION # AUTHORITY use strict; use warnings; use base qw/Redis::Fast Tie::Array/; sub TIEARRAY { my ($class, $list, @rest) = @_; my $self = $class->new(@rest); $self->__set_data($list); return $self; } sub FETCH { my ($self, $index) = @_; $self->lindex($self->__get_data, $index); } sub FETCHSIZE { my ($self) = @_; $self->llen($self->__get_data); } sub STORE { my ($self, $index, $value) = @_; $self->lset($self->__get_data, $index, $value); } sub STORESIZE { my ($self, $count) = @_; $self->ltrim($self->__get_data, 0, $count); # if $count > $self->FETCHSIZE; } sub CLEAR { my ($self) = @_; $self->del($self->__get_data); } sub PUSH { my $self = shift; my $list = $self->__get_data; $self->rpush($list, $_) for @_; } sub POP { my $self = shift; $self->rpop($self->__get_data); } sub SHIFT { my ($self) = @_; $self->lpop($self->__get_data); } sub UNSHIFT { my $self = shift; my $list = $self->__get_data; $self->lpush($list, $_) for @_; } sub SPLICE { my ($self, $offset, $length) = @_; $self->lrange($self->__get_data, $offset, $length); # FIXME rest of @_ ? } sub EXTEND { my ($self, $count) = @_; $self->rpush($self->__get_data, '') for ($self->FETCHSIZE .. ($count - 1)); } sub DESTROY { $_[0]->quit } 1; ## End of Redis::List =head1 NAME Redis::List - tie Perl arrays to Redis lists =head1 SYNOPSYS tie @my_list, 'Redis::List', 'list_name', @Redis_new_parameters; $value = $my_list[$index]; $my_list[$index] = $value; $count = @my_list; push @my_list, 'values'; $value = pop @my_list; unshift @my_list, 'values'; $value = shift @my_list; ## NOTE: fourth parameter of splice is *NOT* supported for now @other_list = splice(@my_list, 2, 3); @my_list = (); =cut libredis-fast-perl-0.22+dfsg/lib/Redis/Fast/Sentinel.pm000066400000000000000000000033261333534323000226770ustar00rootroot00000000000000package Redis::Fast::Sentinel; # ABSTRACT: Redis::Fast Sentinel interface use warnings; use strict; use Carp; use base qw(Redis::Fast); sub new { my ($class, %args) = @_; # these args are not allowed when contacting a sentinel delete @args{qw(sentinels service)}; $class->SUPER::new(%args); } sub get_service_address { my ($self, $service) = @_; my ($ip, $port) = $self->sentinel('get-master-addr-by-name', $service); defined $ip or return; $ip eq 'IDONTKNOW' and return $ip; return "$ip:$port"; } sub get_masters { map { +{ @$_ }; } @{ shift->sentinel('masters') || [] }; } 1; __END__ =head1 NAME Redis::Fast::Sentinel - connect to a Sentinel instance =head1 SYNOPSIS my $sentinel = Redis::Fast::Sentinel->new( ... ); my $service_address = $sentinel->get_service_address('mymaster'); my @masters = $sentinel->get_masters; =head1 DESCRIPTION This is a subclass of the Redis::Fast module, specialized into connecting to a Sentinel instance. Inherits from the C package; =head1 CONSTRUCTOR =head2 new See C in L. All parameters are supported, except C and C, which are silently ignored. =head1 METHODS All the methods of the C package are supported, plus the additional following methods: =head2 get_service_address Takes the name of a service as parameter, and returns either void (empty list) if the master couldn't be found, the string 'IDONTKNOW' if the service is in the sentinel config but cannot be reached, or the string C<"$ip:$port"> if the service were found. =head2 get_masters Returns a list of HashRefs representing all the master redis instances that this sentinel monitors. =cut libredis-fast-perl-0.22+dfsg/minil.toml000066400000000000000000000003121333534323000200440ustar00rootroot00000000000000badges = ['travis', 'metacpan'] module_maker = "ModuleBuild" [build] build_class = "builder::MyBuilder" [no_index] directory = ['t', 'xt', 'inc', 'share', 'eg', 'examples', 'author', 'builder', 'deps'] libredis-fast-perl-0.22+dfsg/scripts/000077500000000000000000000000001333534323000175325ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/scripts/publish.pl000077500000000000000000000005041333534323000215370ustar00rootroot00000000000000#!/usr/bin/perl use warnings; use strict; use Redis; my $pub = Redis->new(); my $channel = $ARGV[0] || die "usage: $0 channel\n"; print "#$channel > "; while () { chomp; $channel = $1 if s/\s*\#(\w+)\s*//; # remove channel from message my $nr = $pub->publish($channel, $_); print "#$channel $nr> "; } libredis-fast-perl-0.22+dfsg/scripts/reconnect_on_error.pl000066400000000000000000000042101333534323000237510ustar00rootroot00000000000000#!/usr/bin/perl use warnings; use strict; use 5.010; use lib 'lib'; use Test::More; use Redis::Fast; my $test_mode_sync=0; my $r = Redis::Fast->new( reconnect => 1, server => 'localhost:6380', reconnect_on_error => sub { my ($error, $ret, $command) = @_; $ret ||= ""; my $next_reconnect = -1; if ($error =~ /READONLY You can't write against a read only slave/) { $next_reconnect = 2; } diag "cb: error=$error, ret=$ret, command=$command, next=$next_reconnect"; return $next_reconnect; }, ); my $key = 'hoge'; my $ret = $r->get($key); ok !$ret, "no data" or diag $ret; sleep 30; my $value = 'fuga'; for my $i (1..30) { if ($test_mode_sync) { eval { $r->setex($key, 1, $value) }; if ($@) { diag "Sleep and next: tried $i time(s), ignore error=$@"; sleep 1; next; } $ret = $r->get($key); is $ret, $value, 'did reconnect with master' or die '[BUG] test code is broken'; done_testing(); exit 0; } else { my $error; $r->setex($key, 1, $value, sub { my ($ret, $_error) = @_; unless ($_error) { $ret = $r->get($key); is $ret, $value, 'did reconnect with master' or die '[BUG] test code is broken'; done_testing(); exit 0; } $error = $_error; }); $r->wait_all_responses; diag "Sleep and next: tried $i time(s), ignore error=$error"; sleep 1; } } ok 0, 'did not reconnect with master'; done_testing(); __END__ # Manual for an operation test ## NOTE: Turn off `close-on-slave-write` parameter for the ElastiCache Redis. ## 1. Set a redis cluster endpoint url to a server parameter. ## 2. Manual failover to hoge-redis2 aws elasticache modify-replication-group \ --replication-group-id hoge-redis-cluster \ --primary-cluster-id hoge-redis2 \ --apply-immediately ## 3. READONLY errors happen until reconnecting with a new master endpoint. ## 4. This tests are ok after a reconnection. libredis-fast-perl-0.22+dfsg/scripts/redis-benchmark.pl000077500000000000000000000015451333534323000231350ustar00rootroot00000000000000#!/usr/bin/perl use warnings; use strict; use Benchmark qw/:all/; use lib 'lib'; use Redis::Fast; use Redis::Fast::Hash; my $r = Redis::Fast->new; my %hash; tie %hash, 'Redis::Fast::Hash', 'hash'; my $i = 0; timethese( -5, { '00_ping' => sub { $r->ping }, '10_set' => sub { $r->set('foo', $i++) }, '11_set_r' => sub { $r->set('bench-' . rand(), rand()) }, '20_get' => sub { $r->get('foo') }, '21_get_r' => sub { $r->get('bench-' . rand()) }, '30_incr' => sub { $r->incr('counter') }, '30_incr_r' => sub { $r->incr('bench-' . rand()) }, '40_lpush' => sub { $r->lpush('mylist', 'bar') }, '40_lpush' => sub { $r->lpush('mylist', 'bar') }, '50_lpop' => sub { $r->lpop('mylist') }, '90_h_set' => sub { $hash{ 'test' . rand() } = rand() }, '90_h_get' => sub { my $a = $hash{ 'test' . rand() }; }, } ); libredis-fast-perl-0.22+dfsg/src/000077500000000000000000000000001333534323000166325ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/src/Redis__Fast.xs000066400000000000000000001150661333534323000214010ustar00rootroot00000000000000#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "hiredis.h" #include "async.h" #include #include #include #include #include #include #define MAX_ERROR_SIZE 256 #define WAIT_FOR_EVENT_OK 0 #define WAIT_FOR_EVENT_READ_TIMEOUT 1 #define WAIT_FOR_EVENT_WRITE_TIMEOUT 2 #define WAIT_FOR_EVENT_EXCEPTION 3 #define FLAG_INSIDE_TRANSACTION 0x01 #define FLAG_INSIDE_WATCH 0x02 //#define DEBUG #if defined(DEBUG) #define DEBUG_MSG(fmt, ...) \ do { \ fprintf(stderr, "[%s:%d:%s]: ", __FILE__, __LINE__, __func__); \ fprintf(stderr, fmt, __VA_ARGS__); \ fprintf(stderr, "\n"); \ } while(0) #else #define DEBUG_MSG(fmt, ...) #endif #define EQUALS_COMMAND(len, cmd, expected) ((len) == sizeof(expected) - 1 && memcmp(cmd, expected, sizeof(expected) - 1) == 0) typedef struct redis_fast_s { redisAsyncContext* ac; char* hostname; int port; char* path; char* error; int reconnect; int every; double cnx_timeout; double read_timeout; double write_timeout; int current_database; int need_reconnect; int is_connected; SV* on_connect; SV* on_build_sock; SV* data; SV* reconnect_on_error; double next_reconnect_on_error_at; int proccess_sub_count; int is_subscriber; int expected_subs; pid_t pid; int flags; } redis_fast_t, *Redis__Fast; typedef struct redis_fast_reply_s { SV* result; SV* error; } redis_fast_reply_t; typedef redis_fast_reply_t (*CUSTOM_DECODE)(Redis__Fast self, redisReply* reply, int collect_errors); typedef struct redis_fast_sync_cb_s { redis_fast_reply_t ret; int collect_errors; CUSTOM_DECODE custom_decode; int on_flags; int off_flags; } redis_fast_sync_cb_t; typedef struct redis_fast_async_cb_s { SV* cb; int collect_errors; CUSTOM_DECODE custom_decode; int on_flags; int off_flags; const void* command_name; STRLEN command_length; } redis_fast_async_cb_t; typedef struct redis_fast_subscribe_cb_s { Redis__Fast self; SV* cb; } redis_fast_subscribe_cb_t; #define WAIT_FOR_READ 0x01 #define WAIT_FOR_WRITE 0x02 typedef struct redis_fast_event_s { int flags; } redis_fast_event_t; static void AddRead(void *privdata) { redis_fast_event_t *e = (redis_fast_event_t*)privdata; e->flags |= WAIT_FOR_READ; DEBUG_MSG("flags = %x", e->flags); } static void DelRead(void *privdata) { redis_fast_event_t *e = (redis_fast_event_t*)privdata; e->flags &= ~WAIT_FOR_READ; DEBUG_MSG("flags = %x", e->flags); } static void AddWrite(void *privdata) { redis_fast_event_t *e = (redis_fast_event_t*)privdata; e->flags |= WAIT_FOR_WRITE; DEBUG_MSG("flags = %x", e->flags); } static void DelWrite(void *privdata) { redis_fast_event_t *e = (redis_fast_event_t*)privdata; e->flags &= ~WAIT_FOR_WRITE; DEBUG_MSG("flags = %x", e->flags); } static void Cleanup(void *privdata) { free(privdata); } static int Attach(redisAsyncContext *ac) { redis_fast_event_t *e; /* Nothing should be attached when something is already attached */ if (ac->ev.data != NULL) return REDIS_ERR; /* Create container for context and r/w events */ e = (redis_fast_event_t*)malloc(sizeof(*e)); e->flags = 0; /* Register functions to start/stop listening for events */ ac->ev.addRead = AddRead; ac->ev.delRead = DelRead; ac->ev.addWrite = AddWrite; ac->ev.delWrite = DelWrite; ac->ev.cleanup = Cleanup; ac->ev.data = e; return REDIS_OK; } static int wait_for_event(Redis__Fast self, double read_timeout, double write_timeout) { redisContext *c; int fd; redis_fast_event_t *e; struct pollfd pollfd; int rc; double timeout = -1; int timeout_mode = WAIT_FOR_EVENT_WRITE_TIMEOUT; int ms; if(self==NULL) return WAIT_FOR_EVENT_EXCEPTION; if(self->ac==NULL) return WAIT_FOR_EVENT_EXCEPTION; c = &(self->ac->c); fd = c->fd; e = (redis_fast_event_t*)self->ac->ev.data; if(e==NULL) return 0; if((e->flags & (WAIT_FOR_READ|WAIT_FOR_WRITE)) == (WAIT_FOR_READ|WAIT_FOR_WRITE)) { DEBUG_MSG("set READ and WRITE, compare read_timeout = %f and write_timeout = %f", read_timeout, write_timeout); if(read_timeout < 0 && write_timeout < 0) { timeout = -1; timeout_mode = WAIT_FOR_EVENT_WRITE_TIMEOUT; } else if(read_timeout < 0) { timeout = write_timeout; timeout_mode = WAIT_FOR_EVENT_WRITE_TIMEOUT; } else if(write_timeout < 0) { timeout = read_timeout; timeout_mode = WAIT_FOR_EVENT_READ_TIMEOUT; } else if(read_timeout < write_timeout) { timeout = read_timeout; timeout_mode = WAIT_FOR_EVENT_READ_TIMEOUT; } else { timeout = write_timeout; timeout_mode = WAIT_FOR_EVENT_WRITE_TIMEOUT; } } else if(e->flags & WAIT_FOR_READ) { DEBUG_MSG("set READ, read_timeout = %f", read_timeout); timeout = read_timeout; timeout_mode = WAIT_FOR_EVENT_READ_TIMEOUT; } else if(e->flags & WAIT_FOR_WRITE) { DEBUG_MSG("set WRITE, write_timeout = %f", write_timeout); timeout = write_timeout; timeout_mode = WAIT_FOR_EVENT_WRITE_TIMEOUT; } START_POLL: if (timeout < 0) { ms = -1; } else { ms = (int)(timeout * 1000 + 0.999); } DEBUG_MSG("select start, timeout is %f", timeout); pollfd.fd = fd; pollfd.events = 0; pollfd.revents = 0; if(e->flags & WAIT_FOR_READ) { pollfd.events |= POLLIN; } if(e->flags & WAIT_FOR_WRITE) { pollfd.events |= POLLOUT; } rc = poll(&pollfd, 1, ms); DEBUG_MSG("poll returns %d", rc); if(rc == 0) { DEBUG_MSG("%s", "timeout"); return timeout_mode; } if(rc < 0) { DEBUG_MSG("exception: %s", strerror(errno)); if( errno == EINTR ) { PERL_ASYNC_CHECK(); DEBUG_MSG("%s", "recieved interrupt. retry wait_for_event"); goto START_POLL; } return WAIT_FOR_EVENT_EXCEPTION; } if(self->ac && (pollfd.revents & POLLIN) != 0) { DEBUG_MSG("ready to %s", "read"); redisAsyncHandleRead(self->ac); } if(self->ac && (pollfd.revents & (POLLOUT|POLLHUP)) != 0) { DEBUG_MSG("ready to %s", "write"); redisAsyncHandleWrite(self->ac); } if((pollfd.revents & (POLLERR|POLLNVAL)) != 0) { DEBUG_MSG( "exception: %s%s", (pollfd.revents & POLLERR) ? "POLLERR " : "", (pollfd.revents & POLLNVAL) ? "POLLNVAL " : ""); return WAIT_FOR_EVENT_EXCEPTION; } DEBUG_MSG("%s", "finish"); return WAIT_FOR_EVENT_OK; } static void Redis__Fast_connect_cb(redisAsyncContext* c, int status) { Redis__Fast self = (Redis__Fast)c->data; DEBUG_MSG("connected status = %d", status); if(status != REDIS_OK) { // Connection Error!! // Redis context will close automatically self->ac = NULL; } else { self->is_connected = 1; } } static void Redis__Fast_disconnect_cb(redisAsyncContext* c, int status) { Redis__Fast self = (Redis__Fast)c->data; PERL_UNUSED_VAR(status); DEBUG_MSG("disconnected status = %d", status); self->ac = NULL; } static redisAsyncContext* __build_sock(Redis__Fast self) { redisAsyncContext *ac; double timeout; int res; DEBUG_MSG("%s", "start"); if(self->on_build_sock) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); call_sv(self->on_build_sock, G_DISCARD | G_NOARGS); FREETMPS; LEAVE; } if(self->path) { ac = redisAsyncConnectUnix(self->path); } else { ac = redisAsyncConnect(self->hostname, self->port); } if(ac == NULL) { DEBUG_MSG("%s", "allocation error"); return NULL; } if(ac->err) { DEBUG_MSG("connection error: %s", ac->errstr); redisAsyncFree(ac); return NULL; } ac->data = (void*)self; self->ac = ac; self->is_connected = 0; Attach(ac); redisAsyncSetConnectCallback(ac, (redisConnectCallback*)Redis__Fast_connect_cb); redisAsyncSetDisconnectCallback(ac, (redisDisconnectCallback*)Redis__Fast_disconnect_cb); // wait to connect... timeout = -1; if(self->cnx_timeout) { timeout = self->cnx_timeout; } while(!self->is_connected) { res = wait_for_event(self, timeout, timeout); if(self->ac == NULL) { // set is_connected flag to reconnect. // see https://github.com/shogo82148/Redis-Fast/issues/73 self->is_connected = 1; return NULL; } if(res != WAIT_FOR_EVENT_OK) { DEBUG_MSG("error: %d", res); redisAsyncFree(self->ac); // set is_connected flag to reconnect. // see https://github.com/shogo82148/Redis-Fast/issues/73 self->is_connected = 1; self->ac = NULL; return NULL; } } if(self->on_connect){ dSP; PUSHMARK(SP); call_sv(self->on_connect, G_DISCARD | G_NOARGS); } DEBUG_MSG("%s", "finsih"); return self->ac; } static int _wait_all_responses(Redis__Fast self) { DEBUG_MSG("%s", "start"); while(self->ac && self->ac->replies.tail) { int res = wait_for_event(self, self->read_timeout, self->write_timeout); if (res != WAIT_FOR_EVENT_OK) { DEBUG_MSG("error: %d", res); return res; } } DEBUG_MSG("%s", "finish"); return WAIT_FOR_EVENT_OK; } static void Redis__Fast_connect(Redis__Fast self) { struct timeval start, end; DEBUG_MSG("%s", "start"); if (self->ac) { redisAsyncFree(self->ac); self->ac = NULL; } self->flags = 0; //$self->{queue} = []; self->pid = getpid(); if(self->reconnect == 0) { __build_sock(self); if(!self->ac) { if(self->path) { snprintf(self->error, MAX_ERROR_SIZE, "Could not connect to Redis server at %s", self->path); } else { snprintf(self->error, MAX_ERROR_SIZE, "Could not connect to Redis server at %s:%d", self->hostname, self->port); } croak("%s", self->error); } return ; } // Reconnect... gettimeofday(&start, NULL); while (1) { double elapsed_time; if(__build_sock(self)) { // Connected! DEBUG_MSG("%s", "finish"); return; } gettimeofday(&end, NULL); elapsed_time = (end.tv_sec-start.tv_sec) + 1E-6 * (end.tv_usec-start.tv_usec); DEBUG_MSG("elasped time:%f, reconnect:%d", elapsed_time, self->reconnect); if( elapsed_time > self->reconnect) { if(self->path) { snprintf(self->error, MAX_ERROR_SIZE, "Could not connect to Redis server at %s", self->path); } else { snprintf(self->error, MAX_ERROR_SIZE, "Could not connect to Redis server at %s:%d", self->hostname, self->port); } DEBUG_MSG("%s", "timed out"); croak("%s", self->error); return; } DEBUG_MSG("%s", "failed to connect. wait..."); usleep(self->every); } DEBUG_MSG("%s", "finish"); } static void Redis__Fast_reconnect(Redis__Fast self) { DEBUG_MSG("%s", "start"); if(self->is_connected && !self->ac && self->reconnect) { DEBUG_MSG("%s", "connection not found. reconnect"); Redis__Fast_connect(self); } if(!self->ac) { DEBUG_MSG("%s", "Not connected to any server"); } DEBUG_MSG("%s", "finish"); } static redis_fast_reply_t Redis__Fast_decode_reply(Redis__Fast self, redisReply* reply, int collect_errors) { redis_fast_reply_t res = {NULL, NULL}; switch (reply->type) { case REDIS_REPLY_ERROR: res.error = sv_2mortal(newSVpvn(reply->str, reply->len)); break; case REDIS_REPLY_STRING: case REDIS_REPLY_STATUS: res.result = sv_2mortal(newSVpvn(reply->str, reply->len)); break; case REDIS_REPLY_INTEGER: res.result = sv_2mortal(newSViv(reply->integer)); break; case REDIS_REPLY_NIL: res.result = sv_2mortal(newSV(0)); break; case REDIS_REPLY_ARRAY: { AV* av = newAV(); size_t i; res.result = sv_2mortal(newRV_noinc((SV*)av)); for (i = 0; i < reply->elements; i++) { redis_fast_reply_t elem = Redis__Fast_decode_reply(self, reply->element[i], collect_errors); if(collect_errors) { AV* elem_av = (AV*)sv_2mortal((SV*)newAV()); if(elem.result) { av_push(elem_av, SvREFCNT_inc(elem.result)); } else { av_push(elem_av, newSV(0)); } if(elem.error) { av_push(elem_av, SvREFCNT_inc(elem.error)); } else { av_push(elem_av, newSV(0)); } av_push(av, newRV_inc((SV*)elem_av)); } else { if(elem.result) { av_push(av, SvREFCNT_inc(elem.result)); } else { av_push(av, newSV(0)); } if(elem.error && !res.error) { res.error = elem.error; } } } break; } } return res; } static int Redis__Fast_call_reconnect_on_error(Redis__Fast self, redis_fast_reply_t ret, const void *command_name, STRLEN command_length) { int _need_reconnect = 0; struct timeval current; double current_sec; SV* sv_ret; SV* sv_err; SV* sv_cmd; int count; if (ret.error == NULL) { return _need_reconnect; } if (self->reconnect_on_error == NULL) { return _need_reconnect; } gettimeofday(¤t, NULL); current_sec = current.tv_sec + 1E-6 * current.tv_usec; if( self->next_reconnect_on_error_at < 0 || self->next_reconnect_on_error_at < current_sec) { dSP; ENTER; SAVETMPS; sv_ret = ret.result ? ret.result : sv_2mortal(newSV(0)); sv_err = ret.error; sv_cmd = sv_2mortal(newSVpvn((const char*)command_name, command_length)); PUSHMARK(SP); XPUSHs(sv_err); XPUSHs(sv_ret); XPUSHs(sv_cmd); PUTBACK; count = call_sv(self->reconnect_on_error, G_SCALAR); SPAGAIN; if (count != 1) { croak("[BUG] retval count should be 1\n"); } _need_reconnect = POPi; PUTBACK; FREETMPS; LEAVE; } return _need_reconnect; } static void Redis__Fast_sync_reply_cb(redisAsyncContext* c, void* reply, void* privdata) { Redis__Fast self = (Redis__Fast)c->data; redis_fast_sync_cb_t *cbt = (redis_fast_sync_cb_t*)privdata; DEBUG_MSG("%p", (void*)privdata); if(reply) { self->flags = (self->flags | cbt->on_flags) & cbt->off_flags; if(cbt->custom_decode) { cbt->ret = (cbt->custom_decode)(self, (redisReply*)reply, cbt->collect_errors); } else { cbt->ret = Redis__Fast_decode_reply(self, (redisReply*)reply, cbt->collect_errors); } } else if(c->c.flags & REDIS_FREEING) { DEBUG_MSG("%s", "redis feeing"); Safefree(cbt); } else { DEBUG_MSG("connect error: %s", c->errstr); self->need_reconnect = 1; cbt->ret.result = NULL; cbt->ret.error = sv_2mortal( newSVpvn(c->errstr, strlen(c->errstr)) ); } DEBUG_MSG("%s", "finish"); } static void Redis__Fast_async_reply_cb(redisAsyncContext* c, void* reply, void* privdata) { Redis__Fast self = (Redis__Fast)c->data; redis_fast_async_cb_t *cbt = (redis_fast_async_cb_t*)privdata; if (reply) { self->flags = (self->flags | cbt->on_flags) & cbt->off_flags; { redis_fast_reply_t result; SV* sv_undef; dSP; ENTER; SAVETMPS; if(cbt->custom_decode) { result = (cbt->custom_decode)(self, (redisReply*)reply, cbt->collect_errors); } else { result = Redis__Fast_decode_reply(self, (redisReply*)reply, cbt->collect_errors); } sv_undef = sv_2mortal(newSV(0)); if(result.result == NULL) result.result = sv_undef; if(result.error == NULL) result.error = sv_undef; PUSHMARK(SP); XPUSHs(result.result); XPUSHs(result.error); PUTBACK; call_sv(cbt->cb, G_DISCARD); FREETMPS; LEAVE; } { if (0 < self->reconnect && !self->need_reconnect // Avoid useless cost when reconnect_on_error is not set. && self->reconnect_on_error != NULL) { redis_fast_reply_t result; if(cbt->custom_decode) { result = (cbt->custom_decode)( self, (redisReply*)reply, cbt->collect_errors ); } else { result = Redis__Fast_decode_reply( self, (redisReply*)reply, cbt->collect_errors ); } self->need_reconnect = Redis__Fast_call_reconnect_on_error( self, result, cbt->command_name, cbt->command_length ); } } } SvREFCNT_dec(cbt->cb); Safefree(cbt); } static void Redis__Fast_subscribe_cb(redisAsyncContext* c, void* reply, void* privdata) { int is_need_free = 0; Redis__Fast self = (Redis__Fast)c->data; redis_fast_subscribe_cb_t *cbt = (redis_fast_subscribe_cb_t*)privdata; redisReply* r = (redisReply*)reply; SV* sv_undef; DEBUG_MSG("%s", "start"); if(!cbt) { DEBUG_MSG("%s", "cbt is empty finished"); return ; } if (r) { char* stype = r->element[0]->str; int pvariant = (tolower(stype[0]) == 'p') ? 1 : 0; redis_fast_reply_t res; dSP; ENTER; SAVETMPS; res = Redis__Fast_decode_reply(self, r, 0); if (strcasecmp(stype+pvariant,"subscribe") == 0) { DEBUG_MSG("%s %s %lld", r->element[0]->str, r->element[1]->str, r->element[2]->integer); self->is_subscriber = r->element[2]->integer; self->expected_subs--; } else if (strcasecmp(stype+pvariant,"unsubscribe") == 0) { DEBUG_MSG("%s %s %lld", r->element[0]->str, r->element[1]->str, r->element[2]->integer); self->is_subscriber = r->element[2]->integer; is_need_free = 1; self->expected_subs--; } else { DEBUG_MSG("%s %s", r->element[0]->str, r->element[1]->str); self->proccess_sub_count++; } sv_undef = sv_2mortal(newSV(0)); if(res.result == NULL) res.result = sv_undef; if(res.error == NULL) res.error = sv_undef; PUSHMARK(SP); XPUSHs(res.result); XPUSHs(res.error); PUTBACK; call_sv(cbt->cb, G_DISCARD); FREETMPS; LEAVE; } else { DEBUG_MSG("connect error: %s", c->errstr); is_need_free = 1; } if(is_need_free) { // destroy private data DEBUG_MSG("destroy %p", cbt); if(cbt->cb) { SvREFCNT_dec(cbt->cb); cbt->cb = NULL; } Safefree(cbt); } DEBUG_MSG("%s", "finish"); } static void Redis__Fast_quit(Redis__Fast self) { redis_fast_sync_cb_t *cbt; if(!self->ac) { return; } Newx(cbt, sizeof(redis_fast_sync_cb_t), redis_fast_sync_cb_t); cbt->ret.result = NULL; cbt->ret.error = NULL; cbt->custom_decode = NULL; // initialize, or self->flags will be corrupted. cbt->on_flags = 0; cbt->off_flags = 0; redisAsyncCommand( self->ac, Redis__Fast_sync_reply_cb, cbt, "QUIT" ); redisAsyncDisconnect(self->ac); if(_wait_all_responses(self) == WAIT_FOR_EVENT_OK) { DEBUG_MSG("%s", "wait_all_responses ok"); if(cbt->ret.result || cbt->ret.error) Safefree(cbt); } else { DEBUG_MSG("%s", "wait_all_responses not ok"); if(cbt->ret.result || cbt->ret.error) Safefree(cbt); } DEBUG_MSG("%s", "finish"); self->ac = NULL; } static redis_fast_reply_t Redis__Fast_run_cmd(Redis__Fast self, int collect_errors, CUSTOM_DECODE custom_decode, SV* cb, int argc, const char** argv, size_t* argvlen) { redis_fast_reply_t ret = {NULL, NULL}; int on_flags = 0, off_flags = ~0; DEBUG_MSG("start %s", argv[0]); DEBUG_MSG("pid check: previous pid is %d, now %d", self->pid, getpid()); if(self->pid != getpid()) { DEBUG_MSG("%s", "pid changed. create new connection.."); Redis__Fast_connect(self); } if(EQUALS_COMMAND(argvlen[0], argv[0], "MULTI")) { on_flags = FLAG_INSIDE_TRANSACTION; } else if(EQUALS_COMMAND(argvlen[0], argv[0], "EXEC") || EQUALS_COMMAND(argvlen[0], argv[0], "DISCARD")) { off_flags = ~(FLAG_INSIDE_TRANSACTION | FLAG_INSIDE_WATCH); } else if(EQUALS_COMMAND(argvlen[0], argv[0], "WATCH")) { on_flags = FLAG_INSIDE_WATCH; } else if(EQUALS_COMMAND(argvlen[0], argv[0], "UNWATCH")) { off_flags = ~FLAG_INSIDE_WATCH; } if(cb) { redis_fast_async_cb_t *cbt; Newx(cbt, sizeof(redis_fast_async_cb_t), redis_fast_async_cb_t); cbt->cb = SvREFCNT_inc(cb); cbt->custom_decode = custom_decode; cbt->collect_errors = collect_errors; cbt->on_flags = on_flags; cbt->off_flags = off_flags; cbt->command_name = argv[0]; cbt->command_length = argvlen[0]; redisAsyncCommandArgv( self->ac, Redis__Fast_async_reply_cb, cbt, argc, argv, argvlen ); ret.result = sv_2mortal(newSViv(1)); } else { redis_fast_sync_cb_t *cbt; int i, cnt = (self->reconnect == 0 ? 1 : 2); int res = WAIT_FOR_EVENT_OK; for(i = 0; i < cnt; i++) { Newx(cbt, sizeof(redis_fast_sync_cb_t), redis_fast_sync_cb_t); self->need_reconnect = 0; cbt->ret.result = NULL; cbt->ret.error = NULL; cbt->custom_decode = custom_decode; cbt->collect_errors = collect_errors; cbt->on_flags = on_flags; cbt->off_flags = off_flags; DEBUG_MSG("%s", "send command in sync mode"); redisAsyncCommandArgv( self->ac, Redis__Fast_sync_reply_cb, cbt, argc, argv, argvlen ); DEBUG_MSG("%s", "waiting response"); res = _wait_all_responses(self); if(res == WAIT_FOR_EVENT_OK && !self->need_reconnect) { int _need_reconnect = 0; if (1 < cnt - i) { _need_reconnect = Redis__Fast_call_reconnect_on_error( self, cbt->ret, argv[0], argvlen[0] ); // Should be quit before reconnect if (_need_reconnect) { Redis__Fast_quit(self); } } if (!_need_reconnect) { ret = cbt->ret; if(cbt->ret.result || cbt->ret.error) Safefree(cbt); DEBUG_MSG("finish %s", argv[0]); return ret; } } if( res == WAIT_FOR_EVENT_READ_TIMEOUT ) break; if(self->flags & (FLAG_INSIDE_TRANSACTION | FLAG_INSIDE_WATCH)) { croak("reconnect disabled inside transaction or watch"); } Redis__Fast_reconnect(self); } if( res == WAIT_FOR_EVENT_OK && (cbt->ret.result || cbt->ret.error) ) Safefree(cbt); // else destructor will release cbt if(res == WAIT_FOR_EVENT_READ_TIMEOUT || res == WAIT_FOR_EVENT_WRITE_TIMEOUT) { snprintf(self->error, MAX_ERROR_SIZE, "Error while reading from Redis server: %s", strerror(EAGAIN)); errno = EAGAIN; croak("%s", self->error); } if(!self->ac) { croak("Not connected to any server"); } } DEBUG_MSG("Finish %s", argv[0]); return ret; } static redis_fast_reply_t Redis__Fast_keys_custom_decode(Redis__Fast self, redisReply* reply, int collect_errors) { // TODO: Support redis <= 1.2.6 return Redis__Fast_decode_reply(self, reply, collect_errors); } static redis_fast_reply_t Redis__Fast_info_custom_decode(Redis__Fast self, redisReply* reply, int collect_errors) { redis_fast_reply_t res = {NULL, NULL}; if(reply->type == REDIS_REPLY_STRING || reply->type == REDIS_REPLY_STATUS) { HV* hv = (HV*)sv_2mortal((SV*)newHV()); char* str = reply->str; size_t len = reply->len; res.result = newRV_inc((SV*)hv); while(len != 0) { const char* line = (char*)memchr(str, '\r', len); const char* sep; size_t linelen; if(line == NULL) { linelen = len; } else { linelen = line - str; } sep = (char*)memchr(str, ':', linelen); if(str[0] != '#' && sep != NULL) { SV* val; SV** ret; size_t keylen; keylen = sep - str; val = newSVpvn(sep + 1, linelen - keylen - 1); ret = hv_store(hv, str, keylen, val, 0); if (ret == NULL) { SvREFCNT_dec(val); croak("failed to hv_store"); } } if(line == NULL) { break; } else { len -= linelen + 2; str += linelen + 2; } } } else { res = Redis__Fast_decode_reply(self, reply, collect_errors); } return res; } MODULE = Redis::Fast PACKAGE = Redis::Fast SV* _new(char* cls); PREINIT: redis_fast_t* self; CODE: { DEBUG_MSG("%s", "start"); Newxz(self, sizeof(redis_fast_t), redis_fast_t); self->error = (char*)malloc(MAX_ERROR_SIZE); self->reconnect_on_error = NULL; self->next_reconnect_on_error_at = -1; ST(0) = sv_newmortal(); sv_setref_pv(ST(0), cls, (void*)self); DEBUG_MSG("return %p", ST(0)); XSRETURN(1); } OUTPUT: RETVAL int __set_reconnect(Redis::Fast self, int val) CODE: { RETVAL = self->reconnect = val; } OUTPUT: RETVAL int __get_reconnect(Redis::Fast self) CODE: { RETVAL = self->reconnect; } OUTPUT: RETVAL int __set_every(Redis::Fast self, int val) CODE: { RETVAL = self->every = val; } OUTPUT: RETVAL int __get_every(Redis::Fast self) CODE: { RETVAL = self->every; } OUTPUT: RETVAL double __set_cnx_timeout(Redis::Fast self, double val) CODE: { RETVAL = self->cnx_timeout = val; } OUTPUT: RETVAL double __get_cnx_timeout(Redis::Fast self) CODE: { RETVAL = self->cnx_timeout; } OUTPUT: RETVAL double __set_read_timeout(Redis::Fast self, double val) CODE: { RETVAL = self->read_timeout = val; } OUTPUT: RETVAL double __get_read_timeout(Redis::Fast self) CODE: { RETVAL = self->read_timeout; } OUTPUT: RETVAL double __set_write_timeout(Redis::Fast self, double val) CODE: { RETVAL = self->write_timeout = val; } OUTPUT: RETVAL double __get_write_timeout(Redis::Fast self) CODE: { RETVAL = self->write_timeout; } OUTPUT: RETVAL int __set_current_database(Redis::Fast self, int val) CODE: { RETVAL = self->current_database = val; } OUTPUT: RETVAL int __get_current_database(Redis::Fast self) CODE: { RETVAL = self->current_database; } OUTPUT: RETVAL int __sock(Redis::Fast self) CODE: { RETVAL = self->ac ? self->ac->c.fd : 0; } OUTPUT: RETVAL int __get_port(Redis::Fast self) CODE: { struct sockaddr_in addr; socklen_t len; len = sizeof( addr ); getsockname( self->ac->c.fd, ( struct sockaddr *)&addr, &len ); RETVAL = addr.sin_port; } OUTPUT: RETVAL void __set_on_connect(Redis::Fast self, SV* func) CODE: { self->on_connect = SvREFCNT_inc(func); } void __set_on_build_sock(Redis::Fast self, SV* func) CODE: { self->on_build_sock = SvREFCNT_inc(func); } void __set_data(Redis::Fast self, SV* data) CODE: { self->data = SvREFCNT_inc(data); } void __get_data(Redis::Fast self) CODE: { ST(0) = self->data; XSRETURN(1); } void __set_reconnect_on_error(Redis::Fast self, SV* func) CODE: { self->reconnect_on_error = SvREFCNT_inc(func); } double __set_next_reconnect_on_error_at(Redis::Fast self, double val) CODE: { struct timeval current; double current_sec; if ( -1 < val ) { gettimeofday(¤t, NULL); current_sec = current.tv_sec + 1E-6 * current.tv_usec; val += current_sec; } RETVAL = self->next_reconnect_on_error_at = val; } OUTPUT: RETVAL void is_subscriber(Redis::Fast self) CODE: { ST(0) = sv_2mortal(newSViv(self->is_subscriber)); XSRETURN(1); } void DESTROY(Redis::Fast self); CODE: { DEBUG_MSG("%s", "start"); if (self->ac) { DEBUG_MSG("%s", "free ac"); redisAsyncFree(self->ac); self->ac = NULL; } if(self->hostname) { DEBUG_MSG("%s", "free hostname"); free(self->hostname); self->hostname = NULL; } if(self->path) { DEBUG_MSG("%s", "free path"); free(self->path); self->path = NULL; } if(self->error) { DEBUG_MSG("%s", "free error"); free(self->error); self->error = NULL; } if(self->on_connect) { DEBUG_MSG("%s", "free on_connect"); SvREFCNT_dec(self->on_connect); self->on_connect = NULL; } if(self->on_build_sock) { DEBUG_MSG("%s", "free on_build_sock"); SvREFCNT_dec(self->on_build_sock); self->on_build_sock = NULL; } if(self->data) { DEBUG_MSG("%s", "free data"); SvREFCNT_dec(self->data); self->data = NULL; } if(self->reconnect_on_error) { DEBUG_MSG("%s", "free reconnect_on_error"); SvREFCNT_dec(self->reconnect_on_error); self->reconnect_on_error = NULL; } Safefree(self); DEBUG_MSG("%s", "finish"); } void __connection_info(Redis::Fast self, char* hostname, int port = 6379) CODE: { if(self->hostname) { free(self->hostname); self->hostname = NULL; } if(self->path) { free(self->path); self->path = NULL; } if(hostname) { self->hostname = (char*)malloc(strlen(hostname) + 1); strcpy(self->hostname, hostname); } self->port = port; } void __connection_info_unix(Redis::Fast self, char* path) CODE: { if(self->hostname) { free(self->hostname); self->hostname = NULL; } if(self->path) { free(self->path); self->path = NULL; } if(path) { self->path = (char*)malloc(strlen(path) + 1); strcpy(self->path, path); } } void connect(Redis::Fast self) CODE: { Redis__Fast_connect(self); } void wait_all_responses(Redis::Fast self) CODE: { int res = _wait_all_responses(self); if(res != WAIT_FOR_EVENT_OK) { croak("Error while reading from Redis server"); } if (0 < self->reconnect && self->need_reconnect) { // Should be quit before reconnect Redis__Fast_quit(self); Redis__Fast_reconnect(self); self->need_reconnect = 0; } } void wait_one_response(Redis::Fast self) CODE: { int res = _wait_all_responses(self); if(res != WAIT_FOR_EVENT_OK) { croak("Error while reading from Redis server"); } if (0 < self->reconnect && self->need_reconnect) { // Should be quit before reconnect Redis__Fast_quit(self); Redis__Fast_reconnect(self); self->need_reconnect = 0; } } void __std_cmd(Redis::Fast self, ...) PREINIT: redis_fast_reply_t ret; SV* cb; char** argv; size_t* argvlen; STRLEN len; int argc, i, collect_errors; CODE: { Redis__Fast_reconnect(self); if(!self->ac) { croak("Not connected to any server"); } cb = ST(items - 1); if (SvROK(cb) && SvTYPE(SvRV(cb)) == SVt_PVCV) { argc = items - 2; } else { cb = NULL; argc = items - 1; } Newx(argv, sizeof(char*) * argc, char*); Newx(argvlen, sizeof(size_t) * argc, size_t); for (i = 0; i < argc; i++) { if(!sv_utf8_downgrade(ST(i + 1), 1)) { croak("command sent is not an octet sequence in the native encoding (Latin-1). Consider using debug mode to see the command itself."); } argv[i] = SvPV(ST(i + 1), len); argvlen[i] = len; } collect_errors = 0; if(cb && EQUALS_COMMAND(argvlen[0], argv[0], "EXEC")) collect_errors = 1; ret = Redis__Fast_run_cmd(self, collect_errors, NULL, cb, argc, (const char**)argv, argvlen); Safefree(argv); Safefree(argvlen); ST(0) = ret.result ? ret.result : sv_2mortal(newSV(0)); ST(1) = ret.error ? ret.error : sv_2mortal(newSV(0)); XSRETURN(2); } void __quit(Redis::Fast self) CODE: { DEBUG_MSG("%s", "start QUIT"); if(self->ac) { Redis__Fast_quit(self); ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1); } else { DEBUG_MSG("%s", "finish. there is no connection."); XSRETURN(0); } } void __shutdown(Redis::Fast self) CODE: { DEBUG_MSG("%s", "start SHUTDOWN"); if(self->ac) { redisAsyncCommand( self->ac, NULL, NULL, "SHUTDOWN" ); redisAsyncDisconnect(self->ac); _wait_all_responses(self); self->is_connected = 0; self->ac = NULL; ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1); } else { DEBUG_MSG("%s", "redis server has alread shutdown"); XSRETURN(0); } } void __keys(Redis::Fast self, ...) PREINIT: redis_fast_reply_t ret; SV* cb; char** argv; size_t* argvlen; STRLEN len; int argc, i; CODE: { Redis__Fast_reconnect(self); cb = ST(items - 1); if (SvROK(cb) && SvTYPE(SvRV(cb)) == SVt_PVCV) { argc = items - 1; } else { cb = NULL; argc = items; } Newx(argv, sizeof(char*) * argc, char*); Newx(argvlen, sizeof(size_t) * argc, size_t); argv[0] = "KEYS"; argvlen[0] = 4; for (i = 1; i < argc; i++) { argv[i] = SvPV(ST(i), len); argvlen[i] = len; } ret = Redis__Fast_run_cmd(self, 0, Redis__Fast_keys_custom_decode, cb, argc, (const char**)argv, argvlen); Safefree(argv); Safefree(argvlen); ST(0) = ret.result ? ret.result : sv_2mortal(newSV(0)); ST(1) = ret.error ? ret.error : sv_2mortal(newSV(0)); XSRETURN(2); } void __info(Redis::Fast self, ...) PREINIT: redis_fast_reply_t ret; SV* cb; char** argv; size_t* argvlen; STRLEN len; int argc, i; CODE: { Redis__Fast_reconnect(self); cb = ST(items - 1); if (SvROK(cb) && SvTYPE(SvRV(cb)) == SVt_PVCV) { argc = items - 1; } else { cb = NULL; argc = items; } Newx(argv, sizeof(char*) * argc, char*); Newx(argvlen, sizeof(size_t) * argc, size_t); argv[0] = "INFO"; argvlen[0] = 4; for (i = 1; i < argc; i++) { argv[i] = SvPV(ST(i), len); argvlen[i] = len; } ret = Redis__Fast_run_cmd(self, 0, Redis__Fast_info_custom_decode, cb, argc, (const char**)argv, argvlen); Safefree(argv); Safefree(argvlen); ST(0) = ret.result ? ret.result : sv_2mortal(newSV(0)); ST(1) = ret.error ? ret.error : sv_2mortal(newSV(0)); XSRETURN(2); } void __send_subscription_cmd(Redis::Fast self, ...) PREINIT: SV* cb; char** argv; size_t* argvlen; STRLEN len; int argc, i; redis_fast_subscribe_cb_t* cbt; int pvariant; CODE: { int cnt = (self->reconnect == 0 ? 1 : 2); DEBUG_MSG("%s", "start"); Redis__Fast_reconnect(self); if(!self->is_subscriber) { _wait_all_responses(self); } cb = ST(items - 1); if (SvROK(cb) && SvTYPE(SvRV(cb)) == SVt_PVCV) { argc = items - 2; } else { cb = NULL; argc = items - 1; } Newx(argv, sizeof(char*) * argc, char*); Newx(argvlen, sizeof(size_t) * argc, size_t); for (i = 0; i < argc; i++) { argv[i] = SvPV(ST(i+1), len); argvlen[i] = len; DEBUG_MSG("argv[%d] = %s", i, argv[i]); } for(i = 0; i < cnt; i++) { pvariant = tolower(argv[0][0]) == 'p'; if (strcasecmp(argv[0]+pvariant,"unsubscribe") != 0) { DEBUG_MSG("%s", "command is not unsubscribe"); Newx(cbt, sizeof(redis_fast_subscribe_cb_t), redis_fast_subscribe_cb_t); cbt->self = self; cbt->cb = SvREFCNT_inc(cb); } else { DEBUG_MSG("%s", "command is unsubscribe"); cbt = NULL; } redisAsyncCommandArgv( self->ac, cbt ? Redis__Fast_subscribe_cb : NULL, cbt, argc, (const char**)argv, argvlen ); self->expected_subs = argc - 1; while(self->expected_subs > 0 && wait_for_event(self, self->read_timeout, self->write_timeout) == WAIT_FOR_EVENT_OK) ; if(self->expected_subs == 0) break; Redis__Fast_reconnect(self); } Safefree(argv); Safefree(argvlen); DEBUG_MSG("%s", "finish"); XSRETURN(0); } void wait_for_messages(Redis::Fast self, double timeout = -1) CODE: { int i, cnt = (self->reconnect == 0 ? 1 : 2); int res = WAIT_FOR_EVENT_OK; DEBUG_MSG("%s", "start"); self->proccess_sub_count = 0; for(i = 0; i < cnt; i++) { while((res = wait_for_event(self, timeout, timeout)) == WAIT_FOR_EVENT_OK) ; if(res == WAIT_FOR_EVENT_READ_TIMEOUT || res == WAIT_FOR_EVENT_WRITE_TIMEOUT) break; Redis__Fast_reconnect(self); } if(res == WAIT_FOR_EVENT_EXCEPTION) { if(!self->ac) { DEBUG_MSG("%s", "Connection not found"); croak("EOF from server"); } else if(self->ac->c.err == REDIS_ERR_EOF) { DEBUG_MSG("hiredis returns error: %s", self->ac->c.errstr); croak("EOF from server"); } else { DEBUG_MSG("hiredis returns error: %s", self->ac->c.errstr); snprintf(self->error, MAX_ERROR_SIZE, "[WAIT_FOR_MESSAGES] %s", self->ac->c.errstr); croak("%s", self->error); } } ST(0) = sv_2mortal(newSViv(self->proccess_sub_count)); DEBUG_MSG("finish with %d", res); XSRETURN(1); } void __wait_for_event(Redis::Fast self, double timeout = -1) CODE: { DEBUG_MSG("%s", "start"); wait_for_event(self, timeout, timeout); DEBUG_MSG("%s", "finish"); XSRETURN(0); } libredis-fast-perl-0.22+dfsg/t/000077500000000000000000000000001333534323000163065ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/t/01-basic.t000077500000000000000000000261561333534323000200070ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } my $n; is( exception { $n = Redis::Fast->new(server => $srv, name => 'no_auto_connect', no_auto_connect_on_new => 1) }, undef, 'Got an unconnected object', ); ok(!$n->ping, "ping doesn't work yet"); $n->connect; ok($n->ping, "ping works after connection"); my $o; is( exception { $o = Redis::Fast->new(server => $srv, name => 'my_name_is_glorious') }, undef, 'connected to our test redis-server', ); ok($o->ping, 'ping'); ## Commands operating on string values ok($o->set(foo => 'bar'), 'set foo => bar'); ok(!$o->setnx(foo => 'bar'), 'setnx foo => bar fails'); cmp_ok($o->get('foo'), 'eq', 'bar', 'get foo = bar'); ok($o->set(foo => ''), 'set foo => ""'); cmp_ok($o->get('foo'), 'eq', '', 'get foo = ""'); ok($o->set(foo => 'baz'), 'set foo => baz'); cmp_ok($o->get('foo'), 'eq', 'baz', 'get foo = baz'); my $euro = "\x{20ac}"; ok ord($euro) > 255, "assume \$eur is wide character"; ok ! eval { $o->set(utf8 => $euro); 1 }, "accepts only binary data, thus crashes on strings with characters > 255"; like "$@", qr/command sent is not an octet sequence in the native encoding/i, ".. and crashes on syswrite call"; ok ! defined $o->get('utf8'), ".. and does not write actual data"; ok($o->set('test-undef' => 42), 'set test-undef'); ok($o->exists('test-undef'), 'exists undef'); # Big sized keys for my $size (10_000, 100_000, 500_000, 1_000_000, 2_500_000) { my $v = 'a' x $size; ok($o->set('big_key', $v), "set with value size $size ok"); is($o->get('big_key'), $v, "... and get was ok to"); } $o->del('non-existant'); ok(!$o->exists('non-existant'), 'exists non-existant'); ok(!defined $o->get('non-existant'), 'get non-existant'); my $key_next = 3; ok($o->set('key-next' => 0), 'key-next = 0'); ok($o->set('key-left' => $key_next), 'key-left'); is_deeply([$o->mget('foo', 'key-next', 'key-left')], ['baz', 0, 3], 'mget'); my @keys; foreach my $id (0 .. $key_next) { my $key = 'key-' . $id; push @keys, $key; ok($o->set($key => $id), "set $key"); ok($o->exists($key), "exists $key"); is($o->get($key), $id, "get $key"); cmp_ok($o->incr('key-next'), '==', $id + 1, 'incr'); cmp_ok($o->decr('key-left'), '==', $key_next - $id - 1, 'decr'); } is($o->get('key-next'), $key_next + 1, 'key-next'); ok($o->set('test-incrby', 0), 'test-incrby'); ok($o->set('test-decrby', 0), 'test-decry'); foreach (1 .. 3) { is($o->incrby('test-incrby', 3), $_ * 3, 'incrby 3'); is($o->decrby('test-decrby', 7), -($_ * 7), 'decrby 7'); } ok($o->del($_), "del $_") foreach map {"key-$_"} ('next', 'left'); ok(!$o->del('non-existing'), 'del non-existing'); cmp_ok($o->type('foo'), 'eq', 'string', 'type'); is($o->keys('key-*'), $key_next + 1, 'key-*'); is_deeply([sort $o->keys('key-*')], [sort @keys], 'keys'); ok(my $key = $o->randomkey, 'randomkey'); ok($o->rename('test-incrby', 'test-renamed'), 'rename'); ok($o->exists('test-renamed'), 'exists test-renamed'); eval { $o->rename('test-decrby', 'test-renamed', 1) }; ok($@, 'rename to existing key'); ok(my $nr_keys = $o->dbsize, 'dbsize'); like( exception { $o->lpush('foo', 'bar') }, qr/\[lpush\] (?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value,/, 'Error responses throw exception' ); ## Commands operating on lists my $list = 'test-list'; $o->del($list); ok($o->rpush($list => "r$_"), 'rpush') foreach (1 .. 3); ok($o->lpush($list => "l$_"), 'lpush') foreach (1 .. 2); cmp_ok($o->type($list), 'eq', 'list', 'type'); cmp_ok($o->llen($list), '==', 5, 'llen'); is_deeply([$o->lrange($list, 0, 1)], ['l2', 'l1'], 'lrange'); ok($o->ltrim($list, 1, 2), 'ltrim'); cmp_ok($o->llen($list), '==', 2, 'llen after ltrim'); cmp_ok($o->lindex($list, 0), 'eq', 'l1', 'lindex'); cmp_ok($o->lindex($list, 1), 'eq', 'r1', 'lindex'); ok($o->lset($list, 0, 'foo'), 'lset'); cmp_ok($o->lindex($list, 0), 'eq', 'foo', 'verified'); ok($o->lrem($list, 1, 'foo'), 'lrem'); cmp_ok($o->llen($list), '==', 1, 'llen after lrem'); cmp_ok($o->lpop($list), 'eq', 'r1', 'lpop'); ok(!$o->rpop($list), 'rpop'); ## Commands operating on sets my $set = 'test-set'; $o->del($set); ok($o->sadd($set, 'foo'), 'sadd'); ok(!$o->sadd($set, 'foo'), 'sadd'); cmp_ok($o->scard($set), '==', 1, 'scard'); ok($o->sismember($set, 'foo'), 'sismember'); cmp_ok($o->type($set), 'eq', 'set', 'type is set'); ok($o->srem($set, 'foo'), 'srem'); ok(!$o->srem($set, 'foo'), 'srem again'); cmp_ok($o->scard($set), '==', 0, 'scard'); $o->del($_) foreach qw( test-set1 test-set2 ); $o->sadd('test-set1', $_) foreach ('foo', 'bar', 'baz'); $o->sadd('test-set2', $_) foreach ('foo', 'baz', 'xxx'); my $inter = [sort('foo', 'baz')]; is_deeply([sort $o->sinter('test-set1', 'test-set2')], $inter, 'sinter'); ok($o->sinterstore('test-set-inter', 'test-set1', 'test-set2'), 'sinterstore'); cmp_ok($o->scard('test-set-inter'), '==', $#$inter + 1, 'cardinality of intersection'); is_deeply([$o->sdiff('test-set1', 'test-set2')], ['bar'], 'sdiff'); ok($o->sdiffstore(qw( test-set-diff test-set1 test-set2 )), 'sdiffstore'); is($o->scard('test-set-diff'), 1, 'cardinality of diff'); my @union = sort qw( foo bar baz xxx ); is_deeply([sort $o->sunion(qw( test-set1 test-set2 ))], \@union, 'sunion'); ok($o->sunionstore(qw( test-set-union test-set1 test-set2 )), 'sunionstore'); is($o->scard('test-set-union'), scalar(@union), 'cardinality of union'); my $first_rand = $o->srandmember('test-set-union'); ok(defined $first_rand, 'srandmember result is defined'); ok(scalar grep { $_ eq $first_rand } @union, 'srandmember'); my $second_rand = $o->spop('test-set-union'); ok(defined $first_rand, 'spop result is defined'); ok(scalar grep { $_ eq $second_rand } @union, 'spop'); is($o->scard('test-set-union'), scalar(@union) - 1, 'new cardinality of union'); $o->del('test_set3'); my @test_set3 = sort qw( foo bar baz ); $o->sadd('test-set3', $_) foreach @test_set3; is_deeply([sort $o->smembers('test-set3')], \@test_set3, 'smembers'); $o->del('test-set4'); $o->smove(qw( test-set3 test-set4 ), $_) foreach @test_set3; is($o->scard('test-set3'), 0, 'repeated smove depleted source'); is($o->scard('test-set4'), scalar(@test_set3), 'repeated smove populated destination'); is_deeply([sort $o->smembers('test-set4')], \@test_set3, 'smembers'); ## Commands operating on zsets (sorted sets) # TODO: ZUNIONSTORE, ZINTERSTORE, SORT, tests w/multiple values having the same score my $zset = 'test-zset'; $o->del($zset); ok($o->zadd($zset, 0, 'foo')); ok(!$o->zadd($zset, 1, 'foo')); # 0 returned because foo is already in the set is($o->zscore($zset, 'foo'), 1); ok($o->zincrby($zset, 1, 'foo')); is($o->zscore($zset, 'foo'), 2); ok($o->zincrby($zset, 1, 'bar')); is($o->zscore($zset, 'bar'), 1); # bar was new, so its score got set to the increment SKIP: { eval { $o->zrank($zset, 'bar') }; skip "zrank not implemented in this redis", 4 if $@ && $@ =~ /unknown command/; is($o->zrank($zset, 'bar'), 0); is($o->zrank($zset, 'foo'), 1); is($o->zrevrank($zset, 'bar'), 1); is($o->zrevrank($zset, 'foo'), 0); } ok($o->zadd($zset, 2.1, 'baz')); # we now have bar foo baz is_deeply([$o->zrange($zset, 0, 1)], [qw/bar foo/]); is_deeply([$o->zrevrange($zset, 0, 1)], [qw/baz foo/]); my $withscores = { $o->zrevrange($zset, 0, 1, 'WITHSCORES') }; # this uglyness gets around floating point weirdness in the return (I.E. 2.1000000000000001); my $rounded_withscores = { map { $_ => 0 + sprintf("%0.5f", $withscores->{$_}) } keys %$withscores }; is_deeply($rounded_withscores, { baz => 2.1, foo => 2 }); is_deeply([$o->zrangebyscore($zset, 2, 3)], [qw/foo baz/]); SKIP: { eval { $o->zcount($zset, 2, 3) }; skip "zcount not implemented in this redis", 1 if $@ && $@ =~ /unknown command/; is($o->zcount($zset, 2, 3), 2); } is($o->zcard($zset), 3); ok($o->del($zset)); # cleanup my $score = 0.1; my @zkeys = (qw/foo bar baz qux quux quuux quuuux quuuuux/); ok($o->zadd($zset, $score++, $_)) for @zkeys; is_deeply([$o->zrangebyscore($zset, 0, 8)], \@zkeys); SKIP: { my $retval = eval { $o->zremrangebyrank($zset, 5, 8) }; skip "zremrangebyrank not implemented in this redis", 5 if $@ && $@ =~ /unknown command/; is($retval, 3); # remove quux and up is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]); is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[2 .. 4]]); # only left with 3 is($o->zcard($zset), 3); } ok($o->del($zset)); # cleanup ## Commands operating on hashes my $hash = 'test-hash'; $o->del($hash); SKIP: { my $retval = eval { $o->hset($hash, foo => 'bar') }; skip "hset not implemented in this redis", 20 if $@ && $@ =~ /unknown command/; ok($retval); is($o->hget($hash, 'foo'), 'bar'); ok($o->hexists($hash, 'foo')); ok($o->hdel($hash, 'foo')); ok(!$o->hexists($hash, 'foo')); ok($o->hincrby($hash, incrtest => 1)); is($o->hget($hash, 'incrtest'), 1); is($o->hincrby($hash, incrtest => -1), 0); is($o->hget($hash, 'incrtest'), 0); ok($o->hdel($hash, 'incrtest')); #cleanup ok($o->hsetnx($hash, setnxtest => 'baz')); ok(!$o->hsetnx($hash, setnxtest => 'baz')); # already exists, 0 returned ok($o->hdel($hash, 'setnxtest')); #cleanup ok($o->hmset($hash, foo => 1, bar => 2, baz => 3, qux => 4)); is_deeply([$o->hmget($hash, qw/foo bar baz/)], [1, 2, 3]); is($o->hlen($hash), 4); is_deeply([$o->hkeys($hash)], [qw/foo bar baz qux/]); is_deeply([$o->hvals($hash)], [qw/1 2 3 4/]); is_deeply({ $o->hgetall($hash) }, { foo => 1, bar => 2, baz => 3, qux => 4 }); ok($o->del($hash)); # remove entire hash } ## Multiple databases handling commands ok($o->select(1), 'select'); ok($o->select(0), 'select'); ok($o->move('foo', 1), 'move'); ok(!$o->exists('foo'), 'gone'); ok($o->select(1), 'select'); ok($o->exists('foo'), 'exists'); ok($o->flushdb, 'flushdb'); cmp_ok($o->dbsize, '==', 0, 'empty'); ## Sorting ok($o->lpush('test-sort', $_), "put $_") foreach (1 .. 4); cmp_ok($o->llen('test-sort'), '==', 4, 'llen'); is_deeply([$o->sort('test-sort')], [1, 2, 3, 4], 'sort'); is_deeply([$o->sort('test-sort', 'DESC')], [4, 3, 2, 1], 'sort DESC'); ## "Persistence control commands" ok($o->save, 'save'); ok($o->bgsave, 'bgsave'); ok($o->lastsave, 'lastsave'); #ok( $o->shutdown, 'shutdown' ); ## Remote server control commands ok(my $info = $o->info, 'info'); isa_ok($info, 'HASH', '... yields a hash'); ok(keys %$info, '... nonempty'); unlike(join("\n", keys %$info), qr/#/, '... with no comments in the keys'); unlike(join("\n", keys %$info), qr/\n\n|\A\n|\n\z/, '... with no blank lines in the keys'); ## Connection handling ok($o->ping, 'ping() is true'); ok($o->quit, 'quit'); ok(!$o->quit, 'quit again, ok'); ok(!$o->ping, '... but after quit() returns false'); $o = Redis::Fast->new(server => $srv); ok($o->shutdown(), 'shutdown() once is ok'); ok(!$o->shutdown(), '... twice also lives, but returns false'); ok(!$o->ping(), 'ping() will be false after shutdown()'); sleep(1); like( exception { Redis::Fast->new(server => $srv) }, qr/Could not connect to Redis server at $srv/, 'Failed connection throws exception' ); ## All done done_testing(); libredis-fast-perl-0.22+dfsg/t/02-responses.t000077500000000000000000000062301333534323000207370ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Test::Deep; use Redis::Fast; use IO::Socket::UNIX; use Test::UNIXSock; use Parallel::ForkManager; sub r { my ($response, $test) = @_; test_unix_sock( server => sub { my $path = shift; my $sock = IO::Socket::UNIX->new( Local => $path, Listen => 1, Type => SOCK_STREAM, ) or die "Cannot open server socket: $!"; my $res = join '', map "$_\r\n", @$response; my $pm = Parallel::ForkManager->new(10); while(my $remote = $sock->accept) { my $pid = $pm->start and next; <$remote>; # ignore commands from client print {$remote} $res; $pm->finish; } $pm->wait_all_children; }, client => sub { my $path = shift; ok(my $r = Redis::Fast->new(sock => $path, reconnect => 1), 'connected to our test redis-server'); $test->($r); }, ); } ## -ERR responses r(['-you must die!!'] => sub { my $r = shift; like( exception { $r->get('hoge') }, qr/you must die!!/, 'Error response detected' ); }); ## +TEXT responses r(['+all your text are belong to us'] => sub { is shift->get('hoge'), 'all your text are belong to us', 'Text response ok'; }); ## :NUMBER responses r([':234'] => sub { is shift->get('hoge'), 234, 'Integer response ok'; }); ## $SIZE PAYLOAD responses r(['$19', "Redis\r\nis\r\ngreat!\r\n"] => sub { is shift->get('hoge'), "Redis\r\nis\r\ngreat!\r\n", 'Size+payload response ok'; }); r(['$0', ""] => sub { is shift->get('hoge'), "", 'Zero-size+payload response ok'; }); r(['$-1', ""] => sub { is shift->get('hoge'), undef, 'Negative-size+payload response ok'; }); ## Multi-bulk responses r(['*4', '$5', 'Redis', ':42', '$-1', '+Cool stuff'] => sub { cmp_deeply([shift->get('hoge')], ['Redis', 42, undef, 'Cool stuff'], 'Simple multi-bulk response ok'); }); ## Nested Multi-bulk responses r(['*5', '$5', 'Redis', ':42', '*4', ':1', ':2', '$4', 'hope', '*2', ':4', ':5', '$-1', '+Cool stuff'] => sub { cmp_deeply( [shift->get('hoge')], ['Redis', 42, [1, 2, 'hope', [4, 5]], undef, 'Cool stuff'], 'Nested multi-bulk response ok', ); }); ## Nil multi-bulk responses r(['*-1'] => sub { is shift->get('hoge'), undef, 'Read a NIL multi-bulk response'; }); ## Multi-bulk responses with nested error r(['*3', '$5', 'Redis', '-you must die!!', ':42'] => sub { my $r = shift; like( exception { $r->get('hoge') }, qr/\[get\] you must die!!/, 'Nested errors must usually throw exceptions' ); }); r(['*3', '$5', 'Redis', '-you must die!!', ':42'] => sub { my $r = shift; my $result; $r->exec('hoge', sub { $result = [@_] }); $r->wait_all_responses; is_deeply( $result, [[['Redis', undef], [undef, 'you must die!!'], [42, undef]], undef,], 'Nested errors must be collected in collect-errors mode' ); }); done_testing(); libredis-fast-perl-0.22+dfsg/t/03-pubsub.t000077500000000000000000000242331333534323000202220ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Test::Deep; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer qw( redis reap ); my ($c, $srv) = redis(); END { $c->() if $c } { my $r = Redis::Fast->new(server => $srv); eval { $r->publish( 'aa', 'v1' ) }; plan 'skip_all' => "pubsub not implemented on this redis server" if $@ && $@ =~ /unknown command/; } my ($another_kill_switch, $yet_another_kill_switch); END { $_ and $_->() for($another_kill_switch, $yet_another_kill_switch) } subtest 'basics' => sub { my %got; ok(my $pub = Redis::Fast->new(server => $srv), 'connected to our test redis-server (pub)'); ok(my $sub = Redis::Fast->new(server => $srv), 'connected to our test redis-server (sub)'); is($pub->publish('aa', 'v1'), 0, "No subscribers to 'aa' topic"); my $db_size = -1; $sub->dbsize(sub { $db_size = $_[0] }); ## Basic pubsub my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; $sub->subscribe('aa', 'bb', $sub_cb); is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); is($db_size, 0, 'subscribing processes pending queued commands'); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'aa' => 'v1:aa' }, "... for the expected topic, 'aa'"); my $sub_cb2 = sub { my ($v, $t, $s) = @_; $got{"2$s"} = uc("$v:$t") }; $sub->subscribe('aa', $sub_cb2); is($pub->publish('aa', 'v1'), 1, "Delivered to 1 subscriber of topic 'aa'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'aa' => 'v1:aa', '2aa' => 'V1:AA' }, "... for the expected topic, 'aa', with two handlers"); ## Trick subscribe with other messages my $psub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; %got = (); is($pub->publish('aa', 'v2'), 1, "Delivered to 1 subscriber of topic 'aa'"); $sub->psubscribe('a*', 'c*', $psub_cb); cmp_deeply( \%got, { 'aa' => 'v2:aa', '2aa' => 'V2:AA' }, '... received message while processing psubscribe(), two handlers' ); is($pub->publish('aa', 'v3'), 2, "Delivered to 2 subscriber of topic 'aa'"); is($sub->wait_for_messages(1), 2, '... yep, got the expected 2 messages'); cmp_deeply( \%got, { 'aa' => 'v3:aa', 'a*' => 'v3:aa', '2aa' => 'V3:AA' }, "... for the expected subs, 'aa' and 'a*', three handlers total" ); ## Test subscribe/psubscribe diffs %got = (); is($pub->publish('aaa', 'v4'), 1, "Delivered to 1 subscriber of topic 'aaa'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*' => 'v4:aaa' }, "... for the expected sub, 'a*'"); ## Subscriber mode status is($sub->is_subscriber, 4, 'Current subscriber has 4 subscriptions active'); is($pub->is_subscriber, 0, '... the publisher has none'); ## Unsubscribe $sub->unsubscribe('xx', sub { }); is($sub->is_subscriber, 4, "No match to our subscriptions, unsubscribe doesn't change active count"); $sub->unsubscribe('aa', $sub_cb); is($sub->is_subscriber, 4, "unsubscribe ok, active count is still 4, another handler is alive"); $sub->unsubscribe('aa', $sub_cb2); is($sub->is_subscriber, 3, "unsubscribe done, active count is now 3, both handlers are done"); $pub->publish('aa', 'v5'); %got = (); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*', 'v5:aa' }, "... for the expected key, 'a*'"); $sub->unsubscribe('a*', $psub_cb); is($sub->is_subscriber, 3, "unsubscribe with topic wildcard failed, active count is now 3"); $pub->publish('aa', 'v6'); %got = (); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { 'a*', 'v6:aa' }, "... for the expected key, 'a*'"); $sub->unsubscribe('bb', $sub_cb); is($sub->is_subscriber, 2, "unsubscribe with 'bb' ok, active count is now 2"); $sub->punsubscribe('a*', $psub_cb); is($sub->is_subscriber, 1, "punsubscribe with 'a*' ok, active count is now 1"); is($pub->publish('aa', 'v6'), 0, "Publish to 'aa' now gives 0 deliveries"); %got = (); is($sub->wait_for_messages(1), 0, '... yep, no messages delivered'); cmp_deeply(\%got, {}, '... and an empty messages recorded set'); is($sub->is_subscriber, 1, 'Still some pending subcriptions active'); for my $cmd (qw) { like( exception { $sub->$cmd }, qr/Cannot use command '(?i:$cmd)' while in SUBSCRIBE mode/, ".. still an error to try \U$cmd\E while in SUBSCRIBE mode" ); } $sub->punsubscribe('c*', $psub_cb); is($sub->is_subscriber, 0, '... but none anymore'); is(exception { $sub->info }, undef, 'Other commands ok after we leave subscriber_mode'); }; subtest 'zero_topic' => sub { my %got; my $pub = Redis::Fast->new(server => $srv); my $sub = Redis::Fast->new(server => $srv); my $db_size = -1; $sub->dbsize(sub { $db_size = $_[0] }); my $bad_topic = '0'; my $sub_cb = sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }; $sub->psubscribe("$bad_topic*", 'xx', $sub_cb); is($pub->publish($bad_topic, 'vBAD'), 1, "Delivered to 1 subscriber of topic '$bad_topic'"); is($sub->wait_for_messages(1), 1, '... yep, got the expected 1 message'); cmp_deeply(\%got, { "$bad_topic*" => "vBAD:$bad_topic" }, "... for the expected topic, '$bad_topic'"); }; subtest 'wait_for_messages forever' => sub { my $pid = fork(); BAIL_OUT("Fork failed, aborting") unless defined $pid; if ($pid) { ## parent diag("parent waiting for child $pid..."); my $failed = reap($pid, 11); if ($failed) { pass("wait_for_messages wait forever "); kill(15, $pid); reap($pid) and fail('failed to reap the dead child'); } else { fail("wait_for_messages return"); } } else { my $sub = Redis::Fast->new(server => $srv); $sub->subscribe('chan', sub { }); $sub->wait_for_messages; ## never return exit(0); } }; subtest 'server is killed while waiting for subscribe' => sub { my ($another_kill_switch, $another_server) = redis(); my $pid = fork(); BAIL_OUT("Fork failed, aborting") unless defined $pid; if ($pid) { ## parent, we'll wait for the child to die quickly ok(my $sync = Redis::Fast->new(server => $srv), 'connected to our test redis-server (sync parent)'); BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); ok($another_kill_switch->(), "pub/sub redis server killed"); diag("parent killed pub/sub redis server, signal child to proceed"); $sync->lpush('wake_up_child', 'the redis-server is dead, do your thing'); diag("parent waiting for child $pid..."); my $failed = reap($pid, 5); if ($failed) { fail("wait_for_messages() hangs when the server goes away..."); kill(9, $pid); reap($pid) and fail('... failed to reap the dead child'); } else { pass("wait_for_messages() properly detects a server that dies"); } } else { ## child my $sync = Redis::Fast->new(server => $srv); my $sub = Redis::Fast->new(server => $another_server); $sub->subscribe('chan', sub { }); diag("child is ready to test, signal parent to kill our server"); $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); ## This is the test, next wait_for_messages() should not block diag("now, check wait_for_messages(), should die..."); like( exception { $sub->wait_for_messages(0) }, qr/EOF from server/, "properly died with EOF" ); exit(0); } }; subtest 'server is restarted while waiting for subscribe' => sub { my @ret = redis(); my ($another_kill_switch, $another_server) = @ret; my $port = pop @ret; my $pid = fork(); BAIL_OUT("Fork failed, aborting") unless defined $pid; if ($pid) { ## parent, we'll wait for the child to die quickly ok(my $sync = Redis::Fast->new(server => $srv), 'PARENT: connected to our test redis-server (sync parent)'); BAIL_OUT('Missed sync while waiting for child') unless defined $sync->blpop('wake_up_parent', 4); ok($another_kill_switch->(), "PARENT: pub/sub redis server killed"); diag("PARENT: killed pub/sub redis server, signal child to proceed"); $sync->lpush('wake_up_child', 'the redis-server is dead, waiting before respawning it'); sleep 5; # relaunch it on the same port my ($yet_another_kill_switch) = redis(port => $port); my $pub = Redis::Fast->new(server => $another_server); diag("PARENT: has relaunched the server..."); sleep 5; is($pub->publish('chan', 'v1'), 1, "PARENT: published and the child is subscribed"); diag("PARENT: waiting for child $pid..."); my $failed = reap($pid, 5); if ($failed) { fail("PARENT: wait_for_messages() hangs when the server goes away..."); kill(9, $pid); reap($pid) and fail('PARENT: ... failed to reap the dead child'); } else { pass("PARENT: child has properly quit after wait_for_messages()"); } ok($yet_another_kill_switch->(), "PARENT: pub/sub redis server killed"); } else { ## child my $sync = Redis::Fast->new(server => $srv); my $sub = Redis::Fast->new(server => $another_server, reconnect => 10, on_connect => sub { diag "CHILD: reconnected (with a 10s timeout)"; } ); my %got; $sub->subscribe('chan', sub { my ($v, $t, $s) = @_; $got{$s} = "$v:$t" }); diag("CHILD: is ready to test, signal parent to restart our server"); $sync->lpush('wake_up_parent', 'we are ready on this side, kill the server...'); die '## Missed sync while waiting for parent' unless defined $sync->blpop('wake_up_child', 4); ## This is the test, wait_for_messages() should reconnect to the respawned server while (1) { diag("CHILD: launch wait_for_messages(2), with reconnect..."); my $r = $sub->wait_for_messages(2); $r and last; diag("CHILD: after 2 sec, nothing yet, retrying"); } diag("CHILD: child received the message"); cmp_deeply(\%got, { 'chan' => 'v1:chan' }, "CHILD: the message is what we want"); exit(0); } }; ## And we are done done_testing(); libredis-fast-perl-0.22+dfsg/t/04-pipeline.t000077500000000000000000000106511333534323000205270ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Test::Deep; my ($c, $srv) = redis(); END { $c->() if $c } { my $r = Redis::Fast->new(server => $srv); eval { $r->multi( ); }; plan 'skip_all' => "multi without arguments not implemented on this redis server" if $@ && $@ =~ /unknown command/; } ok(my $r = Redis::Fast->new(server => $srv), 'connected to our test redis-server'); sub pipeline_ok { my ($desc, @commands) = @_; my (@responses, @expected_responses); for my $cmd (@commands) { my ($method, $args, $expected, $expected_err) = @$cmd; push @expected_responses, [$expected, $expected_err]; $r->$method(@$args, sub { push @responses, [@_] }); } $r->wait_all_responses; cmp_deeply(\@responses, \@expected_responses, $desc); } pipeline_ok 'single-command pipeline', ([set => [foo => 'bar'], 'OK'],); pipeline_ok 'pipeline with embedded error', ([set => [clunk => 'eth'], 'OK'], [oops => [], undef, re(q[\AERR unknown command ['`]OOPS['`](:?, with args beginning with: )?\z])], [get => ['clunk'], 'eth'],); pipeline_ok 'keys in pipelined mode', ([keys => ['*'], bag(qw)], [keys => [], undef, q[ERR wrong number of arguments for 'keys' command]],); pipeline_ok 'info in pipelined mode', ( [info => [], code(sub { ref $_[0] eq 'HASH' && keys %{ $_[0] } })], [ info => [qw], undef, re(qr{^ERR (?:syntax error|wrong number of arguments for 'info' command)$}) ], ); pipeline_ok 'pipeline with multi-bulk reply', ([hmset => [kapow => (a => 1, b => 2, c => 3)], 'OK'], [hmget => [kapow => qw], [3, 2, 1]],); pipeline_ok 'large pipeline', ( (map { [hset => [zzapp => $_ => -$_], 1] } 1 .. 5000), [hmget => [zzapp => (1 .. 5000)], [reverse -5000 .. -1]], [del => ['zzapp'], 1], ); subtest 'synchronous request with pending pipeline' => sub { my $clunk; is($r->get('clunk', sub { $clunk = $_[0] }), 1, 'queue a request'); is($r->set('kapow', 'zzapp', sub { }), 1, 'queue another request'); is($r->get('kapow'), 'zzapp', 'synchronous request has expected return'); is($clunk, 'eth', 'synchronous request processes pending ones'); }; subtest 'transaction with error and pipeline' => sub { my @responses; my $s = sub { push @responses, [@_] }; $r->multi($s); $r->set(clunk => 'eth', $s); $r->rpush(clunk => 'oops', $s); $r->get('clunk', $s); $r->exec($s); $r->wait_all_responses; is(shift(@responses)->[0], 'OK' , 'multi started' ); is(shift(@responses)->[0], 'QUEUED', 'queued'); is(shift(@responses)->[0], 'QUEUED', 'queued'); is(shift(@responses)->[0], 'QUEUED', 'queued'); my $resp = shift @responses; is ($resp->[0]->[0]->[0], 'OK', 'set'); is ($resp->[0]->[1]->[0], undef, 'bad rpush value should be undef'); like ($resp->[0]->[1]->[1], qr/(?:ERR|WRONGTYPE) Operation against a key holding the wrong kind of value/, 'bad rpush should give an error'); is ($resp->[0]->[2]->[0], 'eth', 'get should work'); }; subtest 'transaction with error and no pipeline' => sub { is($r->multi, 'OK', 'multi'); is($r->set('clunk', 'eth'), 'QUEUED', 'transactional SET'); is($r->rpush('clunk', 'oops'), 'QUEUED', 'transactional bad RPUSH'); is($r->get('clunk'), 'QUEUED', 'transactional GET'); like( exception { $r->exec }, qr{\[exec\] (?:WRONGTYPE|ERR) Operation against a key holding the wrong kind of value,}, 'synchronous EXEC dies for intervening error' ); }; subtest 'wait_one_response' => sub { plan skip_all => 'hiredis cannot wait_one_response'; my $first; my $second; $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->get('a', sub { $first++ }); $r->get('a', sub { $second++ }); $r->wait_one_response(); is($first, 1, 'after first wait_one_response(), first callback called'); is($second, undef, '... but not the second one'); $r->wait_one_response(); is($first, 1, 'after second wait_one_response(), first callback was not called again'); is($second, 1, '... but the second one was called'); $r->wait_all_responses(); is($first, 2, 'after final wait_all_responses(), first callback was called again'); is($second, 2, '... the second one was also called'); $r->wait_one_response(); is($first, 2, 'after final wait_one_response(), first callback was not called again'); is($second, 2, '... nor was the second one'); }; done_testing(); libredis-fast-perl-0.22+dfsg/t/05-nonblock.t000066400000000000000000000021231333534323000205200ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More skip_all => 'not needed, tested by hiredis'; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } subtest 'non-block TCP' => sub { ok(my $r = Redis::Fast->new(server => $srv), 'connected to our test redis-server via TCP'); ## Try to read from server (nothing sent, so nothing to read) ## But kill if we block local $SIG{ALRM} = sub { kill 9, $$ }; alarm(2); ok(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block"); alarm(0); }; subtest 'non-block UNIX' => sub { plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' unless $ENV{TEST_REDIS_SERVER_SOCK_PATH}; ok(my $r = Redis::Fast->new(sock => $ENV{TEST_REDIS_SERVER_SOCK_PATH}), 'connected to our test redis-server via UNIX'); ## Try to read from server (nothing sent, so nothing to read) ## But kill if we block local $SIG{ALRM} = sub { kill 9, $$ }; alarm(2); ok(!$r->__try_read_sock($r->{sock}), "Nothing to read, didn't block"); alarm(0); }; done_testing(); libredis-fast-perl-0.22+dfsg/t/06-on-connect.t000066400000000000000000000017211333534323000207620ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(timeout => 1); END { $c->() if $c } subtest 'on_connect' => sub { my $r; ok($r = Redis::Fast->new(server => $srv, on_connect => sub { shift->incr('on_connect') }), 'connected to our test redis-server'); is($r->get('on_connect'), 1, '... on_connect code was run'); ok($r = Redis::Fast->new(server => $srv, on_connect => sub { shift->incr('on_connect') }), 'new connection is up and running'); is($r->get('on_connect'), 2, '... on_connect code was run again'); ok($r = Redis::Fast->new(reconnect => 1, server => $srv, on_connect => sub { shift->incr('on_connect') }), 'new connection with reconnect enabled'); is($r->get('on_connect'), 3, '... on_connect code one again perfect'); $r->quit; is($r->get('on_connect'), 4, '... on_connect code works after reconnect also'); }; done_testing(); libredis-fast-perl-0.22+dfsg/t/07-reconnect-on-error.t000066400000000000000000000171131333534323000224430ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(timeout => 3); # redis connection timeouts within 3 seconds. END { $c->() if $c } # Reconnect once # when ## 1. reconnect is greater than 0 ## 2. and reconnect_on_error returns a value greater than and equal to 0 ## 3. and a specified time seconds elapsed my $sync_call_hset = sub { my ($client, $hint) = @_; like (exception { $client->hset(1,1) }, qr{ERR wrong number of arguments for 'hset' command}, 'syntax error') or diag "hint=$hint"; return 'sync'; }; my $async_call_hset = sub { my ($client, $hint) = @_; my $_cb_call_count = 0; my $_cb = sub { my ($ret, $error) = @_; is $error, "ERR wrong number of arguments for 'hset' command" or diag "_cb_call_count=$_cb_call_count, hint=$hint"; ok !$ret or diag "_cb_call_count=$_cb_call_count, hint=$hint"; $_cb_call_count++; }; $client->hset(1,1,$_cb); $client->hset(2,2,$_cb); $client->wait_all_responses; is $_cb_call_count, 2; return 'async'; }; # Check a condition 1. subtest 'reconnect option is 0: reconnect_on_error is not called' => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $cb_call_count = 0; my $r = Redis::Fast->new( reconnect => 0, # do not trigger reconnection. server => $srv, reconnect_on_error => sub { $cb_call_count++ }, ); my $hint = $call_hset->($r, "reconnect is 0"); is $cb_call_count, 0, 'reconnect_on_error is not called' or diag "call=$hint"; } }; subtest 'reconnect option is 1: reconnect_on_error is called once' => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $cb_call_count = 0; my $r = Redis::Fast->new( reconnect => 1, # trigger reconnection until 1 second elapsed. server => $srv, reconnect_on_error => sub { my ($error, $ret, $cmd) = @_; # increment a counter to test it later. $cb_call_count++; # tests each argument. is $error, "ERR wrong number of arguments for 'hset' command"; ok !$ret; is $cmd, 'HSET'; return 0; # 0 means invake reconnection as soon as possible. }, ); my $hint = $call_hset->($r, "reconnect is 1"); is $cb_call_count, 1, 'reconnect_on_error is called once' or diag "call=$hint"; } }; # Check a condition 2. subtest "reconnect_on_error returns -1: redis ERR doesn't trigger reconnection" => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $connect_count = 0; my $cb_call_count = 0; my $r = Redis::Fast->new( reconnect => 1, server => $srv, on_connect => sub { $connect_count++ }, reconnect_on_error => sub { $cb_call_count++; return -1; # reconnect_on_error returns -1 }, ); my $hint = $call_hset->($r, "reconnect_on_error returns -1"); is $connect_count, 1, "redis ERR doesn't trigger reconnection"; if ($hint eq 'async') { is $cb_call_count, 2, 'call reconnect_on_error each async call for hset' or diag "cb_return_value=-1 hint=$hint"; } else { is $cb_call_count, 1, 'call reconnect_on_error once' or diag "cb_return_value=-1, hint=$hint"; } } }; subtest "reconnect_on_error returns 0: redis ERR triggers reconnection" => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $connect_count = 0; my $cb_call_count = 0; my $r = Redis::Fast->new( reconnect => 1, server => $srv, on_connect => sub { $connect_count++ }, reconnect_on_error => sub { $cb_call_count++; return 0; # reconnect_on_error returns 0 }, ); my $hint = $call_hset->($r, "reconnect_on_error returns 0"); is $connect_count, 2, "redis ERR triggers reconnection"; # If $cb_return_value is 0 and then $self->need_reconnect is set, # calling the reconnect_on_error cb again is useless cost. is $cb_call_count, 1, 'call reconnect_on_error once' or diag "cb_return_value=-1, hint=$hint"; } }; # Check a condition 3. subtest "reconnection will not be triggered until specified seconds elapsed." => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $hint; my $cb_call_count = 0; my $cb_return_value = 0; my $r = Redis::Fast->new( reconnect => 1, server => $srv, reconnect_on_error => sub { $cb_call_count++; return $cb_return_value; }, ); # reconnect if the redis returns ERR, # and next reconnection will be triggered. $cb_return_value = 0; $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 1, 'call reconnect_on_error once' or diag "cb_return_value=$cb_return_value, call=$hint"; # reconnect if the redis returns ERR, # and next reconnection will not be triggered until 1 second elapsed. $cb_return_value = 1; $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 2, 'call reconnect_on_error twice' or diag "cb_return_value=$cb_return_value, call=$hint"; # reconnection is not triggered # because $cb_return_value seconds have not passed since the last reconnection. $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 2, 'call reconnect_on_error twice' or diag "cb_return_value=$cb_return_value, call=$hint"; } }; subtest "reconnection will be triggered after specified seconds elapsed." => sub { for my $call_hset ($sync_call_hset, $async_call_hset) { my $hint; my $cb_call_count = 0; my $cb_return_value = 0; my $r = Redis::Fast->new( reconnect => 1, server => $srv, reconnect_on_error => sub { $cb_call_count++; return $cb_return_value; }, ); # reconnect if the redis returns ERR, # and next reconnection will be triggered. $cb_return_value = 0; $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 1, 'call reconnect_on_error once' or diag "cb_return_value=$cb_return_value, call=$hint"; # reconnect if the redis returns ERR, # and next reconnection will not be triggered until 1 second elapsed. $cb_return_value = 1; $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 2, 'call reconnect_on_error twice' or diag "cb_return_value=$cb_return_value, call=$hint"; # wait for $cb_return_value seconds to pass since the last reconnection. # +1 second is a buffer. sleep $cb_return_value + 1; # reconnection is triggered # because $cb_return_value seconds have passed since the last reconnection. $hint = $call_hset->($r, $cb_return_value); is $cb_call_count, 3, 'call reconnect_on_error twice' or diag "cb_return_value=$cb_return_value, call=$hint"; } }; done_testing(); libredis-fast-perl-0.22+dfsg/t/07-reconnect.t000077500000000000000000000207641333534323000207130ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Time::HiRes qw(gettimeofday tv_interval); use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Net::EmptyPort qw(empty_port); my ($c, $srv) = redis(timeout => 1); END { $c->() if $c } subtest 'Command without connection, no reconnect' => sub { ok(my $r = Redis::Fast->new(reconnect => 0, server => $srv), 'connected to our test redis-server'); ok($r->quit, 'close connection to the server'); like(exception { $r->set(reconnect => 1) }, qr{Not connected to any server}, 'send ping without reconnect',); }; subtest 'Command without connection or timeout, with database change, with reconnect' => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->select(4), 'send command with reconnect'); ok($r->set(reconnect => $$), 'send command with reconnect'); ok($r->quit, 'close connection to the server'); is($r->get('reconnect'), $$, 'reconnect with read errors before write'); }; subtest 'Reconnection discards pending commands' => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); my $processed_pending = 0; $r->dbsize(sub { $processed_pending++ }); _wait_for_redis_timeout(); ok($r->set(foo => 'bar'), 'send command with reconnect'); is($processed_pending, 0, 'pending command discarded on reconnect'); }; subtest 'INFO commands with extra logic triggers reconnect' => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->quit, 'close connection to the server'); my $info = $r->info; is(ref $info, 'HASH', 'reconnect on INFO command'); }; subtest 'KEYS commands with extra logic triggers reconnect' => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); ok($r->flushdb, 'delete all keys'); ok($r->set(reconnect => $$), 'set known key'); ok($r->quit, 'close connection to the server'); my @keys = $r->keys('*'); is_deeply(\@keys, ['reconnect'], 'reconnect on KEYS command'); }; subtest 'PING commands with extra logic triggers reconnect' => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); _wait_for_redis_timeout(); my $res = $r->ping; ok($res, 'reconnect on PING command'); ok($r->quit, 'close connection to the server'); $res = $r->ping; ok(!$res, 'QUIT command disables reconnect on PING command'); }; subtest "Bad commands don't trigger reconnect" => sub { ok(my $r = Redis::Fast->new(reconnect => 2, server => $srv), 'connected to our test redis-server'); my $prev_sock = $r->__sock; like( exception { $r->set(bad => reconnect => 1) }, qr{ERR wrong number of arguments for 'set' command|ERR syntax error}, 'Bad commands still die', ); is($r->__sock, $prev_sock, "... and don't trigger a reconnect"); }; subtest 'Reconnect code clears sockect ASAP' => sub { ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); _wait_for_redis_timeout(); is(exception { $r->quit }, undef, "Quit doesn't die if we are already disconnected"); }; subtest "Reconnect gives up after timeout" => sub { ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); $c->(); ## Make sure the server is dead my $t0 = [gettimeofday]; like( exception { $r->set(reconnect => 1) }, qr{Could not connect to Redis server at}, 'Eventually it gives up and dies', ); ok(tv_interval($t0) > 3, '... minimum value for the reconnect reached'); }; subtest "Reconnect during transaction" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect_1' => 1), 'set first key'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); like(exception { $r->set('reconnect_2' => 2) }, qr{reconnect disabled inside transaction}, 'set second key'); $r->connect(); #reconnect is($r->exists('reconnect_1'), 0, 'key "reconnect_1" should not exist'); is($r->exists('reconnect_2'), 0, 'key "reconnect_2" should not exist'); }; subtest "exec does not trigger reconnect" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect_1' => 1), 'set first key'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); like(exception { $r->exec() }, qr{reconnect disabled inside transaction}, 'exec'); $r->connect(); #reconnect is($r->exists('reconnect_1'), 0, 'key "reconnect_1" should not exist'); }; subtest "multi should trigger reconnect" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->multi(), 'start transacion'); ok($r->set('reconnect' => 1), 'set key'); ok($r->exec(), 'execute transaction'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting key should not fail'); }; subtest "Reconnect works after WATCH + MULTI + EXEC" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->set('watch' => 'watch'), 'set watch key'); ok($r->watch('watch'), 'start watching key'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect' => 1), 'set key'); ok($r->exec(), 'execute transaction'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting key should not fail'); }; subtest "Reconnect works after WATCH + MULTI + DISCARD" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new(reconnect => 3, server => $srv), 'connected to our test redis-server'); ok($r->set('watch' => 'watch'), 'set watch key'); ok($r->watch('watch'), 'start watching key'); ok($r->multi(), 'start transacion'); ok($r->set('reconnect' => 1), 'set key'); ok($r->discard(), 'dscard transaction'); $c->(); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set('reconnect' => 1), 'setting second key should not fail'); }; subtest "Reconnect behaviour differs from cpan Redis module #73" => sub { $c->(); ## Make previous server is dead my $port = empty_port(); ok(($c, $srv) = redis(port => $port, timeout => 1), "spawn redis on port $port"); ok(my $r = Redis::Fast->new( reconnect => 1, every => 100_000, cnx_timeout => 3, read_timeout => 1, write_timeout => 1, server => $srv ), 'connected to our test redis-server'); ok($r->set(reconnect => $$), 'send command'); $c->(); ## Make sure the server is dead like( exception { $r->set(reconnect => $$) }, qr{Could not connect to Redis server at}, 'Eventually it gives up and dies (first try)', ); like( exception { $r->set(reconnect => $$) }, qr{Could not connect to Redis server at}, 'Eventually it gives up and dies (second try)', ); ok(($c, $srv) = redis(port => $port, timeout => 1), "respawn redis on port $port"); ok($r->set(reconnect => $$), 'a command works after respawn'); }; done_testing(); sub _wait_for_redis_timeout { ## Redis will timeout clients after 100 internal server loops, at ## least 10 seconds (even with a timeout 1 on the config) so we sleep ## a bit more hoping the timeout did happen. Not perfect, patches ## welcome diag('Sleeping 11 seconds, waiting for Redis to timeout...'); sleep(11); } libredis-fast-perl-0.22+dfsg/t/08-unix-socket.t000066400000000000000000000021071333534323000211710ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' unless $ENV{TEST_REDIS_SERVER_SOCK_PATH}; my $conn = sub { my @args = @_; my $r; is( exception { $r = Redis::Fast->new(sock => $ENV{TEST_REDIS_SERVER_SOCK_PATH}, @args); }, undef, 'Connected to the Redis server ok', ); return $r; }; subtest 'basic tests' => sub { my $r = $conn->(); ok($r->set(xpto => '42'), '... set command via UNIX ok'); is($r->get('xpto'), '42', '... and get command ok too'); is(exception { $r->quit }, undef, 'Connection closed ok'); like(exception { $r->get('xpto') }, qr!Not connected to any server!, 'Command failed ok, no reconnect',); }; subtest 'reconnect over UNIX daemon' => sub { my $r = $conn->(reconnect => 2); ok($r->quit, '... and connection closed ok'); is(exception { $r->set(xpto => '43') }, undef, 'set command via UNIX ok, reconnected fine'); is($r->get('xpto'), '43', '... and get command ok too'); }; done_testing(); libredis-fast-perl-0.22+dfsg/t/09-env-redis-server.t000066400000000000000000000025751333534323000221320ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } subtest 'REDIS_SERVER TCP' => sub { my $n = time(); my $r = Redis::Fast->new(server => $srv); $r->set($$ => $n); local $ENV{REDIS_SERVER} = $srv; is(exception { $r = Redis::Fast->new }, undef, "Direct IP/Port address on REDIS_SERVER works ($srv)",); is($r->get($$), $n, '... connected to the expected server'); $ENV{REDIS_SERVER} = "tcp:$srv"; is(exception { $r = Redis::Fast->new }, undef, 'Direct IP/Port address (with tcp prefix) on REDIS_SERVER works',); is($r->get($$), $n, '... connected to the expected server'); }; subtest 'REDIS_SERVER UNIX' => sub { my $srv = $ENV{TEST_REDIS_SERVER_SOCK_PATH}; plan skip_all => 'Define ENV TEST_REDIS_SERVER_SOCK_PATH to test UNIX socket support' unless $srv; my $n = time(); my $r = Redis::Fast->new(sock => $srv); $r->set($$ => $n); local $ENV{REDIS_SERVER} = $srv; is(exception { $r = Redis::Fast->new }, undef, 'UNIX path on REDIS_SERVER works',); is($r->get($$), $n, '... connected to the expected server'); $ENV{REDIS_SERVER} = "unix:$srv"; is(exception { $r = Redis::Fast->new }, undef, 'UNIX path (with unix prefix) on REDIS_SERVER works',); is($r->get($$), $n, '... connected to the expected server'); }; done_testing(); libredis-fast-perl-0.22+dfsg/t/10-tie-list.t000077500000000000000000000032611333534323000204500ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Redis::Fast::List; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ## Setup my @my_list; ok(my $redis = tie(@my_list, 'Redis::Fast::List', 'my_list', server => $srv), 'tied to our test redis-server'); ok($redis->ping, 'pinged fine'); isa_ok($redis, 'Redis::Fast::List'); ## Direct access subtest 'direct access' => sub { @my_list = (); is_deeply(\@my_list, [], 'empty list ok'); @my_list = ('foo', 'bar', 'baz'); is_deeply(\@my_list, ['foo', 'bar', 'baz'], 'Set multiple values ok'); $my_list[1] = 'BAR'; is_deeply(\@my_list, ['foo', 'BAR', 'baz'], 'Set single value ok'); is($my_list[2]++, 'baz', 'get single value ok'); is(++$my_list[2], 'bbb', '... even with post/pre-increments'); }; ## List functions subtest 'list functions' => sub { my $v; ok($v = shift(@my_list), 'shift ok'); is($v, 'foo', '... expected value'); is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); ok(push(@my_list, $v), 'push ok'); is_deeply(\@my_list, ['BAR', 'bbb', 'foo'], '... resulting list as expected'); ok($v = pop(@my_list), 'pop ok'); is($v, 'foo', '... expected value'); is_deeply(\@my_list, ['BAR', 'bbb'], '... resulting list as expected'); ok(unshift(@my_list, $v), 'unshift ok'); is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... resulting list as expected'); ok(my @s = splice(@my_list, 1, 2), 'splice ok'); is_deeply([@s], ['BAR', 'bbb'], '... resulting list as expected'); is_deeply(\@my_list, ['foo', 'BAR', 'bbb'], '... original list as expected'); }; ## Cleanup @my_list = (); is_deeply(\@my_list, [], 'empty list ok'); done_testing(); libredis-fast-perl-0.22+dfsg/t/11-timeout.t000066400000000000000000000033531333534323000204040ustar00rootroot00000000000000#!perl use strict; use warnings; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisTimeoutServer; use Errno qw(ETIMEDOUT EWOULDBLOCK); use POSIX qw(strerror); use Carp; use IO::Socket::INET; use Test::TCP; subtest 'server replies quickly enough' => sub { my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(0); my $redis = Redis::Fast->new(server => '127.0.0.1:' . $server->port, read_timeout => 1); ok($redis); my $res = $redis->get('foo');; is $res, 42; }; subtest "server doesn't replies quickly enough" => sub { my $server = Test::SpawnRedisTimeoutServer::create_server_with_timeout(10); my $redis = Redis::Fast->new(server => '127.0.0.1:' . $server->port, read_timeout => 1); ok($redis); like( exception { $redis->get('foo'); }, qr/Error while reading from Redis server: /, "the code died as expected", ); ok($! == ETIMEDOUT || $! == EWOULDBLOCK); }; subtest "server doesn't respond at connection (cnx_timeout)" => sub { SKIP: { skip "This subtest is failing on some platforms", 4; my $server = Test::TCP->new(code => sub { my $port = shift; my $sock = IO::Socket::INET->new(Listen => 1, LocalPort => $port, Proto => 'tcp', LocalAddr => '127.0.0.1') or croak "fail to listen on port $port"; while(1) { sleep(1); }; }); my $redis; my $start_time = time; isnt( exception { $redis = Redis::Fast->new(server => '127.0.0.1:' . $server->port, cnx_timeout => 1); }, undef, "the code died", ); ok(time - $start_time >= 1, "gave up late enough"); ok(time - $start_time < 5, "gave up soon enough"); ok(!$redis, 'redis was not set'); } }; done_testing; libredis-fast-perl-0.22+dfsg/t/20-tie-hash.t000077500000000000000000000025601333534323000204220ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Deep; use Redis::Fast::Hash; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ## Setup my %my_hash; ok(my $redis = tie(%my_hash, 'Redis::Fast::Hash', 'my_hash', server => $srv), 'tied to our test redis-server'); ok($redis->ping, 'pinged fine'); isa_ok($redis, 'Redis::Fast::Hash'); ## Direct access subtest 'direct access' => sub { %my_hash = (); cmp_deeply(\%my_hash, {}, 'empty list ok'); %my_hash = (a => 'foo', b => 'bar', c => 'baz'); cmp_deeply(\%my_hash, { a => 'foo', b => 'bar', c => 'baz' }, 'Set multiple values ok'); $my_hash{b} = 'BAR'; cmp_deeply(\%my_hash, { a => 'foo', b => 'BAR', c => 'baz' }, 'Set single value ok'); is($my_hash{c}++, 'baz', 'get single value ok'); is(++$my_hash{c}, 'bbb', '... even with post/pre-increments'); }; ## Hash functions subtest 'hash functions' => sub { ok(my @keys = keys(%my_hash), 'keys ok'); cmp_deeply(\@keys, bag(qw( a b c )), '... resulting list as expected'); ok(my @values = values(%my_hash), 'values ok'); cmp_deeply(\@values, bag(qw( foo BAR bbb )), '... resulting list as expected'); %my_hash = reverse %my_hash; cmp_deeply(\%my_hash, { foo => 'a', BAR => 'b', bbb => 'c' }, 'reverse() worked'); }; ## Cleanup %my_hash = (); cmp_deeply(\%my_hash, {}, 'empty list ok'); done_testing(); libredis-fast-perl-0.22+dfsg/t/30-scripts.t000077500000000000000000000021141333534323000204030ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Digest::SHA qw(sha1_hex); my ($c, $srv) = redis(); END { $c->() if $c } my $o = Redis::Fast->new(server => $srv); ## Make sure SCRIPT commands are available eval { $o->script_flush }; if ($@ && $@ =~ /ERR unknown command 'SCRIPT',/) { $c->(); plan skip_all => 'This redis-server lacks scripting support'; } ## Commands related to Lua scripting # Specifically, these commands test multi-word commands ok($o->set(foo => 'bar'), 'set foo => bar'); my $script = "return 1"; my $script_sha = sha1_hex($script); my @ret = $o->script_exists($script_sha); ok(@ret && $ret[0] == 0, "script exists returns false"); @ret = $o->script_load($script); ok(@ret && $ret[0] eq $script_sha, "script load returns the sha1 of the script"); ok($o->script_exists($script_sha), "script exists returns true after loading"); ok($o->evalsha($script_sha, 0), "evalsha returns true with the sha1 of the script"); ok($o->eval($script, 0), "eval returns true"); ## All done done_testing(); libredis-fast-perl-0.22+dfsg/t/42-client_cmds.t000066400000000000000000000032221333534323000212010ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(requires_version => '2.6.9'); END { $c->() if $c } subtest 'client_{set|get}name commands' => sub { ok(my $r = Redis::Fast->new(server => $srv), 'connected to our test redis-server'); my @clients = $r->client_list; is(@clients, 1, 'one client listed'); like($clients[0], qr/\s+name=\s+/, '... no name set yet'); is($r->client_setname('my_preccccious'), 'OK', "client_setname() is supported, no errors"); is($r->client_getname, 'my_preccccious', '... client_getname() returns new connection name'); @clients = $r->client_list; like($clients[0], qr/\s+name=my_preccccious\s+/, '... no name set yet'); }; subtest 'client name via constructor' => sub { ok(my $r = Redis::Fast->new(server => $srv, name => 'buuu'), 'connected to our test redis-server, with a name'); is($r->client_getname, 'buuu', '...... name was properly set'); ok($r = Redis::Fast->new(server => $srv, name => sub {"cache-for-$$"}), '... with a dynamic name'); is($r->client_getname, "cache-for-$$", '...... name was properly set'); ok($r = Redis::Fast->new(server => $srv, name => sub {undef}), '... with a dynamic name, but returning undef'); is($r->client_getname, undef, '...... name was not set'); my $generation = 0; for (1 .. 3) { ok($r = Redis::Fast->new(server => $srv, name => sub { "gen-$$-" . ++$generation }), "Using dynamic name, for generation $generation"); my $n = "gen-$$-$generation"; is($r->client_getname, $n, "... name was set properly, '$n'"); } }; done_testing(); libredis-fast-perl-0.22+dfsg/t/44-no-unicode-bug.t000077500000000000000000000011411333534323000215330ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } ok(my $r = Redis::Fast->new(server => $srv), 'connected to our test redis-server'); my $s2 = my $s1 = "test\x{80}"; utf8::upgrade($s1); # no need to use 'use utf8' to call this utf8::downgrade($s2); # no need to use 'use utf8' to call this ok ($s1 eq $s2, 'assume test string are considered identical by perl'); $r->set($s1 => 42); is $r->get($s2), 42, "same binary strings should point to same keys"; ## All done done_testing(); libredis-fast-perl-0.22+dfsg/t/50-fork_safe.t000066400000000000000000000013571333534323000206620ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Test::SharedFork; use Socket; my ($c, $srv) = redis(); END { $c->() if $c } my $o = Redis::Fast->new(server => $srv, name => 'my_name_is_glorious'); is $o->info->{connected_clients}, 1; my $localport = $o->__get_port; note "fork safe"; { if (my $pid = fork) { $o->incr("test-fork"); is $o->__get_port, $localport, "same port on parent"; waitpid($pid, 0); } else { $o->incr("test-fork"); isnt $o->__get_port, $localport, "different port on child"; is $o->info->{connected_clients}, 2, "2 clients connected"; exit 0; } is $o->get('test-fork'), 2; }; done_testing; libredis-fast-perl-0.22+dfsg/t/51-leak.t000066400000000000000000000037331333534323000176400ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Test::SharedFork; use Socket; my ($c, $srv) = redis(); END { $c->() if $c } use Test::LeakTrace; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); } 'Redis::Fast->new'; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); my $res; $r->set('hogehoge', 'fugafuga'); $res = $r->get('hogehoge'); $r->flushdb; } 'sync get/set'; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); my $res; $r->set('hogehoge', 'fugafuga', sub { }); $r->get('hogehoge', sub { $res = shift }); $r->wait_all_responses; $r->flushdb; } 'async get/set'; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); my $res; $r->rpush('hogehoge', 'fugafuga') for (1..3); $res = $r->lrange('hogehoge', 0, -1); $r->flushdb; } 'sync list operation'; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); my $res; $r->rpush('hogehoge', 'fugafuga') for (1..3); $r->lrange('hogehoge', 0, -1, sub { $res = shift }); $r->wait_all_responses; $r->flushdb; } 'async list operation'; no_leaks_ok { my $r = Redis::Fast->new(server => $srv); my $cb = sub {}; $r->subscribe('hogehoge', $cb); $r->wait_for_messages(0); $r->unsubscribe('hogehoge', $cb); } 'unsubscribe'; no_leaks_ok { my $r = Redis::Fast->new( server => $srv, reconnect => 1, reconnect_on_error => sub { my $force_reconnect = 1; return $force_reconnect; }, ); eval { $r->hset(1,1) }; } 'sync reconnect_on_error'; no_leaks_ok { my $r = Redis::Fast->new( server => $srv, reconnect => 1, reconnect_on_error => sub { my $force_reconnect = 1; return $force_reconnect; }, ); my $cb = sub {}; $r->hset(1,1,$cb); $r->hset(2,2,$cb); eval { $r->wait_all_responses }; } 'async reconnect_on_error'; done_testing; libredis-fast-perl-0.22+dfsg/t/53-blpop.t000066400000000000000000000010241333534323000200310ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } my $redis = Redis::Fast->new(server => $srv, name => 'blpop_test', reconnect=>1, cnx_timeout => 0.2, read_timeout => 1); unless (fork()) { # it will exit with read timeout eval { $redis->blpop("somekey", 3); }; exit; } sleep 2; $redis->rpush("somekey", 4); sleep 1; is $redis->lpop("somekey"), 4, 'blpop is time out while lpop is success'; wait; done_testing; libredis-fast-perl-0.22+dfsg/t/53-blpop_and_timeout.t000066400000000000000000000007161333534323000224300ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis(); END { $c->() if $c } unless (fork()) { my $redis = Redis::Fast->new(server => $srv, name => 'my_name_is_glorious', reconnect=>1, read_timeout => 0.3); eval { $redis->blpop("notakey", 1); }; exit 0; } wait; is $?, 0, "does not crash when read_timeout is smaller than BLPOP timeout"; done_testing; libredis-fast-perl-0.22+dfsg/t/53-deep-recursion.t000077500000000000000000000015701333534323000216520ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my ($c, $srv) = redis( maxclients => 1, ); END { $c->() if $c } ok my $r1 = Redis::Fast->new( server => $srv, name => 'my-first-connection', reconnect => 1, every => 1000, on_connect => sub { my ( $redis ) = @_; $redis->select(1); }, ), "first connection is success"; like( exception { my $r2 = Redis::Fast->new( server => $srv, name => 'my-second-connection', reconnect => 1, every => 1000, on_connect => sub { my ( $redis ) = @_; $redis->select(1); }, ); }, qr/Could not connect to Redis server at/, 'second connection is fail', ); ## All done done_testing(); libredis-fast-perl-0.22+dfsg/t/53-fail-to-connect.t000066400000000000000000000003461333534323000217050ustar00rootroot00000000000000use strict; use warnings; use Config; use Test::More; use Test::Fatal; use Redis::Fast; like exception { Redis::Fast->new(server => "localhost:0"); }, qr/could not connect to redis server/i, 'fail to connect'; done_testing; libredis-fast-perl-0.22+dfsg/t/53-password.t000066400000000000000000000021731333534323000205650ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; my $password = 'very-very-long-strong-password'; my ($c, $srv) = redis( password => $password, ); END { $c->() if $c } subtest 'no password' => sub { my $o; is( exception { $o = Redis::Fast->new(server => $srv) }, undef, 'connect is success', ); like( exception { $o->get('foo') }, qr/\[get\] (NOAUTH Authentication required|ERR operation not permitted)/, 'but cannot execute any command except `auth`', ); }; subtest 'wrong password' => sub { my $o; like( exception { $o = Redis::Fast->new(server => $srv, password => 'wrong-password') }, qr/Redis server refused password/, 'connect is fail', ); }; subtest 'correct password' => sub { my $o; is( exception { $o = Redis::Fast->new(server => $srv, password => $password) }, undef, 'connect is success', ); is( exception { $o->get('foo') }, undef, 'can exeecute all command', ); }; ## All done done_testing(); libredis-fast-perl-0.22+dfsg/t/53-signal.t000066400000000000000000000021061333534323000201740ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Time::HiRes qw(); my ($c, $srv) = redis(); END { $c->() if $c } my $redis; is( exception { $redis = Redis::Fast->new(server => $srv, name => 'my_name_is_glorious') }, undef, 'connected to our test redis-server', ); ok($redis->ping, 'ping'); $redis->select(2); subtest 'signal' => sub { my $start = Time::HiRes::time; my $sig; local $SIG{ALRM} = sub { $sig = Time::HiRes::time }; alarm 1; $redis->blpop('abc', 5); my $end = Time::HiRes::time; cmp_ok $sig - $start, '<=', 2, 'the signal handler is executed as soon as possible'; cmp_ok $end - $start, '>=', 4, 'the signal does not unblock the Redis command'; }; subtest 'die in signal' => sub { my $start = Time::HiRes::time; local $SIG{ALRM} = sub { die "ALARM\n"; }; alarm 1; is exception { $redis->blpop('abc', 20); }, "ALARM\n"; my $end = Time::HiRes::time; cmp_ok $end - $start, '<=', 2, 'the signal unblocks the Redis command'; }; done_testing; libredis-fast-perl-0.22+dfsg/t/53-timeout-length.t000066400000000000000000000007671333534323000216770ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Fatal; use Redis::Fast; use lib 't/tlib'; use Test::SpawnRedisServer; use Time::HiRes qw/gettimeofday tv_interval/; my ($c, $srv) = redis(); END { $c->() if $c } my $redis = Redis::Fast->new(server => $srv, name => 'my_name_is_glorious', reconnect => 1, write_timeout => 1); my $start_time = [gettimeofday]; eval { $redis->blpop("notakey", 5); }; my $elapsed = tv_interval($start_time); cmp_ok( $elapsed, '>', 4, 'not too short' ); done_testing; libredis-fast-perl-0.22+dfsg/t/60-sentinel.t000066400000000000000000000047061333534323000205460ustar00rootroot00000000000000#!perl use warnings; use strict; use Test::More; use Test::Fatal; use Test::Deep; use Redis::Fast; use Redis::Fast::Sentinel; use lib 't/tlib'; use Test::SpawnRedisServer; my @ret = redis(); my $redis_port = pop @ret; my ($c, $redis_addr) = @ret; END { diag 'shutting down redis'; $c->() if $c } diag "redis address : $redis_addr\n"; my @ret2 = sentinel( redis_port => $redis_port ); my $sentinel_port = pop @ret2; my ($c2, $sentinel_addr) = @ret2; END { diag 'shutting down sentinel'; $c2->() if $c2 } my @ret3 = sentinel( redis_port => $redis_port ); my $sentinel2_port = pop @ret3; my ($c3, $sentinel2_addr) = @ret3; END { diag 'shutting down sentinel2'; $c3->() if $c3 } diag "sentinel address: $sentinel_addr\n"; diag "sentinel2 address: $sentinel2_addr\n"; diag("wait 3 sec for the sentinels and the master to gossip"); sleep 3; { # check basic sentinel command my $sentinel = Redis::Fast::Sentinel->new(server => $sentinel_addr); use Data::Dumper; my ($major, $minor, $revision) = split /\./, $sentinel->info->{redis_version}; if($major < 2 || ($major == 2 && $minor < 8)) { plan skip_all => 'this test reqires Redis 2.8 or above'; } my $got = ($sentinel->get_masters())[0]; cmp_deeply($got, superhashof({ name => 'mymaster', ip => '127.0.0.1', port => $redis_port, flags => 'master', 'role-reported' => 'master', 'config-epoch' => 0, 'num-slaves' => 0, 'num-other-sentinels' => 1, quorum => 2, }), "sentinel has proper config of its master" ); } { my $sentinel = Redis::Fast::Sentinel->new(server => $sentinel_addr); my $address = $sentinel->get_service_address('mymaster'); is $address, "127.0.0.1:$redis_port", "found service mymaster"; } { my $sentinel = Redis::Fast::Sentinel->new(server => $sentinel_addr); my $address = $sentinel->get_service_address('mywrongmaster'); is $address, undef, "didn't found service mywrongmaster"; } { # connect to the master via the sentinel my $redis = Redis::Fast->new(sentinels => [ $sentinel_addr ], service => 'mymaster'); is_deeply({ map { $_ => 1} @{$redis->__get_data->{sentinels} || []} }, { $sentinel_addr => 1, $sentinel2_addr => 1}, "Redis client has connected and updated its sentinels"); } done_testing(); libredis-fast-perl-0.22+dfsg/t/tlib/000077500000000000000000000000001333534323000172405ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/t/tlib/Test/000077500000000000000000000000001333534323000201575ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/t/tlib/Test/SpawnRedisServer.pm000066400000000000000000000117651333534323000237750ustar00rootroot00000000000000package # Hide from PAUSE Test::SpawnRedisServer; use strict; use warnings; use Redis::Fast; use File::Temp; use IPC::Cmd qw(can_run); use POSIX ":sys_wait_h"; use base qw( Exporter ); use Net::EmptyPort qw(empty_port); our @EXPORT = qw( redis sentinel ); our @EXPORT_OK = qw( redis reap ); sub redis { my %params = ( timeout => 120, @_, ); my ($fh, $fn) = File::Temp::tempfile(); my $port = empty_port(); my $local_port = $port; $params{port} and $local_port = $params{port}; my $addr = "127.0.0.1:$local_port"; unlink("redis-server-$addr.log"); unlink('dump.rdb'); $fh->print(" timeout $params{timeout} appendonly no daemonize no port $local_port bind 127.0.0.1 loglevel debug logfile redis-server-$addr.log "); $fh->print("maxclients $params{maxclients}\n") if $params{maxclients}; $fh->print("requirepass $params{password}\n") if $params{password}; $fh->flush; Test::More::diag("Spawn Redis at $addr, cfg $fn") if $ENV{REDIS_DEBUG}; my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server'; if (!can_run($redis_server_path)) { Test::More::plan skip_all => "Could not find binary redis-server"; return; } my ($ver, $c); eval { ($ver, $c) = spawn_server($redis_server_path, $fn, $addr, $params{password}) }; if (my $e = $@) { reap(); Test::More::plan skip_all => "Could not start redis-server: $@"; return; } if (my $rvs = $params{requires_version}) { if (!defined $ver) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version"; return; } my ($v1, $v2, $v3) = split(/[.]/, $ver); my ($r1, $r2, $r3) = split(/[.]/, $rvs); if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver"; return; } } return ($c, $addr, $ver, split(/[.]/, $ver), $local_port); } sub sentinel { my %params = ( timeout => 120, @_, ); my ($fh, $fn) = File::Temp::tempfile(); my $port = empty_port(); my $local_port = $port; $params{port} and $local_port = $params{port}; my $redis_port = $params{redis_port} or die "need a redis port"; my $addr = "127.0.0.1:$local_port"; unlink("redis-sentinel-$addr.log"); $fh->print(" port $local_port sentinel monitor mymaster 127.0.0.1 $redis_port 2 sentinel down-after-milliseconds mymaster 2000 sentinel failover-timeout mymaster 4000 logfile sentinel-$addr.log "); $fh->flush; my $redis_server_path = $ENV{REDIS_SERVER_PATH} || 'redis-server'; if (!can_run($redis_server_path)) { Test::More::plan skip_all => "Could not find binary redis-server"; return; } my ($ver, $c); eval { ($ver, $c) = spawn_server($redis_server_path, $fn, '--sentinel', $addr, undef) }; if (my $e = $@) { reap(); Test::More::plan skip_all => "Could not start redis-sentinel: $@"; return; } if (my $rvs = $params{requires_version}) { if (!defined $ver) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, could not determine server version"; return; } my ($v1, $v2, $v3) = split(/[.]/, $ver); my ($r1, $r2, $r3) = split(/[.]/, $rvs); if ($v1 < $r1 or $v1 == $r1 and $v2 < $r2 or $v1 == $r1 and $v2 == $r2 and $v3 < $r3) { $c->(); Test::More::plan skip_all => "This tests require at least redis-server $rvs, server found is $ver"; return; } } return ($c, $addr, $ver, split(/[.]/, $ver), $local_port); } sub spawn_server { my $password = pop; my $addr = pop; my $pid = fork(); if ($pid) { ## Parent require Test::More; Test::More::diag("Starting server with pid $pid") if $ENV{REDIS_DEBUG}; my %args = (server => $addr, reconnect => 5, every => 200); $args{password} = $password if defined $password; my $redis = Redis::Fast->new(%args); my $version = $redis->info->{redis_version}; my $alive = $$; $redis->quit; my $c = sub { return unless $alive; return unless $$ == $alive; ## only our creator can kill us Test::More::diag("Killing server at $pid") if $ENV{REDIS_DEBUG}; kill(15, $pid); my $failed = reap($pid); Test::More::diag("Failed to kill server at $pid") if $ENV{REDIS_DEBUG} and $failed; unlink("redis-server-$addr.log"); unlink("redis-sentinel-$addr.log"); unlink('dump.rdb'); $alive = 0; return !$failed; }; return $version => $c; } elsif (defined $pid) { ## Child exec(@_); warn "## In child Failed exec of '@_': $!, "; exit(1); } die "Could not fork(): $!"; } sub reap { my ($pid, $limit) = @_; $pid = -1 unless $pid; $limit = 3 unless $limit; my $try = 0; local $?; while ($try++ < $limit) { my $ok = waitpid($pid, WNOHANG); $try = 0, last if $ok > 0; sleep(1); } return $try; } 1; libredis-fast-perl-0.22+dfsg/t/tlib/Test/SpawnRedisTimeoutServer.pm000066400000000000000000000014451333534323000253360ustar00rootroot00000000000000package # Hide from PAUSE Test::SpawnRedisTimeoutServer; use strict; use warnings; use Test::TCP; sub create_server_with_timeout { my $timeout = shift; Test::TCP->new( code => sub { my $port = shift; my $socket = IO::Socket::INET->new( Listen => 5, Timeout => 1, Reuse => 1, Blocking => 1, LocalPort => $port ) or die "failed to connect to RedisTimeoutServer: $!"; my $buffer; while (1) { my $client = $socket->accept(); if (defined (my $got = <$client>)) { sleep $timeout; $client->print("+42\r\n"); } } }, ); } 1; libredis-fast-perl-0.22+dfsg/tools/000077500000000000000000000000001333534323000172035ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/tools/benchmarks/000077500000000000000000000000001333534323000213205ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/tools/benchmarks/read_vs_sysread.pl000066400000000000000000000036211333534323000250340ustar00rootroot00000000000000use 5.18.1; use Time::HiRes qw(gettimeofday tv_interval); my $total_bytes = 5_000_000; my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); foreach my $length (@lengths) { my $packet_nb = int($total_bytes / $length); my %results; my $method = "read"; if (my $pid = open(my $kid, "|-")) { # parent my $data = 'x' x $length; my $i = $packet_nb; my $t0 = [gettimeofday]; while ($i--) { print $kid $data; } close($kid) or warn "kid exited with $?"; my $elapsed = tv_interval ($t0); # equivalent code say "$method: $packet_nb packets of size $length : $elapsed sec"; $results{$method}{$length} = $elapsed; } else { # child my $data; my $i = 0; while ($i < $packet_nb) { read STDIN, $data, $length, $i*$length; $i++; } length($data) eq $length * $packet_nb or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; exit; # don't forget this } my $method = "sysread"; if (my $pid = open(my $kid, "|-")) { # parent my $data = 'x' x $length; my $i = $packet_nb; my $t0 = [gettimeofday]; while ($i--) { syswrite $kid, $data, $length; } close($kid) or warn "kid exited with $?"; my $elapsed = tv_interval ($t0); # equivalent code say "$method: $packet_nb packets of size $length : $elapsed sec"; $results{$method}{$length} = $elapsed; } else { # child my $data; my $i = 0; while ($i < $packet_nb) { sysread STDIN, $data, $length, $i*$length; $i++; } length($data) eq $length * $packet_nb or say "wrong length : got " . length($data) . " instead of " . $length * $packet_nb; exit; # don't forget this } } libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/000077500000000000000000000000001333534323000270745ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/client-readline.pl000077500000000000000000000012011333534323000324650ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; die $! unless print $sock "$exp_cnt,$exp_len\n"; $exp_len += 1; my $cnt = 0; while (my $line = <$sock>) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/client-recv.pl000077500000000000000000000030521333534323000316470ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; $sock->send("$exp_cnt,$exp_len\n"); $exp_len += 1; my $cnt = 0; while (my $line = read_line($sock)) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; exit 0; # implementation of application layer buffering # general concept: # 1. try read 4K block of data # 2. scan if for \n # 3. if found, return line # 4. go to step 1 my $str; my $potential_data_in_str; sub read_line { my $sock = shift; if ($str && $potential_data_in_str) { my $idx = index($str, "\n"); if ($idx >= 0) { return substr($str, 0, $idx + 1, ''); } $potential_data_in_str = 0; } while (1) { my $buf; my $res = $sock->recv($buf, 4096); return unless defined $res; return unless $buf; my $idx = index($buf, "\n"); if ($idx >= 0) { my $line = $str ? $str . substr($buf, 0, $idx + 1, '') : substr($buf, 0, $idx + 1, ''); $str = $buf; $potential_data_in_str = 1; return $line; } else { $str .= $buf; } } } libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/client-sysread.pl000077500000000000000000000030721333534323000323640ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Time::HiRes; use IO::Socket::INET; my $exp_cnt = $ARGV[0]; my $exp_len = $ARGV[1]; my $start_time = Time::HiRes::time(); my $sock = IO::Socket::INET->new( PeerAddr => 'localhost', PeerPort => '1234', Proto => 'tcp', ); die $! unless $sock; die $! unless print $sock "$exp_cnt,$exp_len\n"; $exp_len += 1; my $cnt = 0; while (my $line = read_line($sock)) { my $len = length($line); print "LENGTH MISMATCH $len != $exp_len\n" if $len != $exp_len; ++$cnt; } printf "%.5f\n", (Time::HiRes::time() - $start_time); print "CNT MISMATCH: $cnt != $exp_cnt\n" if $cnt != $exp_cnt; exit 0; # implementation of application layer buffering # general concept: # 1. try read 4K block of data # 2. scan if for \n # 3. if found, return line # 4. go to step 1 my $str; my $potential_data_in_str; sub read_line { my $sock = shift; if ($str && $potential_data_in_str) { my $idx = index($str, "\n"); if ($idx >= 0) { return substr($str, 0, $idx + 1, ''); } $potential_data_in_str = 0; } while (1) { my $buf; my $len = sysread($sock, $buf, 4096); return unless defined $len; return unless $len; my $idx = index($buf, "\n"); if ($idx >= 0) { my $line = $str ? $str . substr($buf, 0, $idx + 1, '') : substr($buf, 0, $idx + 1, ''); $str = $buf; $potential_data_in_str = 1; return $line; } else { $str .= $buf; } } } libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/run.pl000077500000000000000000000016061333534323000302430ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; if (my $pid = fork()) { #parent print "starting server-generator\n"; system('./server-generator.pl'); kill 'KILL', $pid; } else { #child sleep(1); $| = 1; my $total_bytes = 5_000_000; my @lengths = (1, 2, 3, 4, 10, 50, 100, 1_000, 10_000); foreach my $length (@lengths) { my $cnt = int($total_bytes / $length); printf "--- # of lines: %d --- len of line: %d bytes ---\n", $cnt, $length; my $rl_res = `./client-readline.pl $cnt $length`; chomp $rl_res; print "readline: $rl_res sec\n"; my $sr_res = `./client-sysread.pl $cnt $length`; chomp $sr_res; print "sysread: $sr_res sec\n"; my $rc_res = `./client-recv.pl $cnt $length`; chomp $rc_res; print "recv: $rc_res sec\n"; } print "hit ctrl+c to stop the server\n"; } libredis-fast-perl-0.22+dfsg/tools/benchmarks/readline_vs_sysread_vs_recv/server-generator.pl000077500000000000000000000010151333534323000327230ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use IO::Socket::INET; $| = 1; my $sock = IO::Socket::INET->new( Listen => 5, LocalAddr => 'localhost', LocalPort => 1234, Proto => 'tcp', ReuseAddr => 1, ); die $! unless $sock; die $! unless $sock->listen(); while (my $client = $sock->accept()) { my $line = <$client>; chomp $line; my ($cnt, $len) = split(',', $line); next unless $cnt || $len; for (my $i = 1; $i <= $cnt; ++$i) { print $client '.' x $len, "\n"; } } libredis-fast-perl-0.22+dfsg/typemap000066400000000000000000000000411333534323000174400ustar00rootroot00000000000000Redis::Fast T_PTROBJ libredis-fast-perl-0.22+dfsg/xt/000077500000000000000000000000001333534323000164765ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/xt/release/000077500000000000000000000000001333534323000201165ustar00rootroot00000000000000libredis-fast-perl-0.22+dfsg/xt/release/kwalitee.t000066400000000000000000000003461333534323000221130ustar00rootroot00000000000000BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'Skip because AUTHOR_TESTING is unset'); } } use Test::More; use Test::Kwalitee::Extra qw(:retry 1 :experimental);