Test-Mock-Redis-0.20000755000765000024 013045273257 13513 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/Build.PL000444000765000024 302713045273257 15146 0ustar00jeffstaff000000000000use strict; use warnings; use Module::Build 0.4004; my $builder = Module::Build->new( perl => '5.006_001', module_name => 'Test::Mock::Redis', license => 'perl', dist_author => q{Jeff Lavallee }, dist_abstract => 'use Redis; without redis', dist_version_from => 'lib/Test/Mock/Redis.pm', meta_merge => { resources => { bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis', repository => 'http://github.com/jlavallee/Test-Mock-Redis/', }, no_index => { package => [ 'Test::Mock::Redis::PossiblyVolatile', 'Test::Mock::Redis::List', 'Test::Mock::Redis::Hash', 'Test::Mock::Redis::ZSet', 'Test::Mock::Redis::Set', ], }, }, build_requires => { 'Test::More' => '0.88', 'Test::Fatal' => 0, 'Test::Deep' => 0, 'Test::Deep::UnorderedPairs' => 0, }, requires => { 'Scalar::Util' => 0, 'Class::Method::Modifiers' => 0, 'Package::Stash' => '0.34', 'namespace::clean' => 0, 'Try::Tiny' => 0, }, configure_requires => { 'Module::Build' => 0.4 }, add_to_cleanup => [ 'Test-Mock-Redis-*' ], create_makefile_pl => 'traditional', ); $builder->create_build_script(); Test-Mock-Redis-0.20/Changes000444000765000024 425313045273257 15147 0ustar00jeffstaff000000000000Revision history for Perl module Test::Mock::Redis 0.20 2017-02-03 - support negative indicies (Gianni Ceccarelli) - zrevrange sort fix (Gianni Ceccarelli) - Support EX, PX, NX, and XX for set (Nigel Gregoire) 0.19 2015-12-18 - fix for hexists return value (Chris Reinhardt) 0.18 2015-08-03 - fix for keys match (Yaakov Shaul) 0.17 2015-05-15 - zrevrangebyscore command added (Kevin Goess) - zrangebyscore sort fixes (Kevin Goess) 0.16 2015-04-14 - rpoplpush command added (Keith Broughton) 0.15 2014-08-29 - watch/unwatch commands added (Ian Burrell) - del command fixes (Ian Burrell) 0.14 2013-08-31 - change_num_databases class method added (Kevin Goess) 0.13 2013-08-27 - support for changing number of available databases (Kevin Goess) 0.12 2013-12-06 - support for pipelined calls, using callback subs (Karen Etheridge) 0.11 2013-18-05 - atomic transactions ('multi', 'exec', 'discard') now supported: http://redis.io/topics/transactions (Karen Etheridge) 0.10 2013-16-05 - 'info' output brought up-to-date w/redis 2.6 - fixed output for these commands: (Karen Etheridge) should return OK, not 1: auth set setex mset rename ltrim lset select save should return a list length, not the list itself: rpush lpush rpushx lpushx 0.09 2013-26-02 - Expired keys are not returned in the KEYS list (Karen Etheridge) 0.08 2012-13-04 - Correct type is returned for non-existent keys (RT#76534, Karen Etheridge) 0.07 2011-05-10 - Fix for RT-71461, incorrect rename behavior 0.04 2011-18-02 - Made error conditions consistent with Redis.pm's behavior 0.03 2011-16-02 - Pay attention to the server argument to new - now a singleton per server, just like redis - Fixed Test::Exception dependency 0.02 2011-14-02 - More redis functions, including auth, append, strlen, getset, mset & msetnx 0.01 2011-13-02 - First version, released on an unsuspecting world. Test-Mock-Redis-0.20/MANIFEST000444000765000024 55713045273257 14770 0ustar00jeffstaff000000000000Build.PL Changes lib/Test/Mock/Redis.pm Makefile.PL MANIFEST This list of files META.json META.yml README t/00-load.t t/01-basic.t t/02-new.t t/05-server.t t/06-keys.t t/07-expires.t t/08-get-set.t t/09-list.t t/10-hash.t t/11-sets.t t/12-sorted-sets.t t/13-multi.t t/14-pipeline.t t/15-import.t t/boilerplate.t t/manifest.t t/pod.t t/tlib/Test/SpawnRedisServer.pm Test-Mock-Redis-0.20/META.json000444000765000024 421713045273257 15275 0ustar00jeffstaff000000000000{ "abstract" : "use Redis; without redis", "author" : [ "Jeff Lavallee " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.422", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Mock-Redis", "no_index" : { "package" : [ "Test::Mock::Redis::PossiblyVolatile", "Test::Mock::Redis::List", "Test::Mock::Redis::Hash", "Test::Mock::Redis::ZSet", "Test::Mock::Redis::Set" ] }, "prereqs" : { "build" : { "requires" : { "Test::Deep" : "0", "Test::Deep::UnorderedPairs" : "0", "Test::Fatal" : "0", "Test::More" : "0.88" } }, "configure" : { "requires" : { "Module::Build" : "0.4" } }, "runtime" : { "requires" : { "Class::Method::Modifiers" : "0", "Package::Stash" : "0.34", "Scalar::Util" : "0", "Try::Tiny" : "0", "namespace::clean" : "0" } } }, "provides" : { "Test::Mock::Redis" : { "file" : "lib/Test/Mock/Redis.pm", "version" : "0.20" }, "Test::Mock::Redis::Hash" : { "file" : "lib/Test/Mock/Redis.pm" }, "Test::Mock::Redis::List" : { "file" : "lib/Test/Mock/Redis.pm" }, "Test::Mock::Redis::PossiblyVolatile" : { "file" : "lib/Test/Mock/Redis.pm" }, "Test::Mock::Redis::Set" : { "file" : "lib/Test/Mock/Redis.pm" }, "Test::Mock::Redis::ZSet" : { "file" : "lib/Test/Mock/Redis.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/jlavallee/Test-Mock-Redis/" } }, "version" : "0.20", "x_serialization_backend" : "JSON::PP version 2.27300" } Test-Mock-Redis-0.20/META.yml000444000765000024 262613045273257 15127 0ustar00jeffstaff000000000000--- abstract: 'use Redis; without redis' author: - 'Jeff Lavallee ' build_requires: Test::Deep: '0' Test::Deep::UnorderedPairs: '0' Test::Fatal: '0' Test::More: '0.88' configure_requires: Module::Build: '0.4' dynamic_config: 1 generated_by: 'Module::Build version 0.422, 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: Test-Mock-Redis no_index: package: - Test::Mock::Redis::PossiblyVolatile - Test::Mock::Redis::List - Test::Mock::Redis::Hash - Test::Mock::Redis::ZSet - Test::Mock::Redis::Set provides: Test::Mock::Redis: file: lib/Test/Mock/Redis.pm version: '0.20' Test::Mock::Redis::Hash: file: lib/Test/Mock/Redis.pm Test::Mock::Redis::List: file: lib/Test/Mock/Redis.pm Test::Mock::Redis::PossiblyVolatile: file: lib/Test/Mock/Redis.pm Test::Mock::Redis::Set: file: lib/Test/Mock/Redis.pm Test::Mock::Redis::ZSet: file: lib/Test/Mock/Redis.pm requires: Class::Method::Modifiers: '0' Package::Stash: '0.34' Scalar::Util: '0' Try::Tiny: '0' namespace::clean: '0' resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis license: http://dev.perl.org/licenses/ repository: http://github.com/jlavallee/Test-Mock-Redis/ version: '0.20' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-Mock-Redis-0.20/Makefile.PL000444000765000024 127413045273257 15626 0ustar00jeffstaff000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4220 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Test::Mock::Redis', 'INSTALLDIRS' => 'site', 'VERSION_FROM' => 'lib/Test/Mock/Redis.pm', 'PL_FILES' => {}, 'EXE_FILES' => [], 'PREREQ_PM' => { 'Test::Deep::UnorderedPairs' => 0, 'Try::Tiny' => 0, 'Class::Method::Modifiers' => 0, 'Test::More' => '0.88', 'Scalar::Util' => 0, 'Test::Deep' => 0, 'namespace::clean' => 0, 'Test::Fatal' => 0, 'Package::Stash' => '0.34' } ) ; Test-Mock-Redis-0.20/README000444000765000024 171613045273257 14535 0ustar00jeffstaff000000000000Test-Mock-Redis INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Test::Mock::Redis You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Test-Mock-Redis CPAN Ratings http://cpanratings.perl.org/d/Test-Mock-Redis Search CPAN http://search.cpan.org/dist/Test-Mock-Redis/ LICENSE AND COPYRIGHT Copyright (C) 2011 Jeff Lavallee This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Test-Mock-Redis-0.20/lib000755000765000024 013045273257 14261 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/lib/Test000755000765000024 013045273257 15200 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/lib/Test/Mock000755000765000024 013045273257 16071 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/lib/Test/Mock/Redis.pm000444000765000024 10770713045273257 17706 0ustar00jeffstaff000000000000package Test::Mock::Redis; use warnings; use strict; use Carp; use Config; use Scalar::Util qw/blessed/; use Class::Method::Modifiers; use Package::Stash; use Try::Tiny; use namespace::clean; # important: clean all subs imported above this line =head1 NAME Test::Mock::Redis - use in place of Redis for unit testing =head1 VERSION Version 0.20 =cut our $VERSION = '0.20'; =head1 SYNOPSIS Test::Mock::Redis can be used in place of Redis for running tests without needing a running redis instance. use Test::Mock::Redis; my $redis = Test::Mock::Redis->new(server => 'whatever'); $redis->set($key, 'some value'); $redis->get($key); ... This module is designed to function as a drop in replacement for Redis.pm for testing purposes. See perldoc Redis and the redis documentation at L =head1 PERSISTENCE The "connection" to the mocked server (and its stored data) will persist beyond the object instance, just like a real Redis server. This means that you do not need to save the instance to this object in order to preserve your data; simply call C with the same server parameter and the same instance will be returned, with all data preserved. =head1 SUBROUTINES/METHODS =head2 new Create a new Test::Mock::Redis object. It can be used in place of a Redis object for unit testing. It accepts the "server" argument, just like Redis.pm's new. =head2 num_databases Redis ships with a default of 16 databases, and that's what this module handles by default. If you need to change that, do use Test::Mock::Redis num_databases => 21; or at run-time Test::Mock::Redis::change_num_databases(21); =cut my $NUM_DBS = 16; sub import { my ($class, %args) = @_; if ($args{num_databases}){ change_num_databases($args{num_databases}); } } sub change_num_databases { $NUM_DBS = shift; } sub _new_db { tie my %hash, 'Test::Mock::Redis::PossiblyVolatile'; return \%hash; } sub _defaults { my @hex = (0..9, 'a'..'f'); return ( _quit => 0, _shutdown => 0, _stash => [ map { _new_db } (1..$NUM_DBS) ], _num_dbs => $NUM_DBS, _db_index => 0, _up_since => time, _last_save => time, _run_id => (join '', map { $hex[rand @hex] } 1..40), # E.G. '0e7e19fc45139fdb26ff3dd35ca6725d9882f1b7', ); } my $instances; sub new { my $class = shift; my %args = @_; my $server = defined $args{server} ? $args{'server'} : 'localhost:6379'; if( $instances->{$server} ){ confess "Could not connect to Redis server at $server" if $instances->{$server}->{_shutdown}; $instances->{$server}->{_quit} = 0; return $instances->{$server}; } my $self = bless {$class->_defaults, server => $server}, $class; $instances->{$server} = $self; return $self; } sub ping { my $self = shift; return !$self->{_shutdown} && !$self->{_quit}; } sub auth { my $self = shift; confess '[auth] ERR wrong number of arguments for \'auth\' command' unless @_; return 'OK'; } sub quit { my $self = shift; my $return = !$self->{_quit}; $self->{_quit} = 1; return $return; } sub shutdown { my $self = shift; $self->{_shutdown} = 1; } sub set { my ( $self, $key, $value, @args ) = @_; my $expires = 0; while (my $option = shift @args) { $option = lc $option; # Only set if key exists if ($option eq 'xx') { return unless $self->exists($key); # Only set if key doesn't exist } elsif ($option eq 'nx') { return if $self->exists($key); # Set expire time (in seconds) } elsif ($option eq 'ex') { my $new_expires = shift @args; if ($new_expires > $expires) { $expires = $new_expires; } # Set expire time (in milliseconds) } elsif ($option eq 'px') { my $new_expires = shift @args; $new_expires /= 1000; # To seconds if ($new_expires > $expires) { $expires = $new_expires; } } else { confess '[error] ERR syntax error'; } } $self->_stash->{$key} = "$value"; if ($expires) { $self->expire($key, $expires); } return 'OK'; } sub setnx { my ( $self, $key, $value ) = @_; return 0 if $self->exists($key); $self->_stash->{$key} = "$value"; return 1; } sub setex { my ( $self, $key, $ttl, $value ) = @_; $self->set($key, $value); $self->expire($key, $ttl); return 'OK'; } sub expire { my ( $self, $key, $ttl ) = @_; return $self->expireat($key, time + $ttl); } sub expireat { my ( $self, $key, $when ) = @_; return 0 unless exists $self->_stash->{$key}; my $slot = $self->_stash; my $tied = tied(%$slot); $tied->expire($key, $when); return 1; } sub persist { my ( $self, $key, $ttl ) = @_; return 0 unless exists $self->_stash->{$key}; my $slot = $self->_stash; my $tied = tied(%$slot); $tied->persist($key); return 1; } sub ttl { my ( $self, $key, $ttl ) = @_; return -1 unless exists $self->_stash->{$key}; my $slot = $self->_stash; my $tied = tied(%$slot); return $tied->ttl($key); } sub exists :method { my ( $self, $key ) = @_; return exists $self->_stash->{$key} ? 1 : 0; } sub get { my ( $self, $key ) = @_; return $self->_stash->{$key}; } sub append { my ( $self, $key, $value ) = @_; $self->_stash->{$key} .= $value; return $self->strlen($key); } sub strlen { my ( $self, $key ) = @_; return do { use bytes; length $self->_stash->{$key}; }; } sub getset { my ( $self, $key, $value ) = @_; #TODO: should return error when original value isn't a string my $old_value = $self->_stash->{$key}; $self->set($key, $value); return $old_value; } sub incr { my ( $self, $key ) = @_; $self->_stash->{$key} ||= 0; return ++$self->_stash->{$key}; } sub incrby { my ( $self, $key, $incr ) = @_; $self->_stash->{$key} ||= 0; return $self->_stash->{$key} += $incr; } sub decr { my ( $self, $key ) = @_; return --$self->_stash->{$key}; } sub decrby { my ( $self, $key, $decr ) = @_; $self->_stash->{$key} ||= 0; return $self->_stash->{$key} -= $decr; } sub mget { my ( $self, @keys ) = @_; return map { $self->_stash->{$_} } @keys; } sub mset { my ( $self, %things ) = @_; @{ $self->_stash }{keys %things} = (values %things); return 'OK'; } sub msetnx { my ( $self, %things ) = @_; $self->exists($_) && return 0 for keys %things; @{ $self->_stash }{keys %things} = (values %things); return 1; } sub del { my ( $self, @keys ) = @_; my $ret = 0; for my $key (@keys) { $ret++ if $self->exists($key); delete $self->_stash->{$key}; } return $ret; } sub type { my ( $self, $key ) = @_; # types are string, list, set, zset and hash return 'none' unless $self->exists($key); my $type = ref $self->_stash->{$key}; return !$type ? 'string' : $type eq 'Test::Mock::Redis::Hash' ? 'hash' : $type eq 'Test::Mock::Redis::Set' ? 'set' : $type eq 'Test::Mock::Redis::ZSet' ? 'zset' : $type eq 'Test::Mock::Redis::List' ? 'list' : 'unknown' ; } sub keys :method { my ( $self, $match ) = @_; confess q{[KEYS] ERR wrong number of arguments for 'keys' command} unless defined $match; # TODO: we're not escaping other meta-characters $match =~ s/(?_stash->{$_} } grep { /^$match/ } keys %{ $self->_stash }]}; } sub randomkey { my $self = shift; return ( keys %{ $self->_stash } )[ int(rand( scalar keys %{ $self->_stash } )) ] ; } sub rename { my ( $self, $from, $to, $whine ) = @_; confess '[rename] ERR source and destination objects are the same' if $from eq $to; confess '[rename] ERR no such key' unless $self->exists($from); confess 'rename to existing key' if $whine && $self->_stash->{$to}; $self->_stash->{$to} = $self->_stash->{$from}; delete $self->_stash->{$from}; return 'OK'; } sub renamenx { my ( $self, $from, $to ) = @_; return 0 if $self->exists($to); return $self->rename($from, $to); } sub dbsize { my $self = shift; return scalar keys %{ $self->_stash }; } sub rpush { my ( $self, $key, $value ) = @_; $self->_make_list($key); push @{ $self->_stash->{$key} }, "$value"; return scalar @{ $self->_stash->{$key} }; } sub lpush { my ( $self, $key, $value ) = @_; confess "[lpush] ERR Operation against a key holding the wrong kind of value" unless !$self->exists($key) or $self->_is_list($key); $self->_make_list($key); unshift @{ $self->_stash->{$key} }, "$value"; return scalar @{ $self->_stash->{$key} }; } sub rpushx { my ( $self, $key, $value ) = @_; return unless $self->_is_list($key); push @{ $self->_stash->{$key} }, "$value"; return scalar @{ $self->_stash->{$key} }; } sub lpushx { my ( $self, $key, $value ) = @_; return unless $self->_is_list($key); unshift @{ $self->_stash->{$key} }, "$value"; return scalar @{ $self->_stash->{$key} }; } sub rpoplpush { my ( $self, $source_key, $destination_key ) = @_; my $popped_element = $self->rpop( $source_key ) or return; $self->lpush( $destination_key, $popped_element ); return $popped_element; } sub llen { my ( $self, $key ) = @_; return 0 unless $self->exists($key); return scalar @{ $self->_stash->{$key} }; } sub lrange { my ( $self, $key, $start, $end ) = @_; my $array = $self->_stash->{$key}; ($start,$end) = _normalize_range(scalar(@$array),$start,$end); return @{ $array }[$start..$end]; } sub ltrim { my ( $self, $key, $start, $end ) = @_; my $array = $self->_stash->{$key}; ($start,$end) = _normalize_range(scalar(@$array),$start,$end); $self->_stash->{$key} = [ @{ $array }[$start..$end] ]; return 'OK'; } sub lindex { my ( $self, $key, $index ) = @_; my $array = $self->_stash->{$key}; $index = _normalize_index(scalar(@$array),$index); return $array->[$index]; } sub lset { my ( $self, $key, $index, $value ) = @_; my $array = $self->_stash->{$key}; $index = _normalize_index(scalar(@$array),$index); $array->[$index] = "$value"; return 'OK'; } sub lrem { my ( $self, $key, $count, $value ) = @_; my $removed; my @indicies = $count < 0 ? ($#{ $self->_stash->{$key} }..0) : (0..$#{ $self->_stash->{$key} }) ; $count = abs $count; for my $index (@indicies){ if($self->_stash->{$key}->[$index] eq $value){ splice @{ $self->_stash->{$key} }, $index, 1; last if $count && ++$removed >= $count; } } return $removed; } sub lpop { my ( $self, $key ) = @_; return undef unless $self->exists($key); return shift @{ $self->_stash->{$key} }; } sub rpop { my ( $self, $key ) = @_; return undef unless $self->exists($key); return pop @{ $self->_stash->{$key} }; } sub select { my ( $self, $index ) = @_; my $max_index = $#{ $self->{_stash} }; if ($index > $max_index ){ die "You called select($index), but max allowed is $max_index unless you configure more databases"; } $self->{_db_index} = $index; return 'OK'; } sub _stash { my ( $self, $index ) = @_; $index = $self->{_db_index} unless defined $index; return $self->{_stash}->[$index]; } sub sadd { my ( $self, $key, $value ) = @_; $self->_make_set($key); my $return = exists $self->_stash->{$key}->{$value} ? 0 : 1; $self->_stash->{$key}->{$value} = 1; return $return; } sub scard { my ( $self, $key ) = @_; return $self->_is_set($key) ? scalar $self->smembers($key) : 0; } sub sismember { my ( $self, $key, $value ) = @_; return exists $self->_stash->{$key}->{$value} ? 1 : 0; } sub srem { my ( $self, $key, $value ) = @_; return 0 unless exists $self->_stash->{$key} && exists $self->_stash->{$key}->{$value}; delete $self->_stash->{$key}->{$value}; return 1; } sub spop { my ( $self, $key ) = @_; return undef unless $self->_is_set($key); my $value = $self->srandmember($key); delete $self->_stash->{$key}->{$value}; return $value; } sub smove { my ( $self, $source, $dest, $value ) = @_; confess "[smove] ERR Operation against a key holding the wrong kind of value" if ( $self->exists($source) and not $self->_is_set($source) ) or ( $self->exists($dest) and not $self->_is_set($dest) ); if( (delete $self->_stash->{$source}->{$value}) ){ $self->_make_set($dest) unless $self->_is_set($dest); $self->_stash->{$dest}->{$value} = 1; return 1; } return 0; # guess it wasn't in there } sub srandmember { my ( $self, $key ) = @_; return undef unless $self->_is_set($key); return ($self->smembers($key))[rand int $self->scard($key)]; } sub smembers { my ( $self, $key ) = @_; return keys %{ $self->_stash->{$key} }; } sub sinter { my ( $self, @keys ) = @_; my $r = {}; foreach my $key (@keys){ $r->{$_}++ for keys %{ $self->_stash->{$key} }; } return grep { $r->{$_} >= @keys } keys %$r; } sub sinterstore { my ( $self, $dest, @keys ) = @_; $self->_stash->{$dest} = { map { $_ => 1 } $self->sinter(@keys) }; bless $self->_stash->{$dest}, 'Test::Mock::Redis::Set'; return $self->scard($dest); } sub sunion { my ( $self, @keys ) = @_; my $r = {}; foreach my $key (@keys){ $r->{$_}++ for keys %{ $self->_stash->{$key} }; } return grep { $r->{$_} >= 1 } keys %$r; } sub sunionstore { my ( $self, $dest, @keys ) = @_; $self->_stash->{$dest} = { map { $_ => 1 } $self->sunion(@keys) }; bless $self->_stash->{$dest}, 'Test::Mock::Redis::Set'; return $self->scard($dest); } sub sdiff { my ( $self, $start, @keys ) = @_; my $r = { map { $_ => 0 } keys %{ $self->_stash->{$start} } }; foreach my $key (@keys){ $r->{$_}++ for keys %{ $self->_stash->{$key} }; } return grep { $r->{$_} == 0 } keys %$r; } sub sdiffstore { my ( $self, $dest, $start, @keys ) = @_; $self->_stash->{$dest} = { map { $_ => 1 } $self->sdiff($start, @keys) }; bless $self->_stash->{$dest}, 'Test::Mock::Redis::Set'; return $self->scard($dest); } sub hset { my ( $self, $key, $hkey, $value ) = @_; confess '[hset] ERR Operation against a key holding the wrong kind of value' if $self->exists($key) and !$self->_is_hash($key); $self->_make_hash($key); my $ret = exists $self->_stash->{$key}->{$hkey} ? 0 : 1; $self->_stash->{$key}->{$hkey} = $value; return $ret; } sub hsetnx { my ( $self, $key, $hkey, $value ) = @_; return 0 if exists $self->_stash->{$key}->{$hkey}; $self->_make_hash($key); $self->_stash->{$key}->{$hkey} = "$value"; return 1; } sub hmset { my ( $self, $key, %hash ) = @_; $self->_make_hash($key); foreach my $hkey ( keys %hash ){ $self->hset($key, $hkey, $hash{$hkey}); } return 'OK'; } sub hget { my ( $self, $key, $hkey ) = @_; return undef unless $self->_is_hash($key); return $self->_stash->{$key}->{$hkey}; } sub hmget { my ( $self, $key, @hkeys ) = @_; return undef unless $self->_is_hash($key); return map { $self->_stash->{$key}->{$_} } @hkeys; } sub hexists { my ( $self, $key, $hkey ) = @_; confess '[hexists] ERR Operation against a key holding the wrong kind of value' if $self->exists($key) and !$self->_is_hash($key); return exists $self->_stash->{$key}->{$hkey} ? 1 : 0; } sub hdel { my ( $self, $key, $hkey ) = @_; return 0 unless $self->_is_hash($key); my $ret = $self->hexists($key, $hkey); delete $self->_stash->{$key}->{$hkey}; return $ret; } sub hincrby { confess "[hincrby] ERR wrong number of arguments for 'hincrby' command" unless @_ == 4; my ( $self, $key, $hkey, $incr ) = @_; confess '[hexists] ERR Operation against a key holding the wrong kind of value' if $self->exists($key) and !$self->_is_hash($key); confess "[hincrby] ERR hash value is not an integer" if $self->hexists($key, $hkey) # it exists and $self->hget($key, $hkey) !~ /^-?\d+$|^$/ # and it doesn't look like an integer (and it isn't empty) ; $self->_make_hash($key) unless $self->_is_hash($key); $self->_stash->{$key}->{$hkey} ||= 0; return $self->_stash->{$key}->{$hkey} += $incr; } sub hlen { my ( $self, $key ) = @_; return 0 unless $self->_is_hash($key); return scalar values %{ $self->_stash->{$key} }; } sub hkeys { my ( $self, $key ) = @_; confess '[hkeys] ERR Operation against a key holding the wrong kind of value' if $self->exists($key) and !$self->_is_hash($key); return () unless $self->exists($key); return keys %{ $self->_stash->{$key} }; } sub hvals { my ( $self, $key ) = @_; confess '[hvals] ERR Operation against a key holding the wrong kind of value' if $self->exists($key) and !$self->_is_hash($key); return values %{ $self->_stash->{$key} }; } sub hgetall { my ( $self, $key ) = @_; confess "[hgetall] ERR Operation against a key holding the wrong kind of value" if $self->exists($key) and !$self->_is_hash($key); return $self->exists( $key ) ? %{ $self->_stash->{$key} } : (); } sub move { my ( $self, $key, $to ) = @_; return 0 unless !exists $self->_stash($to)->{$key} && exists $self->_stash->{$key} ; $self->_stash($to)->{$key} = $self->_stash->{$key}; delete $self->_stash->{$key}; return 1; } sub flushdb { my $self = shift; $self->{_stash}->[$self->{_db_index}] = _new_db; } sub flushall { my $self = shift; $self->{_stash} = [ map { _new_db }(1..$NUM_DBS) ]; } sub sort { my ( $self, $key, $how ) = @_; my $cmp = do { no warnings 'uninitialized'; $how =~ /\bALPHA\b/ ? $how =~ /\bDESC\b/ ? sub { $b cmp $a } : sub { $a cmp $b } : $how =~ /\bDESC\b/ ? sub { $b <=> $a } : sub { $a <=> $b } ; }; return sort $cmp @{ $self->_stash->{$key} }; } sub save { my $self = shift; $self->{_last_save} = time; return 'OK'; } sub bgsave { my $self = shift; return $self->save; } sub lastsave { my $self = shift; return $self->{_last_save}; } sub info { my $self = shift; return { aof_current_rewrite_time_sec => '-1', aof_enabled => '0', aof_last_bgrewrite_status => 'ok', aof_last_rewrite_time_sec => '-1', aof_rewrite_in_progress => '0', aof_rewrite_scheduled => '0', arch_bits => $Config{use64bitint } ? '64' : '32', blocked_clients => '0', client_biggest_input_buf => '0', client_longest_output_list => '0', connected_clients => '1', connected_slaves => '0', evicted_keys => '0', expired_keys => '0', gcc_version => '4.2.1', instantaneous_ops_per_sec => '568', keyspace_hits => '272', keyspace_misses => '0', latest_fork_usec => '0', loading => '0', lru_clock => '1994309', mem_allocator => 'libc', mem_fragmentation_ratio => '1.61', multiplexing_api => 'kqueue', os => $Config{osname}.' '.$Config{osvers}, # should be like 'Darwin 12.2.1 x86_64', this is close process_id => $$, pubsub_channels => '0', pubsub_patterns => '0', rdb_bgsave_in_progress => '0', rdb_changes_since_last_save => '0', rdb_current_bgsave_time_sec => '-1', rdb_last_bgsave_status => 'ok', rdb_last_bgsave_time_sec => '-1', rdb_last_save_time => '1362120372', redis_git_dirty => '0', redis_git_sha1 => '34b420db', redis_mode => 'standalone', redis_version => '2.6.10', rejected_connections => '0', role => 'master', run_id => $self->{_run_id}, tcp_port => '11084', total_commands_processed => '1401', total_connections_received => '1', uptime_in_days => (time - $self->{_up_since}) / 60 / 60 / 24, uptime_in_seconds => time - $self->{_up_since}, used_cpu_sys => '0.04', used_cpu_sys_children => '0.00', used_cpu_user => '0.02', used_cpu_user_children => '0.00', used_memory => '1056288', used_memory_human => '1.01M', used_memory_lua => '31744', used_memory_peak => '1055728', used_memory_peak_human => '1.01M', used_memory_rss => '1699840', map { 'db'.$_ => sprintf('keys=%d,expires=%d', scalar keys %{ $self->_stash($_) }, $self->_expires_count_for_db($_), ) } grep { scalar keys %{ $self->_stash($_) } > 0 } (0..15) }; } sub _expires_count_for_db { my ( $self, $db_index ) = @_; my $slot = $self->_stash($db_index); my $tied = tied(%$slot); $tied->expire_count; } sub zadd { my ( $self, $key, $score, $value ) = @_; $self->_make_zset($key); my $ret = exists $self->_stash->{$key}->{$value} ? 0 : 1; $self->_stash->{$key}->{$value} = $score; return $ret; } sub zscore { my ( $self, $key, $value ) = @_; return $self->_stash->{$key}->{$value}; } sub zincrby { my ( $self, $key, $score, $value ) = @_; $self->_stash->{$key}->{$value} ||= 0; return $self->_stash->{$key}->{$value} += $score; } sub zrank { my ( $self, $key, $value ) = @_; my $rank = 0; foreach my $elem ( $self->zrange($key, 0, $self->zcard($key)) ){ return $rank if $value eq $elem; $rank++; } return undef; } sub zrevrank { my ( $self, $key, $value ) = @_; my $rank = 0; foreach my $elem ( $self->zrevrange($key, 0, $self->zcard($key)) ){ return $rank if $value eq $elem; $rank++; } return undef; } sub zrange { my ( $self, $key, $start, $stop, $withscores ) = @_; my $length = $self->zcard($key); ($start,$stop) = _normalize_range($length,$start,$stop); return map { $withscores ? ( $_, $self->zscore($key, $_) ) : $_ } ( map { $_->[0] } sort { $a->[1] <=> $b->[1] || $a->[0] cmp $b->[0] } map { [ $_, $self->_stash->{$key}->{$_} ] } keys %{ $self->_stash->{$key} } )[$start..$stop] ; } sub zrevrange { my ( $self, $key, $start, $stop, $withscores ) = @_; my $length = $self->zcard($key); ($start,$stop) = _normalize_range($length,$start,$stop); return map { $withscores ? ( $_, $self->zscore($key, $_) ) : $_ } ( map { $_->[0] } sort { $b->[1] <=> $a->[1] || $b->[0] cmp $a->[0] } map { [ $_, $self->_stash->{$key}->{$_} ] } keys %{ $self->_stash->{$key} } )[$start..$stop] ; } sub zrangebyscore { my ( $self, $key, $min, $max, $withscores ) = @_; my $min_inc = !( $min =~ s/^\(// ); my $max_inc = !( $max =~ s/^\(// ); my $cmp = !$min_inc && !$max_inc ? sub { $self->zscore($key, $_[0]) > $min && $self->zscore($key, $_[0]) < $max } : !$min_inc ? sub { $self->zscore($key, $_[0]) > $min && $self->zscore($key, $_[0]) <= $max } : !$max_inc ? sub { $self->zscore($key, $_[0]) >= $min && $self->zscore($key, $_[0]) < $max } : sub { $self->zscore($key, $_[0]) >= $min && $self->zscore($key, $_[0]) <= $max } ; return map { $withscores ? ( $_, $self->zscore($key, $_) ) : $_ } grep { $cmp->($_) } $self->zrange($key, 0, $self->zcard($key)-1); } # note max and min are reversed from zrangebyscore sub zrevrangebyscore { my ( $self, $key, $max, $min, $withscores ) = @_; my $not_with_scores = 0; return map { $withscores ? ( $_, $self->zscore($key, $_) ) : $_ } reverse $self->zrangebyscore($key, $min, $max, $not_with_scores); } sub zcount { my ( $self, $key, $min, $max ) = @_; return scalar $self->zrangebyscore($key, $min, $max); } sub zcard { my ( $self, $key ) = @_; return scalar values %{ $self->_stash->{$key} } } sub zremrangebyrank { my ( $self, $key, $start, $stop ) = @_; my @remove = $self->zrange($key, $start, $stop); delete $self->_stash->{$key}->{$_} for @remove; return scalar @remove; } sub zremrangebyscore { my ( $self, $key, $start, $stop ) = @_; my @remove = $self->zrangebyscore($key, $start, $stop); delete $self->_stash->{$key}->{$_} for @remove; return scalar @remove; } =head1 PIPELINING See L -- most methods support the use of a callback sub as the final argument. For this implementation, the callback sub will be called immediately (before the result of the original method is returned), and C does nothing. Combining pipelining with C/C is not supported. =head1 TODO Lots! Not all Redis functionality is implemented. The test files that output "TODO" are still to be done. The top of all test files [except 01-basic.t] has the list of commands tested or to-be tested in the file. Those marked with an "x" are pretty well-tested. Those marked with an "o" need help. Those that are unmarked have no tests, or are un-implemented. For example: x AUTH <--- has some tests o KEYS <--- only partially tested and/or implemented ZINTERSTORE <--- not tested (or maybe not implemented) Beyond that, it would be neat to add methods to inspect how often keys were accessed and get other information that allows the module user to confirm that their code interacted with redis (or Test::Mock::Redis) as they expected. =head1 AUTHOR Jeff Lavallee, C<< >> =head1 SEE ALSO The real Redis.pm client whose interface this module mimics: L =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Mock::Redis You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Salvatore Sanfilippo for redis, of course! Dobrica Pavlinusic & Pedro Melo for Redis.pm The following people have contributed to I: =over =item * Chris Reinhardt =item * Ian Burrell =item * Gianni Ceccarelli =item * Karen Etheridge =item * Keith Broughton =item * Kevin Goess =item * Neil Bowers =item * Nigel Gregoire =item * Yaakov Shaul =back =head1 LICENSE AND COPYRIGHT Copyright 2015 Jeff Lavallee. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See L for more information. =cut sub _normalize_index { my ( $length, $index ) = @_; $index += $length if $index < 0; return $index; } sub _normalize_range { my ( $length, $start, $end ) = @_; $start = _normalize_index($length,$start); $end = _normalize_index($length,$end); $end = $length-1 if $end >= $length; return ($start,$end); } sub _is_list { my ( $self, $key ) = @_; return $self->exists($key) && blessed $self->_stash->{$key} && $self->_stash->{$key}->isa('Test::Mock::Redis::List') ; } sub _make_list { my ( $self, $key ) = @_; $self->_stash->{$key} = Test::Mock::Redis::List->new unless $self->_is_list($key); } sub _is_hash { my ( $self, $key ) = @_; return $self->exists($key) && blessed $self->_stash->{$key} && $self->_stash->{$key}->isa('Test::Mock::Redis::Hash') ; } sub _make_hash { my ( $self, $key ) = @_; $self->_stash->{$key} = Test::Mock::Redis::Hash->new unless $self->_is_hash($key); } sub _is_set { my ( $self, $key ) = @_; return $self->exists($key) && blessed $self->_stash->{$key} && $self->_stash->{$key}->isa('Test::Mock::Redis::Set') ; } sub _make_set { my ( $self, $key ) = @_; $self->_stash->{$key} = Test::Mock::Redis::Set->new unless $self->_is_set($key); } sub _is_zset { my ( $self, $key ) = @_; return $self->exists($key) && blessed $self->_stash->{$key} && $self->_stash->{$key}->isa('Test::Mock::Redis::ZSet') ; } sub _make_zset { my ( $self, $key ) = @_; $self->_stash->{$key} = Test::Mock::Redis::ZSet->new unless $self->_is_zset($key); } # MULTI/EXEC/DISCARD: http://redis.io/topics/transactions sub multi { my ( $self ) = @_; confess '[multi] ERR MULTI calls can not be nested' if defined $self->{_multi_commands}; # set up the list for storing commands sent between MULTI and EXEC/DISCARD $self->{_multi_commands} = []; return 'OK'; } # methods that return a list, rather than a single value my @want_list = qw(mget keys lrange smembers sinter sunion sdiff hmget hkeys hvals hgetall sort zrange zrevrange zrangebyscore); my %want_list = map { $_ => 1 } @want_list; sub exec { my ( $self ) = @_; # we are going to commit all the changes we saved up; # replay them now and return all their output confess '[exec] ERR EXEC without MULTI' if not defined $self->{_multi_commands}; my @commands = @{$self->{_multi_commands}}; delete $self->{_multi_commands}; # replay all the queries that were queued up # the returned result is a nested array of the results of all the commands my @exceptions; my @results = map { my ($method, @args) = @$_; my @result = try { $self->$method(@args) } catch { push @exceptions, $_; (); }; $want_list{$method} ? \@result : $result[0]; } @commands; s/^\[\w+\] // for @exceptions; confess('[exec] ', join('; ', @exceptions)) if @exceptions; return @results; } sub discard { my ( $self ) = @_; confess '[discard] ERR DISCARD without MULTI' if not defined $self->{_multi_commands}; # discard all the accumulated commands, without executing them delete $self->{_multi_commands}; return 'OK'; } sub watch { my ($self) = shift; confess '[watch] ERR wrong number of arguments for \'watch\' command' unless @_; return 'OK'; } sub unwatch { my ($self) = shift; confess '[error] ERR wrong number of arguments for \'unwatch\' command' if @_; return 'OK'; } # now that we've defined all our subs, we need to wrap them all in logic that # can check if we are in the middle of a MULTI, and if so, queue up the # commands for later replaying. my %no_transaction_wrap_methods = ( new => 1, multi => 1, exec => 1, discard => 1, quit => 1, import => 1, change_num_databases => 1, ); my @transaction_wrapped_methods = grep { !/^_/} grep { not $no_transaction_wrap_methods{$_} } Package::Stash->new(__PACKAGE__)->list_all_symbols('CODE'); foreach my $method (@transaction_wrapped_methods) { around $method => sub { my $orig = shift; my $self = shift; # pass command through if we are not handling a MULTI return $self->$orig(@_) if not defined $self->{_multi_commands}; push @{$self->{_multi_commands}}, [ $method, @_ ]; return 'QUEUED'; }; } # PIPELINING SUPPORT # these method modifications must be done after (over top of) the modification # for transactions, as we need to check for/extract the $cb first. my %no_pipeline_wrap_methods = ( new => 1, multi => 1, discard => 1, quit => 1, ping => 1, subscribe => 1, unsubscribe => 1, psubscribe => 1, punsubscribe => 1, wait_all_responses => 1, ); my @pipeline_wrapped_methods = grep { !/^_/} grep { not $no_pipeline_wrap_methods{$_} } Package::Stash->new(__PACKAGE__)->list_all_symbols('CODE'); # this is a bit messy, and the wantarray logic may not be quite right. # Alternatively, we could implement all this by reusing the logic in the real # Redis.pm -- subclass Redis, override new/multi/exec/discard (and probably # some other special functions), and have __run_cmd use a dispatch table to # call all our overridden implementations. foreach my $method (@pipeline_wrapped_methods) { around $method => sub { my $orig = shift; my $self = shift; my @args = @_; my $cb = @args && ref $args[-1] eq 'CODE' ? pop @args : undef; return $self->$orig(@args) if not $cb; # this may be officially supported eventually -- see # https://github.com/melo/perl-redis/issues/17 # and "Pipeline management" in the Redis docs # To make this work, we just need to special-case exec, to collect all the # results and errors in tuples and send that to the $cb die 'cannot combine pipelining with MULTI' if $self->{_multi_commands}; # We could also implement this with a queue, not bothering to process # the commands until wait_all_responses is called - but then we need to # make sure to call wait_all_responses explicitly as soon as a command # is issued without a $cb. my $error; my (@result) = try { $self->$orig(@args); } catch { $error = $_; (); }; $cb->( # see notes above - this logic may not be quite right ( $want_list{$method} ? \@result : $result[0] ), $error, ); return 1; }; } # in a real Redis system, this will make all outstanding callbacks get called. sub wait_all_responses {} 1; # End of Test::Mock::Redis package Test::Mock::Redis::List; sub new { return bless [], shift } 1; package Test::Mock::Redis::Hash; sub new { return bless {}, shift } 1; package Test::Mock::Redis::ZSet; sub new { return bless {}, shift } 1; package Test::Mock::Redis::Set; sub new { return bless {}, shift } 1; package Test::Mock::Redis::PossiblyVolatile; use strict; use warnings; use Tie::Hash; use base qw/Tie::StdHash/; sub DELETE { my ( $self, $key ) = @_; delete $self->{$key}; } my $expires; sub FETCH { my ( $self, $key ) = @_; return $self->EXISTS($key) ? $self->{$key} : undef; } sub EXISTS { my ( $self, $key ) = @_; $self->_delete_if_expired($key); return exists $self->{$key}; } sub _delete_if_expired { my ( $self, $key ) = @_; if(exists $expires->{$self}->{$key} && time >= $expires->{$self}->{$key}){ delete $self->{$key}; delete $expires->{$self}->{$key}; } } sub expire { my ( $self, $key, $time ) = @_; $expires->{$self}->{$key} = $time; } sub expire_count { my ( $self ) = @_; # really, we should probably only count keys that haven't expired scalar keys %{ $expires->{$self} }; } sub persist { my ( $self, $key, $time ) = @_; delete $expires->{$self}->{$key}; } sub ttl { my ( $self, $key ) = @_; return -1 unless exists $expires->{$self}->{$key}; return $expires->{$self}->{$key} - time; } 1; Test-Mock-Redis-0.20/t000755000765000024 013045273257 13756 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/t/00-load.t000444000765000024 60013045273257 15410 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More tests => 3; BEGIN { use_ok('Test::Mock::Redis') || print "Bail out!"; } use_ok('Test::Mock::Redis', num_databases => 42); my $r = Test::Mock::Redis->new(server => 'foobar'); is($r->{_num_dbs}, 42, "num_databases import argument was respected"); diag("Testing Test::Mock::Redis $Test::Mock::Redis::VERSION, Perl $], $^X"); Test-Mock-Redis-0.20/t/01-basic.t000555000765000024 2531113045273257 15624 0ustar00jeffstaff000000000000#!perl # # borrowed from Redis.pm's test suite with permission # use warnings; use strict; use lib 't/tlib'; use Test::More; use Test::Fatal; use Test::Mock::Redis; ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $o (@redi){ diag("testing $o") if $ENV{RELEASE_TESTING}; ok($o->ping, 'ping'); ## Commands operating on string values ok($o->set(foo => 'bar'), 'set foo => bar'); ok(!$o->setnx(foo => 'bar'), 'setnx foo => bar fails'); cmp_ok($o->get('foo'), 'eq', 'bar', 'get foo = bar'); ok($o->set(foo => ''), 'set foo => ""'); cmp_ok($o->get('foo'), 'eq', '', 'get foo = ""'); ok($o->set(foo => 'baz'), 'set foo => baz'); cmp_ok($o->get('foo'), 'eq', 'baz', 'get foo = baz'); my $euro = "\x{20ac}"; ok($o->set(utf8 => $euro), 'set utf8'); cmp_ok($o->get('utf8'), 'eq', $euro, 'get utf8'); ok($o->set('test-undef' => 42), 'set test-undef'); ok($o->exists('test-undef'), 'exists undef'); # Big sized keys for my $size (10_000, 100_000, 500_000, 1_000_000, 2_500_000) { my $v = 'a' x $size; ok($o->set('big_key', $v), "set with value size $size ok"); is($o->get('big_key'), $v, "... and get was ok to"); } $o->del('non-existant'); ok(!$o->exists('non-existant'), 'exists non-existant'); ok(!defined $o->get('non-existant'), 'get non-existant'); my $key_next = 3; ok($o->set('key-next' => 0), 'key-next = 0'); ok($o->set('key-left' => $key_next), 'key-left'); is_deeply([$o->mget('foo', 'key-next', 'key-left')], ['baz', 0, 3], 'mget'); my @keys; foreach my $id (0 .. $key_next) { my $key = 'key-' . $id; push @keys, $key; ok($o->set($key => $id), "set $key"); ok($o->exists($key), "exists $key"); is($o->get($key), $id, "get $key"); cmp_ok($o->incr('key-next'), '==', $id + 1, 'incr'); cmp_ok($o->decr('key-left'), '==', $key_next - $id - 1, 'decr'); } is($o->get('key-next'), $key_next + 1, 'key-next'); ok($o->set('test-incrby', 0), 'test-incrby'); ok($o->set('test-decrby', 0), 'test-decry'); foreach (1 .. 3) { is($o->incrby('test-incrby', 3), $_ * 3, 'incrby 3'); is($o->decrby('test-decrby', 7), -($_ * 7), 'decrby 7'); } is($o->del(map {"key-$_"} ('next', 'left')), 2, 'del multiple keys'); ok(!$o->del('non-existing'), 'del non-existing'); is($o->type('zzzzzzz'), 'none', 'type of non-existent key'); 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'); ## 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->sadd('test-set1', $_) foreach ('foo', 'bar', 'baz'); $o->sadd('test-set2', $_) foreach ('foo', 'baz', 'xxx'); my $inter = ['foo', 'baz']; is_deeply([sort $o->sinter('test-set1', 'test-set2')], [sort @$inter], 'siter'); ok($o->sinterstore('test-set-inter', 'test-set1', 'test-set2'), 'sinterstore'); cmp_ok( $o->scard('test-set-inter'), '==', $#$inter + 1, 'cardinality of intersection' ); ## Commands operating on zsets (sorted sets) # TODO: ZUNIONSTORE, ZINTERSTORE, SORT, tests w/multiple values having the same score my $zset = 'test-zset'; $o->del($zset); ok($o->zadd($zset, 0, 'foo')); ok(!$o->zadd($zset, 1, 'foo')); # 0 returned because foo is already in the set is($o->zscore($zset, 'foo'), 1); ok($o->zincrby($zset, 1, 'foo')); is($o->zscore($zset, 'foo'), 2); ok($o->zincrby($zset, 1, 'bar')); is($o->zscore($zset, 'bar'), 1) ; # bar was new, so its score got set to the increment is($o->zrank($zset, 'bar'), 0); is($o->zrank($zset, 'foo'), 1); is($o->zrevrank($zset, 'bar'), 1); is($o->zrevrank($zset, 'foo'), 0); ok($o->zadd($zset, 2.1, 'baz')); # we now have bar foo baz is_deeply([$o->zrange($zset, 0, 1)], [qw/bar foo/]); is_deeply([$o->zrevrange($zset, 0, 1)], [qw/baz foo/]); is_deeply([$o->zrange($zset, 0, -2)], [qw/bar foo/]); is_deeply([$o->zrevrange($zset, -3, 1)], [qw/baz foo/]); my $withscores = {$o->zrevrange($zset, 0, 1, 'WITHSCORES')}; # this uglyness gets around floating point weirdness in the return (I.E. 2.1000000000000001); my $rounded_withscores = { map { $_ => 0 + sprintf("%0.5f", $withscores->{$_}) } keys %$withscores }; is_deeply($rounded_withscores, {baz => 2.1, foo => 2}); is_deeply([$o->zrangebyscore($zset, 2, 3)], [qw/foo baz/]); is($o->zcount($zset, 2, 3), 2); is($o->zcard($zset), 3); ok($o->del($zset)); # cleanup my $score = 0.1; my @zkeys = (qw/foo bar baz qux quux quuux quuuux quuuuux/); ok($o->zadd($zset, $score++, $_)) for @zkeys; is_deeply([$o->zrangebyscore($zset, 0, 8)], \@zkeys); is($o->zremrangebyrank($zset, 5, 8), 3); # remove quux and up is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[0 .. 4]]); is($o->zremrangebyscore($zset, 0, 2), 2); # remove foo and bar is_deeply([$o->zrangebyscore($zset, 0, 8)], [@zkeys[2 .. 4]]); # only left with 3 is($o->zcard($zset), 3); ok($o->del($zset)); # cleanup my @sorting_zkeys = (qw/foog foof fooe fooa foob food fooc/); # foo* all have the same score so they should sort lexically $o->zadd($zset, 1, 'bar'); ok($o->zadd($zset, 5, $_)) for @sorting_zkeys; $o->zadd($zset, 9, 'baz'); my @sorted_zkeys = sort @sorting_zkeys; @sorting_zkeys = ('bar', @sorting_zkeys, 'baz'); @sorted_zkeys = ('bar', @sorted_zkeys, 'baz'); is_deeply([$o->zrangebyscore($zset, 0, 10)], \@sorted_zkeys); is_deeply([$o->zrangebyscore($zset, 0, 4)], [ 'bar' ]); is_deeply([$o->zrangebyscore($zset, 2, 6)], [@sorted_zkeys[1..7]]); my @revsorted_zkeys = reverse @sorted_zkeys; # max and min are reversed is_deeply([$o->zrevrangebyscore($zset, 10, 0)], \@revsorted_zkeys); is_deeply([$o->zrevrangebyscore($zset, 4, 0)], [ 'bar' ]); is_deeply([$o->zrevrangebyscore($zset, 6, 2)], [@revsorted_zkeys[1..7]]); # test withscores my $expected_withscores = [ map { $_, 5} @revsorted_zkeys ]; # (fix up bar =>1 and baz => 9 by hand) $expected_withscores->[-1] = 1; $expected_withscores->[1] = 9; is_deeply([$o->zrevrangebyscore($zset, 10, 0, 'WITHSCORES')], $expected_withscores); ok($o->del($zset)); # cleanup ## Commands operating on hashes my $hash = 'test-hash'; $o->del($hash); ok($o->hset($hash, foo => 'bar')); is($o->hget($hash, 'foo'), 'bar'); ok($o->hexists($hash, 'foo')); ok($o->hdel($hash, 'foo')); ok(!$o->hexists($hash, 'foo')); ok($o->hincrby($hash, incrtest => 1)); is($o->hget($hash, 'incrtest'), 1); is($o->hincrby($hash, incrtest => -1), 0); is($o->hget($hash, 'incrtest'), 0); ok($o->hdel($hash, 'incrtest')); #cleanup ok($o->hsetnx($hash, setnxtest => 'baz')); ok(!$o->hsetnx($hash, setnxtest => 'baz')); # already exists, 0 returned ok($o->hdel($hash, 'setnxtest')); #cleanup ok($o->hmset($hash, foo => 1, bar => 2, baz => 3, qux => 4)); is_deeply([$o->hmget($hash, qw/foo bar baz/)], [1, 2, 3]); is($o->hlen($hash), 4); is_deeply([sort $o->hkeys($hash)], [sort qw/foo bar baz qux/]); is_deeply([sort $o->hvals($hash)], [sort 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'); ## Connection handling ok($o->ping, 'ping() is true'); ok($o->quit, 'quit'); ok(!$o->ping, '... but after quit() returns false'); my $type = ref $o; $srv ||= 'localhost'; $o = $type->new(server => $srv); $o->shutdown(); ok(!$o->ping(), 'ping() also false after shutdown()'); sleep(1); like exception { $type->new(server => $srv) }, qr/Could not connect to Redis server at $srv/, 'Failed connection throws exception'; } ## All done done_testing(); Test-Mock-Redis-0.20/t/02-new.t000444000765000024 64713045273257 15277 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More; use Test::Mock::Redis; my $r = Test::Mock::Redis->new; $r->set('foo', 'foobar'); is $r->get('foo'), 'foobar'; my $s = Test::Mock::Redis->new; is $s->get('foo'), 'foobar', 'we got the same mock redis object back'; my $t = Test::Mock::Redis->new(server => 'something.else'); is $t->get('foo'), undef, 'mock redis object with new server is new'; done_testing(); Test-Mock-Redis-0.20/t/05-server.t000444000765000024 656413045273257 16043 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Mock::Redis; =pod x AUTH x ECHO x PING x QUIT o SELECT <-- TODO: complain about invalid values? BGREWRITEAOF BGSAVE CONFIG GET CONFIG RESETSTAT CONFIG SET DBSIZE DEBUG OBJECT DEBUG SEGFAULT x FLUSHALL x FLUSHDB o INFO x LASTSAVE MONITOR x SAVE o SHUTDOWN SLAVEOF SYNC =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; ok($r->ping, 'ping returns PONG'); ok($r->select($_), "select returns true for $_") for 0..15; $r->select(0); # TODO: do we care? eval{ $r->auth }; like($@, qr/^\Q[auth] ERR wrong number of arguments for 'auth' command\E/, 'auth without a password dies'); # as of redis 2.6 (?) this fails when auth is not enabled on the server # eval{ $r->auth('foo') }; # like($@, qr/^\Q[auth] ERR Client sent AUTH, but no password is set\E/, 'auth when no password set dies'); # however, emulating this behavior is not likely to be useful - better to silently # pretend that any auth worked than throw an error. for(0..15){ $r->select($_); $r->set('foo', "foobar $_"); is($r->get('foo'), "foobar $_"); } ok($r->flushall); for(0..15){ $r->select($_); ok(! $r->exists('foo'), "foo flushed from db$_"); } for my $flush_db (0..15){ for(0..15){ $r->select($_); $r->set('foo', "foobar $_"); is($r->get('foo'), "foobar $_"); } $r->select($flush_db); $r->flushdb; ok(! $r->exists('foo'), "foo flushed from db$flush_db"); for(0..15){ next if $_ == $flush_db; $r->select($_); ok($r->exists('foo'), "foo not flushed from db$_"); } } $r->select(0); # go back to db0 like($r->lastsave, qr/^\d+$/, 'lastsave returns digits'); ok($r->save, 'save returns true'); like($r->lastsave, qr/^\d+$/, 'lastsave returns digits'); my $info = $r->info; is(ref $info, 'HASH', 'info returned a hash'); #use Data::Dumper; diag Dumper $info; like($info->{run_id},qr/^[0-9a-f]{40}/, 'run_id is 40 random hex chars'); for(0..14){ is($info->{"db$_"}, 'keys=1,expires=0', "db$_ info is correct"); } # db15 was left with nothing in it, since it was the last one flushed is($info->{"db15"}, undef, 'info returns no data about databases with no keys'); $r->setex("volitile-key-$_", 15, 'some value') for (1..5); is($r->info->{'db0'}, 'keys=6,expires=5', 'db0 info now has six keys and five expire'); ok($r->quit, 'quit returns true'); ok(!$r->quit, 'quit returns false the second time'); ok(! $r->ping, 'ping returns false after we quit'); my $type = ref $r; my $r2 = $type->new(server => $srv); ok($r2->ping, 'we can ping our new redis client'); $r2->shutdown; # doesn't return anything ok(! $r2->ping, 'ping returns false after we shutdown'); } done_testing(); Test-Mock-Redis-0.20/t/06-keys.t000444000765000024 740013045273257 15477 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Fatal; use Test::Mock::Redis; =pod x DEL x EXISTS o KEYS <-- could use a lot more tests, doesn't escape meta-chars x MOVE o RANDOMKEY x RENAME x RENAMENX x TTL o TYPE <-- only 1 type tested here SORT <-- TODO, requires list/set/sorted set =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; ok(!$r->exists('foo'), "exists returns false for key that doesn't exist"); ok($r->set('foo', 'foobar'), 'can set foo'); ok($r->exists('foo'), 'exists returns true for key that exists'); is($r->randomkey, 'foo', "randomkey returns foo, because it's all we have"); ok($r->set('bar', 'barfoo'), 'can set bar'); ok($r->set('baz', 'bazbaz'), 'can set baz'); is_deeply([ sort $r->keys('ba*') ], [qw/bar baz/], 'keys ba* matches bar and baz'); is_deeply([ sort $r->keys('ba?') ], [qw/bar baz/], 'keys ba? matches bar and baz'); is_deeply([ sort $r->keys('?a?') ], [qw/bar baz/], 'keys ?a? matches bar and baz'); is_deeply([ sort $r->keys('ba[rz]') ], [qw/bar baz/], 'keys ba[rz] matches bar and baz'); is_deeply([ sort $r->keys('a*') ], [], 'keys search should start at beginning of word'); # TODO: more keys() tests ok(! $r->del('quizlebub'), "del on a key that doesn't exist returns false"); ok($r->del('foo'), 'del on a key that exists returns true'); is($r->get('bar'), 'barfoo', 'get returns correct value'); ok($r->set('foo', 'foobar'), 'can set foo again'); my $rand = $r->randomkey; ok(grep { $_ eq $rand } qw/foo bar baz/, 'random returned one of our keys'); like exception { $r->rename('foo', 'foo') }, qr/^\Q[rename] ERR source and destination objects are the same\E/, 'rename with identical source and dest returns false'; like exception { $r->rename('quizlebub', 'foo') }, qr/^\Q[rename] ERR no such key\E/, "rename with source that doesn't exist returns false"; ok($r->rename('foo', 'newfoo'), 'rename returns true on success'); is( $r->get('newfoo'), 'foobar', 'rename worked'); is_deeply([sort $r->keys('*')], [qw/bar baz newfoo/], 'rename removed foo'); like exception { $r->keys }, qr/^\Q[KEYS] ERR wrong number of arguments for 'keys' command\E/, 'keys with no argument complains'; $r->set('foo', 'foobar'); ok(! $r->renamenx('newfoo', 'foo'), 'renamenx returns false when destination key exists'); ok($r->renamenx('newfoo', 'newfoo2'), 'renamenx returns true on success'); is( $r->get('newfoo2'), 'foobar', 'renamenx worked'); is($r->ttl('newfoo2'), -1, 'ttl for key with no timeout is -1'); is($r->ttl('quizlebub'), -1, "ttl for key that doesn't exist is -1"); $r->expire('newfoo2', 3); ok($r->ttl('newfoo2') >= 2, 'ttl for newfoo2 is at least 2'); is($r->type('foo'), 'string', 'type works for simple key/value'); ok($r->move('foo', 1), 'move returns true on success'); ok(! $r->get('foo'), 'move moved foo'); ok(! $r->move('foo', 1), 'move returns false when key does not exist in source'); ok($r->select(1), 'select returns true on success'); ok($r->exists('foo'), 'move moved foo and exists found it'); ok($r->select(0), 'select returns true on success'); $r->set('foo', 'foobar'); # put it back in db0 ok(! $r->move('foo', 1), 'move returns false when key already exists in destination'); } done_testing(); Test-Mock-Redis-0.20/t/07-expires.t000444000765000024 335113045273257 16205 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Mock::Redis; =pod x SETEX x EXPIRE x EXPIREAT x PERSIST =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; ok($r->set('foo', 'foobar'), 'can set foo'); ok($r->set('bar', 'barfoo'), 'can set bar'); ok($r->set('baz', 'bazbaz'), 'can set baz'); ok(! $r->expire('quizlebub', 1), "expire on a key that doesn't exist returns false"); ok($r->expire('bar', 1), 'expire on a key that exists returns true'); sleep 2; is_deeply([ sort $r->keys('*') ], [ qw(baz foo) ], 'expired key removed from KEYS list'); ok(! $r->exists('bar'), 'bar expired'); ok(! $r->expireat('quizlebub', time + 1), "expireat on a key that doesn't exist returns false"); ok($r->expireat('baz', time + 1), 'expireat on a key that exists returns true'); sleep 2; ok(! $r->exists('baz'), 'baz expired'); ok($r->setex('foo', 1, 'foobar'), 'set foo again returns a true value'); sleep 2; ok(! $r->exists('foo'), 'foo expired'); ok($r->setex('foo', 2, 'foobar'), 'set foo again returns a true value'); ok($r->persist('foo'), 'persist for a key that exists returns true'); ok(! $r->persist('quizlebub'), "persist returns false for a key that doesn't exist"); sleep 3; is($r->get('foo'), 'foobar', 'foo persisted'); } done_testing(); Test-Mock-Redis-0.20/t/08-get-set.t000444000765000024 1335013045273257 16117 0ustar00jeffstaff000000000000#!perl -T use utf8; use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Mock::Redis; =pod x APPEND x DECR x DECRBY x GET GETBIT GETRANGE o GETSET <-- needs error for non-string value x INCR x INCRBY x MGET x MSET x MSETNX x SET SETBIT x SETNX SETRANGE x STRLEN =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; ok(! $r->exists('foo'), 'foo does not exist yet'); is($r->get('foo'), undef, "get on a key that doesn't exist returns undef"); ok($r->set('foo', 'foobar'), 'can set foo'); ok($r->set('bar', 'barfoo'), 'can set bar'); ok($r->set('baz', 'bazbaz'), 'can set baz'); is($r->get('foo'), 'foobar', 'can get foo'); is($r->get('bar'), 'barfoo', 'can get bar'); is($r->get('baz'), 'bazbaz', 'can get baz'); is($r->type('foo'), 'string', 'type of foo is string'); subtest 'set options' => sub { ok(! $r->set('foo', 'new_val', 'NX'), 'set takes NX option'); is($r->get('foo'), 'foobar', 'value did not change because of NX'); note 'Try again on new key'; ok($r->set('oof', 'new_val', 'NX'), 'Testing NX on non-existent key'); is($r->get('oof'), 'new_val', 'Successfully set key with NX'); note 'Back to foo'; ok($r->set('foo', 'new_val', 'XX'), 'set takes XX option'); is($r->get('foo'), 'new_val', 'XX updates the value'); ok($r->set('foo', 'foobar', 'EX' => 1000), 'set takes EX option'); ok($r->ttl('foo') > 999 && $r->ttl('foo') <= 1000, 'EX sets TTL'); note 'Now trying some combinations'; ok($r->set('raboof', 'val', 'NX', EX => 10), 'Called set with NX and EX'); is($r->get('raboof'), 'val', ' - created key'); ok($r->ttl('raboof') > 9 && $r->ttl('raboof') <= 10, ' - set TTL'); ok($r->set('raboof', 'bar', 'XX', EX => 20), 'Called set with XX and EX'); is($r->get('raboof'), 'bar', ' - updated key'); ok($r->ttl('raboof') > 19 && $r->ttl('raboof') <= 20, ' - reset TTL'); ok(! defined $r->set('finaltest', 'baz', 'NX', 'XX'), 'Returns nil with NX and XX'); ok($r->set('raboof', 'val', 'EX', 100, 'PX', 10), 'Called set with EX and PX, EX greater'); ok($r->ttl('raboof') > 99 && $r->ttl('raboof') <= 100, 'Used EX value'); ok($r->set('raboof', 'val', 'PX', 5000, 'EX', 2), 'Called set with EX and PX, PX greater'); ok($r->ttl('raboof') > 4 && $r->ttl('raboof') <= 5, 'Used PX value'); }; ok(! $r->setnx('foo', 'foobar'), 'setnx returns false for existing key'); ok($r->setnx('qux', 'quxqux'), 'setnx returns true for new key'); is($r->incr('incr-test'), 1, 'incr returns 1 for new value'); is($r->decr('decr-test'), -1, 'decr returns -1 for new value'); is($r->incr('incr-test'), 2, 'incr returns 2 the next time'); is($r->decr('decr-test'), -2, 'decr returns -2 the next time'); is($r->incr('decr-test'), -1); is($r->incr('decr-test'), 0, 'decr returns 0 appropriately'); is($r->decr('incr-test'), 1); is($r->decr('incr-test'), 0, 'incr returns 0 appropriately'); is($r->incrby('incrby-test', 10), 10, 'incrby 10 returns incrby value for new value'); is($r->decrby('decrby-test', 10), -10, 'decrby 10 returns decrby value for new value'); is($r->decrby('incrby-test', 10), 0, 'incrby returns 0 appropriately'); is($r->incrby('decrby-test', 10), 0, 'decrby returns 0 appropriately'); is($r->incrby('incrby-test', -15), -15, 'incrby a negative value works'); is($r->decrby('incrby-test', -15), 0, 'decrby a negative value works'); is($r->append('append-test', 'foo'), 3, 'append returns length (for new)'); is($r->append('append-test', 'bar'), 6, 'append returns length'); is($r->append('append-test', 'baz'), $r->strlen('append-test'), 'strlen agrees with append'); is($r->strlen('append-test'), 9, 'length of append-test key is now 9'); is($r->append('append-test', '€'), 12, 'euro character (multi-byte) only counted by bytes'); is($r->getset('foo', 'whee!'), 'foobar', 'getset returned old value of foo'); is($r->getset('foo', 'foobar'), 'whee!', 'getset returned old value of foo again (so it must have been set)'); is_deeply([$r->mget(qw/one two three/)], [undef, undef, undef], 'mget returns correct number of undefs'); ok([$r->mset(one => 'fish', two => 'fish', red => 'herring')], 'true returned for Dr Seuss'); is_deeply([$r->mget(qw/one two red blue/)], [qw/fish fish herring/, undef], 'mget returned Dr Seuss and undef'); is_deeply([$r->mget(qw/two blue one red/)], [qw/fish/, undef, qw/fish herring/], 'mget likes order'); ok( !$r->msetnx(blue => 'fish', red => 'fish'), 'msetnx fails if any key exists'); is($r->get('red'), 'herring', 'msetnx left red alone'); ok($r->del('red'), 'bye bye red'); ok($r->msetnx(blue => 'fish', red => 'fish'), 'msetnx sets multiple keys'); is_deeply([$r->mget(qw/one two red blue/)], [qw/fish fish fish fish/], 'all fish now'); } =pod TODO: { local $TODO = "no setbit/getbit yet"; # set the first 8 bits to 0, and the next 8 to 1 ok(! $r->setbit('bits', $_, 0) for(0..7); ok(! $r->setbit('bits', $_, 1) for(8..15); ok(! $r->getbit('bits', $_), "got 0 at bit offset $_") for(0..7); ok($r->getbit('bits', $_), "got 1 at bit offset $_") for(8..15); ok(! $r->getbit('bits', 16), "got 1 at bit offset $_"); }; =cut done_testing(); Test-Mock-Redis-0.20/t/09-list.t000444000765000024 746213045273257 15512 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Mock::Redis; =pod BLPOP BRPOP BRPOPLPUSH x LINDEX LINSERT x LLEN x LPOP x LPUSH x LPUSHX x LRANGE LREM x LSET x LTRIM x RPOP RPOPLPUSH x RPUSH x RPUSHX =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; $r->set('foo', 'foobar'); is $r->$_('list'), undef, "$_ on key that doesn't exist returns undef" for (qw/lpop rpop/); ok ! $r->$_('list'), "$_ on key that doesn't exist returns undef" for (qw/lpop rpop/); # TODO: is this the expected behavior? is $r->llen('list'), 0, "llen returns 0 for a list that doesn't exist"; for my $op (qw/lpush rpush/){ eval { $r->lpush('foo', 'barfoo') }; like $@, qr/^\Q[lpush] ERR Operation against a key holding the wrong kind of value\E/, "lpush against a key that doesn't hold a list died"; ok ! $r->exists("list-$op"), "key 'list-$op' does not exist yet"; is $r->$op("list-$op", 'foobar'), 1, "$op returns length of list"; is $r->llen("list-$op"), 1, "llen agrees"; is $r->$op("list-$op", 'barfoo'), 2, "$op returns length of list"; is $r->llen("list-$op"), 2, "llen agrees"; is $r->$op("list-$op", 'bazbaz'), 3, "$op returns length of list"; is $r->llen("list-$op"), 3, "llen agrees"; is $r->$op("list-$op", 'quxqux'), 4, "$op returns length of list"; is $r->llen("list-$op"), 4, "llen agrees"; } $r->rpush('list', $_) for 0..9; is $r->lindex('list', $_), $_ for 0..9; # e.g. lindex('list',-1) returns the last element is $r->lindex('list', -1-$_), 9-$_ for 0..9; is $r->llen('list'), 10, 'llen returns length of list'; is $r->lpop('list'), $_ for 0..9; # TODO: is this the expected behavior? is $r->llen('list'), 0, 'llen returns zero for empty list'; $r->lpush('list', $_) for 0..9; # just for rpop is $r->rpop('list'), $_ for 0..9; # TODO rpush( 'list', 0..9 ) should also work # rpushlpop # Setup... $r->rpush(source => $_) for 'a', 'b', 'c'; $r->rpush(destination => $_) for 'x', 'y', 'z'; is $r->rpoplpush('list-that-does-not-exist', 'dummy'), undef; is $r->rpoplpush('source', 'destination'), 'c'; list_exactly_contains($r, source => 'a', 'b'); list_exactly_contains($r, destination => 'c', 'x', 'y', 'z'); is $r->rpoplpush(destination => 'destination'), 'z'; list_exactly_contains($r, destination => 'z', 'c', 'x', 'y'); is_deeply([$r->lrange(destination => 0, 2)], [qw/z c x/]); is_deeply([$r->lrange(destination => 1, 2)], [qw/c x/]); is_deeply([$r->lrange(destination => 1, -1)], [qw/c x y/]); is_deeply([$r->lrange(destination => 2, -2)], [qw/x/]); is_deeply([$r->lrange(destination => -3, 5)], [qw/c x y/]); is_deeply([$r->lrange(destination => 3, 1)], []); $r->lset(destination => 0, 'a'); $r->lset(destination => -1, 'f'); list_exactly_contains($r, destination => 'a', 'c', 'x', 'f'); $r->rpush(long => $_) for 1..10; $r->ltrim(long => 1,8); list_exactly_contains($r,long => 2..9); $r->ltrim(long => -5,-3); list_exactly_contains($r,long => 5..7); } sub list_exactly_contains { my ( $redis, $list, @elements ) = @_; for my $i (0 .. $#elements) { is $redis->lindex($list, $i), $elements[$i]; } is $redis->lindex($list, $#elements + 1), undef; } done_testing(); Test-Mock-Redis-0.20/t/10-hash.t000444000765000024 1262613045273257 15470 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Fatal; use Test::Mock::Redis; =pod x HDEL x HEXISTS x HGET x HGETALL x HINCRBY x HKEYS x HLEN x HMGET o HMSET x HSET HSETNX HVALS =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; is $r->hget('hash', 'foo'), undef, "hget for a hash that doesn't exist is undef"; is_deeply([sort $r->hkeys('hash')], [], "hkeys returned no keys for a hash that doesn't exist"); is $r->hset('hash', 'foo', 'foobar'), 1, "hset returns 1 when it's happy"; is $r->hget('hash', 'foo'), 'foobar', "hget returns the value we just set"; is $r->type('hash'), 'hash', "type of key hash is hash"; is $r->hget('hash', 'bar'), undef, "hget for a hash field that doesn't exist is undef"; ok $r->hset('hash', 'bar', 'foobar'), "hset returns true when it's happy"; is $r->hlen('hash'), 2, "hlen counted two keys"; is_deeply([sort $r->hkeys('hash')], [qw/bar foo/], 'hkeys returned our keys'); is $r->hset('hash', 'bar', 'barfoo'), 0, "hset returns 0 when they field already existed"; is $r->hget('hash', 'bar'), 'barfoo', "hget returns the value we just set"; ok $r->set('hash', 'blarg'), "set returns true when we squash a hash"; is $r->get('hash'), 'blarg', "even though it squashed it"; like exception { $r->hset('hash', 'foo', 'foobar') }, qr/^\Q[hset] ERR Operation against a key holding the wrong kind of value\E/, "hset throws error when we overwrite a string with a hash"; ok ! $r->hexists('blarg', 'blorf'), "hexists on a hash that doesn't exist returns false"; like exception { $r->hexists('hash', 'blarg') }, qr/^\Q[hexists] ERR Operation against a key holding the wrong kind of value\E/, "hexists on a field that's not a hash throws error"; $r->del('hash'); ok $r->hset('hash', 'foo', 'foobar'), "hset returns true when it's happy"; is $r->hexists('hash', 'foo'), 1, "hexists returns 1 when it's true"; ok ! $r->hdel('blarg', 'blorf'), "hdel on a hash that doesn't exist returns false"; ok ! $r->hdel('hash', 'blarg'), "hdel on a hash field that doesn't exist returns false"; ok $r->hdel('hash', 'foo'), "hdel returns true when it's happy"; ok ! $r->hexists('hash', 'foo'), "hdel really deleted the field"; is $r->hexists('hash', 'foo'), 0, "hexists returns 0 when field is not in the hash"; is $r->hlen('hash'), 0, "hlen counted zarro keys"; is_deeply([sort $r->hkeys('hash')], [], "hkeys returned no keys for an empty hash"); $r->set('not a hash', 'foo bar'); like exception { $r->hkeys('not a hash') }, qr/^\Q[hkeys] ERR Operation against a key holding the wrong kind of value\E/, "hkeys on key that isn't a hash throws error"; # OK seems inconsistient is $r->hmset('hash', qw/foo bar bar baz baz qux qux quux quux quuux/), 'OK', "hmset returns OK if it set some stuff"; is_deeply { $r->hgetall('hash') }, { foo => 'bar', bar => 'baz', baz => 'qux', qux => 'quux', quux => 'quuux' }, "hget all returned our whole hash"; is_deeply { $r->hgetall("I don't exist") }, { }, "hgetall on non-existent key is empty"; like exception { $r->hgetall('not a hash') }, qr/^\Q[hgetall] ERR Operation against a key holding the wrong kind of value\E/, "hgetall on key that isn't a hash throws error"; is_deeply [sort $r->hvals('hash')], [sort qw/bar baz qux quux quuux/], "hvals all returned all values"; is_deeply [ $r->hvals("I don't exist") ], [ ], "hvals on non-existent key returned an empty list"; $r->set('not a hash', 'foo bar'); like exception { $r->hvals('not a hash') }, qr/^\Q[hvals] ERR Operation against a key holding the wrong kind of value\E/, "hvals on key that isn't a hash throws error"; is_deeply [ $r->hmget('hash', qw/foo bar baz/) ], [ qw/bar baz qux/ ], "hmget returns requested values"; is_deeply [ $r->hmget('hash', qw/blarg foo bar baz blorf/) ], [ undef, qw/bar baz qux/, undef ], "hmget returns undef for missing values"; is_deeply [ $r->hmget('hash', qw/blarg blorf/) ], [ undef, undef ], "hmget returns undef even if all values are missing"; like exception { $r->hincrby('hash', 'foo') }, qr/^\Q[hincrby] ERR wrong number of arguments for 'hincrby' command\E/, "hincerby dies when called with the wrong number of arguments"; like exception { $r->hincrby('hash', 'foo', 1) }, qr/^\Q[hincrby] ERR hash value is not an integer\E/, "hincrby dies when a non-integer is incremented"; is $r->hincrby('hash', 'incrme', 1), 1, "incrby 1 on a value that doesn't exist returns 1"; is $r->hincrby('hash', 'incrmf', 2), 2, "incrby 2 on a value that doesn't exist returns 2"; is $r->hincrby('hash', 'incrmf', -1), 1, "incrby returns value resulting from increment"; is $r->hset('hash', 'emptystr', ''), 1, "can set hash value to empty string"; is $r->hincrby('hash', 'emptystr', 1), 1, "incrby 1 on the empty string returns 1"; } done_testing(); Test-Mock-Redis-0.20/t/11-sets.t000444000765000024 1705613045273257 15526 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use lib 't/tlib'; use Test::More; use Test::Fatal; use Test::Mock::Redis; =pod x SADD x SCARD x SDIFF x SDIFFSTORE x SINTER x SINTERSTORE x SISMEMBER x SMEMBERS x SMOVE x SPOP x SRANDMEMBER x SREM x SUNION x SUNIONSTORE =cut ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } my @members = (qw/foo bar baz qux quux quuux/); foreach my $r (@redi){ diag("testing $r") if $ENV{RELEASE_TESTING}; is $r->srandmember('noset'), undef, "srandmember for a set that doesn't exist returns undef"; is $r->spop('noset'), undef, "spop for a set that doesn't exist returns undef"; is $r->scard('noset'), 0, "scard for a set that doesn't exist returns 0"; is $r->srem('noset', 'foo'), 0, "srem for a set that doesn't exist returns 0"; is $r->smove('noset', 'set', 'foo'), 0, "smove for sets that don't exist returns 0"; is $r->sismember('noset', 'foo'), 0, "sismember for a set that doesn't exist returns 0"; is_deeply [$r->smembers('noset')], [], "smembers for a set that doesn't exist returns an empty array"; is $r->sadd('set', 'foo'), 1, "sadd returns 1 when element is new to the set"; is $r->sadd('set', 'foo'), 0, "sadd returns 0 when element is already in the set"; is $r->scard('set'), 1, "scard returns size of set"; is $r->sadd('set', 'bar'), 1, "sadd returns 1 when element is new to the set"; is $r->scard('set'), 2, "scard returns size of set"; is $r->sismember('set', 'foo'), 1, "sismember returns 1 for a set element that exists"; is $r->sismember('set', 'baz'), 0, "sismember returns 0 for a set element that doesn't exist"; is_deeply [sort $r->smembers('set')], [qw/bar foo/], "smembers returns all members of the set"; is $r->srem('set', 'bar'), 1, "srem returns 1 when it removes an element"; is $r->sadd('set', $_), 1, "srem returns 1 when it adds a new element to the set" for (grep { $_ ne 'foo'} @members); is $r->type('set'), 'set', "our set has type set"; my $randmember = $r->srandmember('set'); ok $randmember, "srandmember returned something"; ok grep { $_ eq $randmember } $r->smembers('set'), "srandmember returned a member"; while($r->scard('set')){ my $popped = $r->spop('set'); ok $popped, "spopped something"; ok grep { $_ eq $popped } @members, "spopped a member"; is $r->sismember('set', $popped), 0, "spop removed $popped"; } # set has been emptied. Put some stuff in it again is $r->sadd('set', $_), 1, "srem returns 1 when it adds a new element to the set" for (@members); is $r->sadd('otherset', $_), 1, "srem returns 1 when it adds a new element to the set" for (qw/foo bar baz/); is $r->sadd('anotherset', $_), 1, "srem returns 1 when it adds a new element to the set" for (qw/bar baz qux/); is_deeply [sort $r->sinter('set', 'otherset')], [qw/bar baz foo/], "sinter returns all members in common"; is_deeply [sort $r->sinter('set', 'otherset', 'anotherset')], [qw/bar baz/], "sinter returns all members in common for multiple sets"; is_deeply [$r->sinter('set', 'emptyset')], [], "sinter returns empty list"; is_deeply [$r->sinter('set', 'otherset', 'emptyset')], [], "sinter returns empty list with multiple sets"; is $r->sinterstore('destset', 'set', 'otherset'), 3, "sinterstore returns cardinality of intersection"; is_deeply [sort $r->smembers('destset')], [sort $r->sinter('set', 'otherset')], "sinterstore stored the correct result"; is $r->sinterstore('destset', 'set', 'emptyset'), 0, "cardinality of empty intersection is zero"; is_deeply [sort $r->smembers('destset')], [sort $r->sinter('set', 'emptyset')], "sinterstore stored the correct result"; is $r->sinterstore('destset', 'set', 'otherset', 'anotherset'), 2, "sinterstore returns cardinality of intersection"; is_deeply [sort $r->smembers('destset')], [sort $r->sinter('set', 'otherset', 'anotherset')], "sinterstore stored the correct result"; is $r->sadd('otherset', $_), 1, "srem returns 1 when it adds a new element to the set" for (qw/oink bah neigh/); is_deeply [sort $r->sunion('set', 'otherset')], [sort @members, qw/oink bah neigh/], "sunion returns all members of two sets"; is_deeply [sort $r->sunion('set', 'anotherset')], [sort @members], "sunion returns all members of two sets"; is $r->sunionstore('destset', 'set', 'otherset'), @members + 3, "sunionstore returns cardinality of union"; is_deeply [sort $r->smembers('destset')], [sort $r->sunion('set', 'otherset')], "sunionstore stored the correct result"; is $r->sunionstore('destset', 'set', 'emptyset'), @members, "cardinality of empty union is same as carindality of set"; is_deeply [sort $r->smembers('destset')], [sort $r->sunion('set', 'emptyset')], "sunionstore stored the correct result"; is $r->sunionstore('destset', 'set', 'otherset', 'anotherset'), @members + 3, "sunion returns cardinality of union"; is_deeply [sort $r->smembers('destset')], [sort $r->sunion('set', 'otherset', 'anotherset')], "sunionstore stored the correct result"; is_deeply [sort $r->sdiff('set', 'otherset')], [qw/quuux quux qux/], "sdiff removed members correctly"; is_deeply [sort $r->sdiff('set', 'otherset', 'anotherset')], [qw/quuux quux/], "sdiff removed members correctly"; is $r->sdiffstore('destset', 'set', 'otherset'), 3, "sdiffstore returnes cardinality of difference"; is_deeply [sort $r->smembers('destset')], [sort $r->sdiff('set', 'otherset')], "sdiffstore stored the correct result"; is $r->sdiffstore('destset', 'set', 'otherset', 'anotherset'), 2, "sdiffstore returnes cardinality of difference"; is_deeply [sort $r->smembers('destset')], [sort $r->sdiff('set', 'otherset', 'anotherset')], "sdiffstore stored the correct result"; # cardinality of the difference with the empty set is the same as what we started with is $r->sdiffstore('destset', 'set', 'emptyset'), $r->scard('set'), "sdiffstore returnes cardinality of difference"; is_deeply [sort $r->smembers('destset')], [sort $r->smembers('set')], "sdiffstore stored the correct result"; is $r->smove('otherset', 'set', 'oink'), 1, "smove returns true if it moved an element succesfully"; is $r->sismember('set', 'oink'), 1, "oink moved to set"; is $r->sismember('otherset', 'oink'), 0, "oink removed from otherset"; is $r->smove('otherset', 'set', 'meow'), 0, "smove returns false if it failed to move an element"; is $r->smove('notaset', 'otherset', 'foo'), 0, "smove returns false when source doesn't exist"; $r->set('justakey', 'foobar'); like exception { $r->smove('justakey', 'set', 'foo') }, qr/^\Q[smove] ERR Operation against a key holding the wrong kind of value\E/, "smove dies when source isn't a set"; like exception { $r->smove('set', 'justakey', 'foo') }, qr/^\Q[smove] ERR Operation against a key holding the wrong kind of value\E/, "smove dies when dest isn't a set"; is $r->smove('otherset', 'newset', 'foo'), 1, "smove returns true when destination doesn't exist"; is $r->type('newset'), 'set', "newset sprang into existence"; } done_testing(); Test-Mock-Redis-0.20/t/12-sorted-sets.t000444000765000024 64613045273257 16762 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More; use Test::Mock::Redis; =pod ZADD ZCARD ZCOUNT ZINCRBY ZINTERSTORE ZRANGE ZRANGEBYSCORE ZRANK ZREM ZREMRANGEBYRANK ZREMRANGEBYSCORE ZREVRANGE ZREVRANGEBYSCORE ZREVRANK ZSCORE ZUNIONSTORE =cut my $r = Test::Mock::Redis->new; diag('TODO'); ok(1, 'placeholder to keep Test::More happy'); done_testing(); Test-Mock-Redis-0.20/t/13-multi.t000444000765000024 1015113045273257 15671 0ustar00jeffstaff000000000000use strict; use warnings FATAL => 'all'; use Test::More 0.88; use Test::Deep; use Test::Fatal; use Test::Mock::Redis; use lib 't/tlib'; =pod x MULTI x EXEC x DISCARD =cut # There is a known issue in the real Redis client that screws up the # interpretation of all results from the client after an error in the middle of # a multi -- https://github.com/melo/perl-redis/issues/42 # Because of this, this one test file uses a subref for its redis object, # rather than the object itself, so it can get a new object at the right time # so we can continue tests... my $r = sub { Test::Mock::Redis->new }; ok($r->(), 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); my $r = sub { Redis->new(server => $srv) }; my $redis = $r->(); ok($redis, 'connected to our test redis-server'); $redis->flushall; unshift @redi, $r } foreach my $o (@redi) { my $redis = $o->(); diag("testing $redis") if $ENV{RELEASE_TESTING}; ok($redis->ping, 'ping'); like( exception { $redis->exec }, qr/^\[exec\] ERR EXEC without MULTI/, 'cannot call EXEC before MULTI', ); like( exception { $redis->discard }, qr/^\[discard\] ERR DISCARD without MULTI/, 'cannot call DISCARD before MULTI', ); like( exception { $redis->multi; $redis->multi }, qr/^\[multi\] ERR MULTI calls can not be nested/, 'cannot call MULTI again until EXEC or DISCARD is called', ); is($redis->discard, 'OK', 'multi state has been reset'); # discarded transactions is($redis->multi, 'OK', 'multi transaction started'); is($redis->hmset('transaction_key_1', qw(a 1 b 2)), 'QUEUED', 'hmset operation recorded'); cmp_deeply( $redis->discard, 'OK', 'transaction discarded', ); cmp_deeply( { $redis->hgetall('transaction_key_1') }, { }, 'data was not altered', ); # successful transactions is($redis->watch('transaction_key_3'), 'OK', 'watch command'); is($redis->multi, 'OK', 'multi transaction started'); is($redis->hmset('transaction_key_3', qw(a 1 b 2)), 'QUEUED', 'hmset operation recorded'); cmp_deeply([ $redis->keys('transaction_key_*') ], [ 'QUEUED' ], 'keys operation recorded'); is($redis->set('transaction_key_4', 'ohhai'), 'QUEUED', 'set operation recorded'); cmp_deeply([ $redis->keys('transaction_key_*') ], [ 'QUEUED' ], 'keys operation recorded'); cmp_deeply( [ $redis->exec ], [ 'OK', [ 'transaction_key_3' ], # transaction_key_4 hasn't been set yet 'OK', bag(qw(transaction_key_3 transaction_key_4)), ], 'transaction finished, returning the results of all queries', ); is($redis->unwatch(), 'OK', 'unwatch command'); cmp_deeply( { $redis->hgetall('transaction_key_3') }, { a => '1', b => '2', }, 'hash data successfully recorded', ); # an error in replaying a transaction should not abort subsequent commands # note: this mirrors behaviour in version 2.6.5+ is($redis->multi, 'OK', 'multi transaction started'); is($redis->set('transaction_key_1', 'foo'), 'QUEUED', 'set operation recorded'); is($redis->hset('transaction_key_1', 'bar', '9'), 'QUEUED', 'hset operation recorded'); is($redis->hset('transaction_key_3', 'a', '9'), 'QUEUED', 'hset operation recorded'); like( exception { $redis->exec }, qr/^\[exec\] ERR Operation against a key holding the wrong kind of value/, 'a bad transaction results in an exception', ); # we need to get a new redis client now -- see notes above $redis = $o->(); is($redis->get('transaction_key_1'), 'foo', 'the first command was executed'); cmp_deeply( { $redis->hgetall('transaction_key_3') }, { a => '9', b => '2', }, 'commands after the error were still executed', ); } done_testing; Test-Mock-Redis-0.20/t/14-pipeline.t000444000765000024 622613045273257 16335 0ustar00jeffstaff000000000000use strict; use warnings FATAL => 'all'; use Test::More 0.88; use Test::Deep; use Test::Fatal; use Test::Deep::UnorderedPairs; use Test::Mock::Redis; use lib 't/tlib'; ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server'); my @redi = ($r); my ( $guard, $srv ); if( $ENV{RELEASE_TESTING} ){ use_ok("Redis"); use_ok("Test::SpawnRedisServer"); ($guard, $srv) = redis(); ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server'); $r->flushall; unshift @redi, $r } foreach my $redis (@redi) { diag("testing $redis") if $ENV{RELEASE_TESTING}; ok($redis->ping, 'ping'); is( $redis->hmset( 'pipeline_key_1', qw(a 1 b 2), sub { cmp_deeply(\@_, [ 'OK', undef ], 'hmset callback') }, ), '1', 'hmset command sent', ); is( $redis->set( 'pipeline_key_2', 'ohhai', sub { cmp_deeply(\@_, [ 'OK', undef ], 'set callback') }, ), '1', 'set command sent', ); is( $redis->keys( 'pipeline_key_*', sub { cmp_deeply(\@_, [ bag(qw(pipeline_key_1 pipeline_key_2)), undef ], 'keys callback') }, ), '1', 'keys operation sent', ); cmp_deeply( [ $redis->hgetall( 'pipeline_key_1', sub { cmp_deeply(\@_, [ tuples(a => 1, b => 2), undef ], 'hgetall callback') }, ), ], [ '1' ], 'hgetall operation sent (wantarray=1)', ); is( $redis->hset( 'pipeline_key_2', 'bar', '9', # weird, when pipelining, the real redis doesn't always include the command name? sub { cmp_deeply(\@_, [ undef, re(qr/^(\[hset\] )?ERR Operation against a key holding the wrong kind of value/) ], 'hset callback') }, ), '1', 'hset operation sent', ); # flush all outstanding commands and test their callbacks $redis->wait_all_responses; TODO: { # this may be officially supported eventually -- see # https://github.com/melo/perl-redis/issues/17 local $TODO = 'Redis.pm docs recommend avoiding transactions + pipelining for now'; is( exception { $redis->multi; is($redis->set('pipeline_key_2', 'ohhai'), 'QUEUED', 'set command queued inside a transaction'); is( $redis->exec(sub { cmp_deeply( \@_, [ [ [ 'OK', undef ], # result, error from 'set' call ], undef, ], 'callback sent arrayref of result/error tuples from the transaction', ) }), '1', 'exec command sent', ); $redis->wait_all_responses; }, undef, 'exec in a pipeline is supported', ); } } done_testing; Test-Mock-Redis-0.20/t/15-import.t000444000765000024 246113045273257 16040 0ustar00jeffstaff000000000000#!perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Deep; use Test::Mock::Redis; # # first demonstrate failure # my $r1 = Test::Mock::Redis->new(server => '1.1.1.1:1111'); like exception { $r1->select(19) }, qr/\QYou called select(19), but max allowed is 15/; # # now change the setting # # the equivalent of 'use $class num_databases => 20' Test::Mock::Redis->import(num_databases => 20); # need a different server since the first one is already set up in $instances my $r2 = Test::Mock::Redis->new(server => '2.2.2.2:2222'); $r2->set('key-in-default-db-0', 'foobar'); # now this will pass is exception { $r2->select(19) }, undef; # and this won't include key-in-default-db-0 $r2->set('key1', 'foobar'); $r2->set('key2', 'foobar'); cmp_deeply( [ $r2->keys('*') ], bag('key1', 'key2')); # # allow alternate syntax, a method that says what it does, if the user wants # to change it during the run of the test # Test::Mock::Redis::change_num_databases(30); my $r3 = Test::Mock::Redis->new(server => '3.3.3.3:3333'); $r3->set('key-in-default-db-0', 'foobar'); # now this will pass is exception { $r3->select(29) }, undef; # and this won't include key-in-default-db-0 $r3->set('key1', 'foobar'); $r3->set('key2', 'foobar'); cmp_deeply( [ $r3->keys('*') ], bag('key1', 'key2')); done_testing(); Test-Mock-Redis-0.20/t/boilerplate.t000444000765000024 232413045273257 16603 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More tests => 3; sub not_in_file_ok { my ($filename, %regex) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while (my $line = <$fh>) { while (my ($desc, $regex) = each %regex) { if ($line =~ $regex) { push @{$violated{$desc}||=[]}, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok($module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } not_in_file_ok(README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok(Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok('lib/Test/Mock/Redis.pm'); Test-Mock-Redis-0.20/t/manifest.t000444000765000024 46513045273257 16073 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } eval "use Test::CheckManifest 0.9"; plan skip_all => "Test::CheckManifest 0.9 required" if $@; unlink 'dump.rdb' if -e 'dump.rdb'; ok_manifest(); Test-Mock-Redis-0.20/t/pod.t000444000765000024 35013045273257 15040 0ustar00jeffstaff000000000000#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Test-Mock-Redis-0.20/t/tlib000755000765000024 013045273257 14710 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/t/tlib/Test000755000765000024 013045273257 15627 5ustar00jeffstaff000000000000Test-Mock-Redis-0.20/t/tlib/Test/SpawnRedisServer.pm000444000765000024 315413045273257 21573 0ustar00jeffstaff000000000000package # Hide from PAUSE Test::SpawnRedisServer; use strict; use warnings; use File::Temp; use Guard; use POSIX ":sys_wait_h"; use base qw( Exporter ); our @EXPORT = qw( redis ); sub redis { my ($fh, $fn) = File::Temp::tempfile(); my $port = 11011 + ($$ % 127); $fh->print(" appendonly no daemonize no port $port bind 127.0.0.1 loglevel notice logfile redis-server.log "); $fh->flush; Test::More::diag("Redis port $port, cfg $fn") if $ENV{REDIS_DEBUG}; ## My local redis PATH $ENV{PATH} = "/usr/local/redis/sbin:/usr/local/bin:/usr/sbin:/usr/bin"; my $g; eval { $g = spawn_server($ENV{REDIS_SERVER_PATH} || 'redis-server', $fn) }; if (my $e = $@) { Test::More::plan skip_all => "Could not start redis-server: $@"; return; } return ($g, "127.0.0.1:$port"); } sub spawn_server { my $pid = fork(); if ($pid) { ## Parent require Test::More; Test::More::diag("Starting server with pid $pid") if $ENV{REDIS_DEBUG}; sleep(1); ## FIXME: we should PING it until he is ready return guard { Test::More::diag("Killing server at $pid") if $ENV{REDIS_DEBUG}; kill(15, $pid); my $try = 0; while ($try++ < 10) { my $ok = waitpid($pid, WNOHANG); $try = -1, last if $ok > 0; sleep(1); } Test::More::diag("Failed to kill server at $pid") if $ENV{REDIS_DEBUG} && $try > 0; unlink('redis-server.log'); }; } elsif (defined $pid) { ## Child exec(@_); die "Failed exec of '@_': $!, "; } die "Could not fork(): $!"; }