Commit 926bec9978cbd31dc448fb8d59c85f25f92af783 - libtest-mock-redis-perl

Imported Upstream version 0.14 gregor herrmann 10 years ago

17 changed file(s) with 782 addition(s) and 105 deletion(s). Raw diff Collapse all Expand all

+12

-6

Build.PL less more

0	0	use strict;
1	1	use warnings;
2		use Module::Build;
	2	use Module::Build 0.4004;
3	3
4	4	my $builder = Module::Build->new(
5	5	perl => '5.006_001',

13	13	bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis',
14	14	repository => 'http://github.com/jlavallee/Test-Mock-Redis/',
15	15	},
16		no_index => { package => [ 'Test::Mock::Redis::PossiblyVolitile',
	16	no_index => { package => [ 'Test::Mock::Redis::PossiblyVolatile',
17	17	'Test::Mock::Redis::List',
18	18	'Test::Mock::Redis::Hash',
19	19	'Test::Mock::Redis::ZSet',

22	22	},
23	23	},
24	24	build_requires => {
25		'Test::More' => 0,
26		'Test::Exception' => 0,
	25	'Test::More' => '0.88',
	26	'Test::Fatal' => 0,
	27	'Test::Deep' => 0,
	28	'Test::Deep::UnorderedPairs' => 0,
27	29	},
28	30	requires => {
29		'Test::More' => 0,
30		'Scalar::Util' => 0,
	31	'Scalar::Util' => 0,
	32	'Class::Method::Modifiers' => 0,
	33	'Package::Stash' => '0.34',
	34	'namespace::clean' => 0,
	35	'Try::Tiny' => 0,
31	36	},
	37	configure_requires => { 'Module::Build' => 0.4 },
32	38	add_to_cleanup => [ 'Test-Mock-Redis-*' ],
33	39	create_makefile_pl => 'traditional',
34	40	);

+39

-6

Changes less more

0	0	Revision history for Test-Mock-Redis
1	1
2		0.01 Sun Feb 13
	2	0.01 Feb 13 2011
3	3	First version, released on an unsuspecting world.
4		0.02 Mon Feb 14
	4
	5	0.02 Feb 14 2011
5	6	More redis functions, including auth, append, strlen, getset, mset & msetnx
6		0.03 Wed Feb 16
	7
	8	0.03 Feb 16 2011
7	9	Pay attention to the server argument to new - now a singleton per server, just like redis
8	10	Fixed Test::Exception dependency
9		0.04 Fri Feb 18
	11
	12	0.04 Feb 18 2011
10	13	Made error conditions consistent with Redis.pm's behavior
11		0.07 Wed Oct 5
	14
	15	0.07 Oct 5 2011
12	16	Fix for RT-71461, incorrect rename behavior
13	17
14		0.08
	18	0.08 Apr 13 2012
15	19	Correct type is returned for non-existent keys (RT#76534, Karen
16	20	Etheridge)
17	21
	22	0.09 Feb 26 2013
	23	Expired keys are not returned in the KEYS list (Karen Etheridge)
	24
	25	0.10 May 16 2013
	26	'info' output brought up-to-date w/redis 2.6
	27
	28	fixed output for these commands: (Karen Etheridge)
	29	should return OK, not 1:
	30	auth
	31	set
	32	setex
	33	mset
	34	rename
	35	ltrim
	36	lset
	37	select
	38	save
	39	should return a list length, not the list itself:
	40	rpush
	41	lpush
	42	rpushx
	43	lpushx
	44
	45	0.11 May 18 2013
	46	atomic transactions ('multi', 'exec', 'discard') now supported:
	47	http://redis.io/topics/transactions (Karen Etheridge)
	48
	49	0.12 Jun 12 2013
	50	support for pipelined calls, using callback subs (Karen Etheridge)

-0

MANIFEST less more

2	2	lib/Test/Mock/Redis.pm
3	3	Makefile.PL
4	4	MANIFEST This list of files
	5	META.json
5	6	META.yml
6	7	README
7	8	t/00-load.t

15	16	t/10-hash.t
16	17	t/11-sets.t
17	18	t/12-sorted-sets.t
	19	t/13-multi.t
	20	t/14-pipeline.t
18	21	t/boilerplate.t
19	22	t/manifest.t
20	23	t/pod.t

+83

-0

META.json less more

	0	{
	1	"abstract" : "use Redis; without redis",
	2	"author" : [
	3	"Jeff Lavallee <jeff@zeroclue.com>"
	4	],
	5	"dynamic_config" : 1,
	6	"generated_by" : "Module::Build version 0.4005, CPAN::Meta::Converter version 2.131560",
	7	"license" : [
	8	"perl_5"
	9	],
	10	"meta-spec" : {
	11	"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
	12	"version" : "2"
	13	},
	14	"name" : "Test-Mock-Redis",
	15	"no_index" : {
	16	"package" : [
	17	"Test::Mock::Redis::PossiblyVolatile",
	18	"Test::Mock::Redis::List",
	19	"Test::Mock::Redis::Hash",
	20	"Test::Mock::Redis::ZSet",
	21	"Test::Mock::Redis::Set"
	22	]
	23	},
	24	"prereqs" : {
	25	"build" : {
	26	"requires" : {
	27	"Test::Deep" : "0",
	28	"Test::Deep::UnorderedPairs" : "0",
	29	"Test::Fatal" : "0",
	30	"Test::More" : "0.88"
	31	}
	32	},
	33	"configure" : {
	34	"requires" : {
	35	"Module::Build" : "0.4"
	36	}
	37	},
	38	"runtime" : {
	39	"requires" : {
	40	"Class::Method::Modifiers" : "0",
	41	"Package::Stash" : "0.34",
	42	"Scalar::Util" : "0",
	43	"Try::Tiny" : "0",
	44	"namespace::clean" : "0"
	45	}
	46	}
	47	},
	48	"provides" : {
	49	"Test::Mock::Redis" : {
	50	"file" : "lib/Test/Mock/Redis.pm",
	51	"version" : "0.14"
	52	},
	53	"Test::Mock::Redis::Hash" : {
	54	"file" : "lib/Test/Mock/Redis.pm"
	55	},
	56	"Test::Mock::Redis::List" : {
	57	"file" : "lib/Test/Mock/Redis.pm"
	58	},
	59	"Test::Mock::Redis::PossiblyVolatile" : {
	60	"file" : "lib/Test/Mock/Redis.pm"
	61	},
	62	"Test::Mock::Redis::Set" : {
	63	"file" : "lib/Test/Mock/Redis.pm"
	64	},
	65	"Test::Mock::Redis::ZSet" : {
	66	"file" : "lib/Test/Mock/Redis.pm"
	67	}
	68	},
	69	"release_status" : "stable",
	70	"resources" : {
	71	"bugtracker" : {
	72	"web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis"
	73	},
	74	"license" : [
	75	"http://dev.perl.org/licenses/"
	76	],
	77	"repository" : {
	78	"url" : "http://github.com/jlavallee/Test-Mock-Redis/"
	79	}
	80	},
	81	"version" : "0.14"
	82	}

+15

-9

META.yml less more

2	2	author:
3	3	- 'Jeff Lavallee <jeff@zeroclue.com>'
4	4	build_requires:
5		Test::Exception: 0
6		Test::More: 0
	5	Test::Deep: 0
	6	Test::Deep::UnorderedPairs: 0
	7	Test::Fatal: 0
	8	Test::More: 0.88
7	9	configure_requires:
8		Module::Build: 0.36
9		generated_by: 'Module::Build version 0.3603'
	10	Module::Build: 0.4
	11	dynamic_config: 1
	12	generated_by: 'Module::Build version 0.4005, CPAN::Meta::Converter version 2.131560'
10	13	license: perl
11	14	meta-spec:
12	15	url: http://module-build.sourceforge.net/META-spec-v1.4.html

14	17	name: Test-Mock-Redis
15	18	no_index:
16	19	package:
17		- Test::Mock::Redis::PossiblyVolitile
	20	- Test::Mock::Redis::PossiblyVolatile
18	21	- Test::Mock::Redis::List
19	22	- Test::Mock::Redis::Hash
20	23	- Test::Mock::Redis::ZSet

22	25	provides:
23	26	Test::Mock::Redis:
24	27	file: lib/Test/Mock/Redis.pm
25		version: 0.08
	28	version: 0.14
26	29	Test::Mock::Redis::Hash:
27	30	file: lib/Test/Mock/Redis.pm
28	31	Test::Mock::Redis::List:
29	32	file: lib/Test/Mock/Redis.pm
30		Test::Mock::Redis::PossiblyVolitile:
	33	Test::Mock::Redis::PossiblyVolatile:
31	34	file: lib/Test/Mock/Redis.pm
32	35	Test::Mock::Redis::Set:
33	36	file: lib/Test/Mock/Redis.pm
34	37	Test::Mock::Redis::ZSet:
35	38	file: lib/Test/Mock/Redis.pm
36	39	requires:
	40	Class::Method::Modifiers: 0
	41	Package::Stash: 0.34
37	42	Scalar::Util: 0
38		Test::More: 0
	43	Try::Tiny: 0
	44	namespace::clean: 0
39	45	resources:
40	46	bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis
41	47	license: http://dev.perl.org/licenses/
42	48	repository: http://github.com/jlavallee/Test-Mock-Redis/
43		version: 0.08
	49	version: 0.14

+13

-7

Makefile.PL less more

0		# Note: this file was auto-generated by Module::Build::Compat version 0.3603
	0	# Note: this file was auto-generated by Module::Build::Compat version 0.4005
1	1	use ExtUtils::MakeMaker;
2	2	WriteMakefile
3	3	(
	4	'PL_FILES' => {},
	5	'INSTALLDIRS' => 'site',
4	6	'NAME' => 'Test::Mock::Redis',
	7	'EXE_FILES' => [],
5	8	'VERSION_FROM' => 'lib/Test/Mock/Redis.pm',
6	9	'PREREQ_PM' => {
	10	'Try::Tiny' => 0,
	11	'Test::Deep::UnorderedPairs' => 0,
7	12	'Scalar::Util' => 0,
8		'Test::Exception' => 0,
9		'Test::More' => 0
10		},
11		'INSTALLDIRS' => 'site',
12		'EXE_FILES' => [],
13		'PL_FILES' => {}
	13	'Package::Stash' => '0.34',
	14	'Test::Fatal' => 0,
	15	'Class::Method::Modifiers' => 0,
	16	'namespace::clean' => 0,
	17	'Test::More' => '0.88',
	18	'Test::Deep' => 0
	19	}
14	20	)
15	21	;

+313

-48

lib/Test/Mock/Redis.pm less more

5	5	use Carp;
6	6	use Config;
7	7	use Scalar::Util qw/blessed/;
	8	use Class::Method::Modifiers;
	9	use Package::Stash;
	10	use Try::Tiny;
	11	use namespace::clean; # important: clean all subs imported above this line
8	12
9	13	=head1 NAME
10	14

12	16
13	17	=head1 VERSION
14	18
15		Version 0.08
	19	Version 0.14
16	20
17	21	=cut
18	22
19		our $VERSION = '0.08';
	23	our $VERSION = '0.14';
20	24
21	25	=head1 SYNOPSIS
22	26

37	41	Redis.pm for testing purposes.
38	42
39	43	See perldoc Redis and the redis documentation at L<http://redis.io>
40
	44
	45	=head1 PERSISTENCE
	46
	47	The "connection" to the mocked server (and its stored data) will persist beyond
	48	the object instance, just like a real Redis server. This means that you do not
	49	need to save the instance to this object in order to preserve your data; simply
	50	call C<new> with the same server parameter and the same instance will be
	51	returned, with all data preserved.
41	52
42	53	=head1 SUBROUTINES/METHODS
43	54

49	60
50	61	It accepts the "server" argument, just like Redis.pm's new.
51	62
	63	=head2 num_databases
	64
	65	Redis ships with a default of 16 databases, and that's what this module
	66	handles by default. If you need to change that, do
	67
	68	use Test::Mock::Redis num_databases => 21;
	69
	70	or at run-time
	71
	72	Test::Mock::Redis::change_num_databases(21);
	73
52	74	=cut
53	75
	76	my $NUM_DBS = 16;
	77
	78	sub import {
	79	my ($class, %args) = @_;
	80
	81	if ($args{num_databases}){
	82	change_num_databases($args{num_databases});
	83	}
	84	}
	85
	86	sub change_num_databases {
	87	$NUM_DBS = shift;
	88	}
	89
	90
54	91	sub _new_db {
55		tie my %hash, 'Test::Mock::Redis::PossiblyVolitile';
	92	tie my %hash, 'Test::Mock::Redis::PossiblyVolatile';
56	93	return \%hash;
57	94	}
58	95
59		my $NUM_DBS = 16;
60	96
61	97	sub _defaults {
	98	my @hex = (0..9, 'a'..'f');
62	99	return (
63	100	_quit => 0,
64	101	_shutdown => 0,
65	102	_stash => [ map { _new_db } (1..$NUM_DBS) ],
	103	_num_dbs => $NUM_DBS,
66	104	_db_index => 0,
67	105	_up_since => time,
68	106	_last_save => time,
	107	_run_id => (join '', map { $hex[rand @hex] } 1..40), # E.G. '0e7e19fc45139fdb26ff3dd35ca6725d9882f1b7',
69	108	);
70	109	}
71	110

105	144
106	145	confess '[auth] ERR wrong number of arguments for \'auth\' command' unless @_;
107	146
108		return 1;
	147	return 'OK';
109	148	}
110	149
111	150	sub quit {
112	151	my $self = shift;
113	152
114		confess "Not connected to any server" if $self->{_quit};
	153	my $return = !$self->{_quit};
	154
115	155	$self->{_quit} = 1;
	156	return $return;
116	157	}
117	158
118	159	sub shutdown {

125	166	my ( $self, $key, $value ) = @_;
126	167
127	168	$self->_stash->{$key} = "$value";
128		return 1;
	169	return 'OK';
129	170	}
130	171
131	172	sub setnx {

142	183	my ( $self, $key, $ttl, $value ) = @_;
143	184	$self->set($key, $value);
144	185	$self->expire($key, $ttl);
145		return 1;
	186	return 'OK';
146	187	}
147	188
148	189	sub expire {

264	305
265	306	@{ $self->_stash }{keys %things} = (values %things);
266	307
267		return 1;
	308	return 'OK';
268	309	}
269	310
270	311	sub msetnx {

318	359	$match =~ s/(?<!\\)\/./g;
319	360	$match =~ s/(?<!\\)\?/.?/g;
320	361
321		return @{[ sort { $a cmp $b } grep { /$match/ } keys %{ $self->_stash }]};
	362	return @{[ sort { $a cmp $b }
	363	grep { exists $self->_stash->{$_} }
	364	grep { /$match/ }
	365	keys %{ $self->_stash }]};
322	366	}
323	367
324	368	sub randomkey {

339	383
340	384	$self->_stash->{$to} = $self->_stash->{$from};
341	385	delete $self->_stash->{$from};
342		return 1;
	386	return 'OK';
343	387	}
344	388
345	389	sub renamenx {

360	404
361	405	$self->_make_list($key);
362	406
363		return push @{ $self->_stash->{$key} }, "$value";
	407	push @{ $self->_stash->{$key} }, "$value";
	408	return scalar @{ $self->_stash->{$key} };
364	409	}
365	410
366	411	sub lpush {

371	416
372	417	$self->_make_list($key);
373	418
374		return unshift @{ $self->_stash->{$key} }, "$value";
	419	unshift @{ $self->_stash->{$key} }, "$value";
	420	return scalar @{ $self->_stash->{$key} };
375	421	}
376	422
377	423	sub rpushx {

379	425
380	426	return unless $self->_is_list($key);
381	427
382		return push @{ $self->_stash->{$key} }, "$value";
	428	push @{ $self->_stash->{$key} }, "$value";
	429	return scalar @{ $self->_stash->{$key} };
383	430	}
384	431
385	432	sub lpushx {

387	434
388	435	return unless $self->_is_list($key);
389	436
390		return unshift @{ $self->_stash->{$key} }, "$value";
	437	unshift @{ $self->_stash->{$key} }, "$value";
	438	return scalar @{ $self->_stash->{$key} };
391	439	}
392	440
393	441	sub llen {

408	456	my ( $self, $key, $start, $end ) = @_;
409	457
410	458	$self->_stash->{$key} = [ @{ $self->_stash->{$key} }[$start..$end] ];
411		return 1;
	459	return 'OK';
412	460	}
413	461
414	462	sub lindex {

421	469	my ( $self, $key, $index, $value ) = @_;
422	470
423	471	$self->_stash->{$key}->[$index] = "$value";
424		return 1;
	472	return 'OK';
425	473	}
426	474
427	475	sub lrem {

462	510	sub select {
463	511	my ( $self, $index ) = @_;
464	512
	513	my $max_index = $#{ $self->{_stash} };
	514	if ($index > $max_index ){
	515	die "You called select($index), but max allowed is $max_index unless you configure more databases";
	516	}
	517
465	518	$self->{_db_index} = $index;
466		return 1;
	519	return 'OK';
467	520	}
468	521
469	522	sub _stash {

788	841	sub save {
789	842	my $self = shift;
790	843	$self->{_last_save} = time;
791		return 1;
	844	return 'OK';
792	845	}
793	846
794	847	sub bgsave {

805	858	my $self = shift;
806	859
807	860	return {
808		arch_bits => $Config{use64bitint } ? '64' : '32',
809		bgrewriteaof_in_progress => '0',
810		bgsave_in_progress => '0',
811		blocked_clients => '0',
812		changes_since_last_save => '0',
813		connected_clients => '1',
814		connected_slaves => '0',
815		expired_keys => '0',
816		hash_max_zipmap_entries => '64',
817		hash_max_zipmap_value => '512',
818		last_save_time => $self->{_last_save},
819		mem_fragmentation_ratio => '0.11',
820		multiplexing_api => 'kqueue',
821		process_id => $$,
822		pubsub_channels => '0',
823		pubsub_patterns => '0',
824		redis_git_dirty => '0',
825		redis_git_sha1 => 'da14590b',
826		redis_version => '2.1.4',
827		role => 'master',
828		total_commands_processed => '84',
829		total_connections_received => '14',
	861	aof_current_rewrite_time_sec => '-1',
	862	aof_enabled => '0',
	863	aof_last_bgrewrite_status => 'ok',
	864	aof_last_rewrite_time_sec => '-1',
	865	aof_rewrite_in_progress => '0',
	866	aof_rewrite_scheduled => '0',
	867	arch_bits => $Config{use64bitint } ? '64' : '32',
	868	blocked_clients => '0',
	869	client_biggest_input_buf => '0',
	870	client_longest_output_list => '0',
	871	connected_clients => '1',
	872	connected_slaves => '0',
	873	evicted_keys => '0',
	874	expired_keys => '0',
	875	gcc_version => '4.2.1',
	876	instantaneous_ops_per_sec => '568',
	877	keyspace_hits => '272',
	878	keyspace_misses => '0',
	879	latest_fork_usec => '0',
	880	loading => '0',
	881	lru_clock => '1994309',
	882	mem_allocator => 'libc',
	883	mem_fragmentation_ratio => '1.61',
	884	multiplexing_api => 'kqueue',
	885	os => $Config{osname}.' '.$Config{osvers}, # should be like 'Darwin 12.2.1 x86_64', this is close
	886	process_id => $$,
	887	pubsub_channels => '0',
	888	pubsub_patterns => '0',
	889	rdb_bgsave_in_progress => '0',
	890	rdb_changes_since_last_save => '0',
	891	rdb_current_bgsave_time_sec => '-1',
	892	rdb_last_bgsave_status => 'ok',
	893	rdb_last_bgsave_time_sec => '-1',
	894	rdb_last_save_time => '1362120372',
	895	redis_git_dirty => '0',
	896	redis_git_sha1 => '34b420db',
	897	redis_mode => 'standalone',
	898	redis_version => '2.6.10',
	899	rejected_connections => '0',
	900	role => 'master',
	901	run_id => $self->{_run_id},
	902	tcp_port => '11084',
	903	total_commands_processed => '1401',
	904	total_connections_received => '1',
830	905	uptime_in_days => (time - $self->{_up_since}) / 60 / 60 / 24,
831	906	uptime_in_seconds => time - $self->{_up_since},
832		used_memory => '3918288',
833		used_memory_human => '3.74M',
834		vm_enabled => '0',
	907	used_cpu_sys => '0.04',
	908	used_cpu_sys_children => '0.00',
	909	used_cpu_user => '0.02',
	910	used_cpu_user_children => '0.00',
	911	used_memory => '1056288',
	912	used_memory_human => '1.01M',
	913	used_memory_lua => '31744',
	914	used_memory_peak => '1055728',
	915	used_memory_peak_human => '1.01M',
	916	used_memory_rss => '1699840',
835	917	map { 'db'.$_ => sprintf('keys=%d,expires=%d',
836	918	scalar keys %{ $self->_stash($_) },
837	919	$self->_expires_count_for_db($_),

970	1052	return scalar @remove;
971	1053	}
972	1054
	1055	=head1 PIPELINING
	1056
	1057	See L<Redis/PIPELINING> -- most methods support the use of a callback sub as
	1058	the final argument. For this implementation, the callback sub will be called
	1059	immediately (before the result of the original method is returned), and
	1060	C<wait_all_responses> does nothing. Combining pipelining with C<multi>/C<exec>
	1061	is not supported.
973	1062
974	1063	=head1 TODO
975	1064

1048	1137
1049	1138	Dobrica Pavlinusic & Pedro Melo for Redis.pm
1050	1139
	1140	The following people have contributed to I<Test::Mock::Redis>:
	1141
	1142	=over
	1143
	1144	=item * Karen Etheridge
	1145
	1146	=item * Kevin Goess
	1147
	1148	=back
	1149
1051	1150	=head1 LICENSE AND COPYRIGHT
1052	1151
1053		Copyright 2011 Jeff Lavallee.
	1152	Copyright 2011, 2012, 2013 Jeff Lavallee.
1054	1153
1055	1154	This program is free software; you can redistribute it and/or modify it
1056	1155	under the terms of either: the GNU General Public License as published
1057	1156	by the Free Software Foundation; or the Artistic License.
1058	1157
1059		See http://dev.perl.org/licenses/ for more information.
	1158	See L<http://dev.perl.org/licenses/> for more information.
1060	1159
1061	1160
1062	1161	=cut

1123	1222	}
1124	1223
1125	1224
	1225	# MULTI/EXEC/DISCARD: http://redis.io/topics/transactions
	1226
	1227	sub multi {
	1228	my ( $self ) = @_;
	1229
	1230	confess '[multi] ERR MULTI calls can not be nested' if defined $self->{_multi_commands};
	1231
	1232	# set up the list for storing commands sent between MULTI and EXEC/DISCARD
	1233	$self->{_multi_commands} = [];
	1234
	1235	return 'OK';
	1236	}
	1237
	1238	# methods that return a list, rather than a single value
	1239	my @want_list = qw(mget keys lrange smembers sinter sunion sdiff hmget hkeys hvals hgetall sort zrange zrevrange zrangebyscore);
	1240	my %want_list = map { $_ => 1 } @want_list;
	1241
	1242	sub exec {
	1243	my ( $self ) = @_;
	1244
	1245	# we are going to commit all the changes we saved up;
	1246	# replay them now and return all their output
	1247
	1248	confess '[exec] ERR EXEC without MULTI' if not defined $self->{_multi_commands};
	1249
	1250	my @commands = @{$self->{_multi_commands}};
	1251	delete $self->{_multi_commands};
	1252
	1253	# replay all the queries that were queued up
	1254	# the returned result is a nested array of the results of all the commands
	1255	my @exceptions;
	1256	my @results = map {
	1257	my ($method, @args) = @$_;
	1258	my @result =
	1259	try { $self->$method(@args) }
	1260	catch { push @exceptions, $_; (); };
	1261	$want_list{$method} ? \@result : $result[0];
	1262	} @commands;
	1263
	1264	s/^\[\w+\] // for @exceptions;
	1265
	1266	confess('[exec] ', join('; ', @exceptions)) if @exceptions;
	1267
	1268	return @results;
	1269	}
	1270
	1271	sub discard {
	1272	my ( $self ) = @_;
	1273
	1274	confess '[discard] ERR DISCARD without MULTI' if not defined $self->{_multi_commands};
	1275
	1276	# discard all the accumulated commands, without executing them
	1277	delete $self->{_multi_commands};
	1278
	1279	return 'OK';
	1280	}
	1281
	1282	# now that we've defined all our subs, we need to wrap them all in logic that
	1283	# can check if we are in the middle of a MULTI, and if so, queue up the
	1284	# commands for later replaying.
	1285
	1286	my %no_transaction_wrap_methods = (
	1287	new => 1,
	1288	multi => 1,
	1289	exec => 1,
	1290	discard => 1,
	1291	quit => 1,
	1292	import => 1,
	1293	change_num_databases => 1,
	1294	);
	1295
	1296	my @transaction_wrapped_methods =
	1297	grep { !/^_/}
	1298	grep { not $no_transaction_wrap_methods{$_} }
	1299	Package::Stash->new(__PACKAGE__)->list_all_symbols('CODE');
	1300
	1301	foreach my $method (@transaction_wrapped_methods)
	1302	{
	1303	around $method => sub {
	1304	my $orig = shift;
	1305	my $self = shift;
	1306
	1307	# pass command through if we are not handling a MULTI
	1308	return $self->$orig(@_) if not defined $self->{_multi_commands};
	1309
	1310	push @{$self->{_multi_commands}}, [ $method, @_ ];
	1311	return 'QUEUED';
	1312	};
	1313	}
	1314
	1315
	1316	# PIPELINING SUPPORT
	1317
	1318	# these method modifications must be done after (over top of) the modification
	1319	# for transactions, as we need to check for/extract the $cb first.
	1320
	1321	my %no_pipeline_wrap_methods = (
	1322	new => 1,
	1323	multi => 1,
	1324	discard => 1,
	1325	quit => 1,
	1326	ping => 1,
	1327	subscribe => 1,
	1328	unsubscribe => 1,
	1329	psubscribe => 1,
	1330	punsubscribe => 1,
	1331	wait_all_responses => 1,
	1332	);
	1333
	1334	my @pipeline_wrapped_methods =
	1335	grep { !/^_/}
	1336	grep { not $no_pipeline_wrap_methods{$_} }
	1337	Package::Stash->new(__PACKAGE__)->list_all_symbols('CODE');
	1338
	1339	# this is a bit messy, and the wantarray logic may not be quite right.
	1340	# Alternatively, we could implement all this by reusing the logic in the real
	1341	# Redis.pm -- subclass Redis, override new/multi/exec/discard (and probably
	1342	# some other special functions), and have __run_cmd use a dispatch table to
	1343	# call all our overridden implementations.
	1344
	1345	foreach my $method (@pipeline_wrapped_methods)
	1346	{
	1347	around $method => sub {
	1348	my $orig = shift;
	1349	my $self = shift;
	1350	my @args = @_;
	1351
	1352	my $cb = @args && ref $args[-1] eq 'CODE' ? pop @args : undef;
	1353
	1354	return $self->$orig(@args) if not $cb;
	1355
	1356	# this may be officially supported eventually -- see
	1357	# https://github.com/melo/perl-redis/issues/17
	1358	# and "Pipeline management" in the Redis docs
	1359	# To make this work, we just need to special-case exec, to collect all the
	1360	# results and errors in tuples and send that to the $cb
	1361	die 'cannot combine pipelining with MULTI' if $self->{_multi_commands};
	1362
	1363	# We could also implement this with a queue, not bothering to process
	1364	# the commands until wait_all_responses is called - but then we need to
	1365	# make sure to call wait_all_responses explicitly as soon as a command
	1366	# is issued without a $cb.
	1367
	1368	my $error;
	1369	my (@result) = try
	1370	{
	1371	$self->$orig(@args);
	1372	}
	1373	catch
	1374	{
	1375	$error = $_;
	1376	();
	1377	};
	1378
	1379	$cb->(
	1380	# see notes above - this logic may not be quite right
	1381	( $want_list{$method} ? \@result : $result[0] ),
	1382	$error,
	1383	);
	1384	return 1;
	1385	};
	1386	}
	1387
	1388	# in a real Redis system, this will make all outstanding callbacks get called.
	1389	sub wait_all_responses {}
	1390
1126	1391
1127	1392	1; # End of Test::Mock::Redis
1128	1393

1142	1407	sub new { return bless {}, shift }
1143	1408	1;
1144	1409
1145		package Test::Mock::Redis::PossiblyVolitile;
	1410	package Test::Mock::Redis::PossiblyVolatile;
1146	1411
1147	1412	use strict; use warnings;
1148	1413	use Tie::Hash;

+10

-4

t/00-load.t less more

1	1
2	2	use strict;
3	3	use warnings;
4		use Test::More tests => 1;
	4	use Test::More tests => 3;
5	5
6	6	BEGIN {
7		use_ok( 'Test::Mock::Redis' ) \|\| print "Bail out!
8		";
	7	use_ok('Test::Mock::Redis') \|\| print "Bail out!";
9	8	}
10	9
11		diag( "Testing Test::Mock::Redis $Test::Mock::Redis::VERSION, Perl $], $^X" );
	10	use_ok('Test::Mock::Redis', num_databases => 42);
	11
	12	my $r = Test::Mock::Redis->new(server => 'foobar');
	13
	14	is($r->{_num_dbs}, 42, "num_databases import argument was respected");
	15
	16
	17	diag("Testing Test::Mock::Redis $Test::Mock::Redis::VERSION, Perl $], $^X");

-3

t/01-basic.t less more

6	6	use strict;
7	7	use lib 't/tlib';
8	8	use Test::More;
9		use Test::Exception;
	9	use Test::Fatal;
10	10	use Test::Mock::Redis;
11	11
12	12	ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server');

94	94	cmp_ok($o->type('foo'), 'eq', 'string', 'type');
95	95
96	96	is($o->keys('key-'), $key_next + 1, 'key-');
97		is_deeply([$o->keys('key-*')], [@keys], 'keys');
	97
	98	is_deeply([sort $o->keys('key-*')], [sort @keys], 'keys');
98	99
99	100	ok(my $key = $o->randomkey, 'randomkey');
100	101

328	329	ok(!$o->ping(), 'ping() also false after shutdown()');
329	330
330	331	sleep(1);
331		throws_ok sub { $type->new(server => $srv) },
	332	like exception { $type->new(server => $srv) },
332	333	qr/Could not connect to Redis server at $srv/,
333	334	'Failed connection throws exception';
334	335

-6

t/05-server.t less more

3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Exception;
7	6	use Test::Mock::Redis;
8	7
9	8

58	57	eval{ $r->auth };
59	58	like($@, qr/^\Q[auth] ERR wrong number of arguments for 'auth' command\E/, 'auth without a password dies');
60	59
61		ok($r->auth('foo'), 'auth with anything else returns true');
62
	60	# as of redis 2.6 (?) this fails when auth is not enabled on the server
	61	# eval{ $r->auth('foo') };
	62	# like($@, qr/^\Q[auth] ERR Client sent AUTH, but no password is set\E/, 'auth when no password set dies');
	63	# however, emulating this behavior is not likely to be useful - better to silently
	64	# pretend that any auth worked than throw an error.
63	65
64	66	for(0..15){
65	67	$r->select($_);

105	107
106	108	#use Data::Dumper; diag Dumper $info;
107	109
108		like($info->{last_save_time}, qr/^\d+$/, 'last save time is some digits');
	110	like($info->{run_id},qr/^[0-9a-f]{40}/, 'run_id is 40 random hex chars');
109	111
110	112	for(0..14){
111	113	is($info->{"db$_"}, 'keys=1,expires=0', "db$_ info is correct");

118	120
119	121	is($r->info->{'db0'}, 'keys=6,expires=5', 'db0 info now has six keys and five expire');
120	122
121
122	123	ok($r->quit, 'quit returns true');
123		throws_ok { $r->quit } qr/^\QNot connected to any server\E\b/, '...even if we call it again';
	124	ok(!$r->quit, 'quit returns false the second time');
124	125
125	126	ok(! $r->ping, 'ping returns false after we quit');
126	127

-4

t/06-keys.t less more

3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Exception;
	6	use Test::Fatal;
7	7	use Test::Mock::Redis;
8	8
9	9	=pod

64	64
65	65	ok(grep { $_ eq $rand } qw/foo bar baz/, 'random returned one of our keys');
66	66
67		throws_ok { $r->rename('foo', 'foo') } qr/^\Q[rename] ERR source and destination objects are the same\E/,
	67	like exception { $r->rename('foo', 'foo') }, qr/^\Q[rename] ERR source and destination objects are the same\E/,
68	68	'rename with identical source and dest returns false';
69	69
70		throws_ok { $r->rename('quizlebub', 'foo') } qr/^\Q[rename] ERR no such key\E/,
	70	like exception { $r->rename('quizlebub', 'foo') }, qr/^\Q[rename] ERR no such key\E/,
71	71	"rename with source that doesn't exist returns false";
72	72
73	73

78	78	is_deeply([sort $r->keys('*')], [qw/bar baz newfoo/], 'rename removed foo');
79	79
80	80
81		throws_ok { $r->keys } qr/^\Q[KEYS] ERR wrong number of arguments for 'keys' command\E/,
	81	like exception { $r->keys }, qr/^\Q[KEYS] ERR wrong number of arguments for 'keys' command\E/,
82	82	'keys with no argument complains';
83	83
84	84	$r->set('foo', 'foobar');

-0

t/07-expires.t less more

37	37
38	38	sleep 2;
39	39
	40	is_deeply([ sort $r->keys('*') ], [ qw(baz foo) ], 'expired key removed from KEYS list');
	41
40	42	ok(! $r->exists('bar'), 'bar expired');
41	43
42	44	ok(! $r->expireat('quizlebub', time + 1), "expireat on a key that doesn't exist returns false");

-8

t/10-hash.t less more

3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Exception;
	6	use Test::Fatal;
7	7	use Test::Mock::Redis;
8	8
9	9	=pod

63	63
64	64	is $r->get('hash'), 'blarg', "even though it squashed it";
65	65
66		throws_ok { $r->hset('hash', 'foo', 'foobar') }
	66	like exception { $r->hset('hash', 'foo', 'foobar') },
67	67	qr/^\Q[hset] ERR Operation against a key holding the wrong kind of value\E/,
68	68	"hset throws error when we overwrite a string with a hash";
69	69
70	70	ok ! $r->hexists('blarg', 'blorf'), "hexists on a hash that doesn't exist returns false";
71	71
72		throws_ok { $r->hexists('hash', 'blarg') }
	72	like exception { $r->hexists('hash', 'blarg') },
73	73	qr/^\Q[hexists] ERR Operation against a key holding the wrong kind of value\E/,
74	74	"hexists on a field that's not a hash throws error";
75	75

92	92
93	93	$r->set('not a hash', 'foo bar');
94	94
95		throws_ok { $r->hkeys('not a hash') }
	95	like exception { $r->hkeys('not a hash') },
96	96	qr/^\Q[hkeys] ERR Operation against a key holding the wrong kind of value\E/,
97	97	"hkeys on key that isn't a hash throws error";
98	98

104	104
105	105	is_deeply { $r->hgetall("I don't exist") }, { }, "hgetall on non-existent key is empty";
106	106
107		throws_ok { $r->hgetall('not a hash') }
	107	like exception { $r->hgetall('not a hash') },
108	108	qr/^\Q[hgetall] ERR Operation against a key holding the wrong kind of value\E/,
109	109	"hgetall on key that isn't a hash throws error";
110	110

116	116
117	117	$r->set('not a hash', 'foo bar');
118	118
119		throws_ok { $r->hvals('not a hash') }
	119	like exception { $r->hvals('not a hash') },
120	120	qr/^\Q[hvals] ERR Operation against a key holding the wrong kind of value\E/,
121	121	"hvals on key that isn't a hash throws error";
122	122

130	130	is_deeply [ $r->hmget('hash', qw/blarg blorf/) ], [ undef, undef ],
131	131	"hmget returns undef even if all values are missing";
132	132
133		throws_ok { $r->hincrby('hash', 'foo') }
	133	like exception { $r->hincrby('hash', 'foo') },
134	134	qr/^\Q[hincrby] ERR wrong number of arguments for 'hincrby' command\E/,
135	135	"hincerby dies when called with the wrong number of arguments";
136	136
137		throws_ok { $r->hincrby('hash', 'foo', 1) }
	137	like exception { $r->hincrby('hash', 'foo', 1) },
138	138	qr/^\Q[hincrby] ERR hash value is not an integer\E/,
139	139	"hincrby dies when a non-integer is incremented";
140	140

-3

t/11-sets.t less more

3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Exception;
	6	use Test::Fatal;
7	7	use Test::Mock::Redis;
8	8
9	9	=pod

146	146
147	147	$r->set('justakey', 'foobar');
148	148
149		throws_ok { $r->smove('justakey', 'set', 'foo') }
	149	like exception { $r->smove('justakey', 'set', 'foo') },
150	150	qr/^\Q[smove] ERR Operation against a key holding the wrong kind of value\E/,
151	151	"smove dies when source isn't a set";
152	152
153		throws_ok { $r->smove('set', 'justakey', 'foo') }
	153	like exception { $r->smove('set', 'justakey', 'foo') },
154	154	qr/^\Q[smove] ERR Operation against a key holding the wrong kind of value\E/,
155	155	"smove dies when dest isn't a set";
156	156

+147

-0

t/13-multi.t less more

	0	use strict;
	1	use warnings FATAL => 'all';
	2
	3	use Test::More 0.88;
	4	use Test::Deep;
	5	use Test::Fatal;
	6	use Test::Mock::Redis;
	7
	8	use lib 't/tlib';
	9
	10	=pod
	11	x MULTI
	12	x EXEC
	13	x DISCARD
	14	=cut
	15
	16	# There is a known issue in the real Redis client that screws up the
	17	# interpretation of all results from the client after an error in the middle of
	18	# a multi -- https://github.com/melo/perl-redis/issues/42
	19	# Because of this, this one test file uses a subref for its redis object,
	20	# rather than the object itself, so it can get a new object at the right time
	21	# so we can continue tests...
	22
	23	my $r = sub { Test::Mock::Redis->new };
	24	ok($r->(), 'pretended to connect to our test redis-server');
	25	my @redi = ($r);
	26
	27	my ( $guard, $srv );
	28	if( $ENV{RELEASE_TESTING} ){
	29	use_ok("Redis");
	30	use_ok("Test::SpawnRedisServer");
	31	($guard, $srv) = redis();
	32
	33	my $r = sub { Redis->new(server => $srv) };
	34	my $redis = $r->();
	35	ok($redis, 'connected to our test redis-server');
	36	$redis->flushall;
	37	unshift @redi, $r
	38	}
	39
	40	foreach my $o (@redi)
	41	{
	42	my $redis = $o->();
	43
	44	diag("testing $redis") if $ENV{RELEASE_TESTING};
	45
	46	ok($redis->ping, 'ping');
	47
	48	like(
	49	exception { $redis->exec },
	50	qr/^\[exec\] ERR EXEC without MULTI/,
	51	'cannot call EXEC before MULTI',
	52	);
	53
	54	like(
	55	exception { $redis->discard },
	56	qr/^\[discard\] ERR DISCARD without MULTI/,
	57	'cannot call DISCARD before MULTI',
	58	);
	59
	60	like(
	61	exception { $redis->multi; $redis->multi },
	62	qr/^\[multi\] ERR MULTI calls can not be nested/,
	63	'cannot call MULTI again until EXEC or DISCARD is called',
	64	);
	65
	66	is($redis->discard, 'OK', 'multi state has been reset');
	67
	68
	69	# discarded transactions
	70
	71	is($redis->multi, 'OK', 'multi transaction started');
	72	is($redis->hmset('transaction_key_1', qw(a 1 b 2)), 'QUEUED', 'hmset operation recorded');
	73
	74	cmp_deeply(
	75	$redis->discard,
	76	'OK',
	77	'transaction discarded',
	78	);
	79
	80	cmp_deeply(
	81	{ $redis->hgetall('transaction_key_1') },
	82	{ },
	83	'data was not altered',
	84	);
	85
	86
	87	# successful transactions
	88
	89	is($redis->multi, 'OK', 'multi transaction started');
	90	is($redis->hmset('transaction_key_3', qw(a 1 b 2)), 'QUEUED', 'hmset operation recorded');
	91	cmp_deeply([ $redis->keys('transaction_key_*') ], [ 'QUEUED' ], 'keys operation recorded');
	92	is($redis->set('transaction_key_4', 'ohhai'), 'QUEUED', 'set operation recorded');
	93	cmp_deeply([ $redis->keys('transaction_key_*') ], [ 'QUEUED' ], 'keys operation recorded');
	94
	95	cmp_deeply(
	96	[ $redis->exec ],
	97	[
	98	'OK',
	99	[ 'transaction_key_3' ], # transaction_key_4 hasn't been set yet
	100	'OK',
	101	bag(qw(transaction_key_3 transaction_key_4)),
	102	],
	103	'transaction finished, returning the results of all queries',
	104	);
	105
	106	cmp_deeply(
	107	{ $redis->hgetall('transaction_key_3') },
	108	{
	109	a => '1',
	110	b => '2',
	111	},
	112	'hash data successfully recorded',
	113	);
	114
	115
	116	# an error in replaying a transaction should not abort subsequent commands
	117	# note: this mirrors behaviour in version 2.6.5+
	118
	119	is($redis->multi, 'OK', 'multi transaction started');
	120	is($redis->set('transaction_key_1', 'foo'), 'QUEUED', 'set operation recorded');
	121	is($redis->hset('transaction_key_1', 'bar', '9'), 'QUEUED', 'hset operation recorded');
	122	is($redis->hset('transaction_key_3', 'a', '9'), 'QUEUED', 'hset operation recorded');
	123
	124	like(
	125	exception { $redis->exec },
	126	qr/^\[exec\] ERR Operation against a key holding the wrong kind of value/,
	127	'a bad transaction results in an exception',
	128	);
	129
	130	# we need to get a new redis client now -- see notes above
	131	$redis = $o->();
	132
	133	is($redis->get('transaction_key_1'), 'foo', 'the first command was executed');
	134
	135	cmp_deeply(
	136	{ $redis->hgetall('transaction_key_3') },
	137	{
	138	a => '9',
	139	b => '2',
	140	},
	141	'commands after the error were still executed',
	142	);
	143	}
	144
	145
	146	done_testing;

+119

-0

t/14-pipeline.t less more

	0	use strict;
	1	use warnings FATAL => 'all';
	2
	3	use Test::More 0.88;
	4	use Test::Deep;
	5	use Test::Fatal;
	6	use Test::Deep::UnorderedPairs;
	7	use Test::Mock::Redis;
	8
	9	use lib 't/tlib';
	10
	11	ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server');
	12	my @redi = ($r);
	13
	14	my ( $guard, $srv );
	15	if( $ENV{RELEASE_TESTING} ){
	16	use_ok("Redis");
	17	use_ok("Test::SpawnRedisServer");
	18	($guard, $srv) = redis();
	19	ok(my $r = Redis->new(server => $srv), 'connected to our test redis-server');
	20	$r->flushall;
	21	unshift @redi, $r
	22	}
	23
	24	foreach my $redis (@redi)
	25	{
	26	diag("testing $redis") if $ENV{RELEASE_TESTING};
	27
	28	ok($redis->ping, 'ping');
	29
	30
	31	is(
	32	$redis->hmset(
	33	'pipeline_key_1', qw(a 1 b 2),
	34	sub { cmp_deeply(\@_, [ 'OK', undef ], 'hmset callback') },
	35	),
	36	'1',
	37	'hmset command sent',
	38	);
	39
	40	is(
	41	$redis->set(
	42	'pipeline_key_2', 'ohhai',
	43	sub { cmp_deeply(\@_, [ 'OK', undef ], 'set callback') },
	44	),
	45	'1',
	46	'set command sent',
	47	);
	48
	49	is(
	50	$redis->keys(
	51	'pipeline_key_*',
	52	sub { cmp_deeply(\@_, [ bag(qw(pipeline_key_1 pipeline_key_2)), undef ], 'keys callback') },
	53	),
	54	'1',
	55	'keys operation sent',
	56	);
	57
	58	cmp_deeply(
	59	[
	60	$redis->hgetall(
	61	'pipeline_key_1',
	62	sub { cmp_deeply(\@_, [ tuples(a => 1, b => 2), undef ], 'hgetall callback') },
	63	),
	64	],
	65	[ '1' ],
	66	'hgetall operation sent (wantarray=1)',
	67	);
	68
	69	is(
	70	$redis->hset(
	71	'pipeline_key_2', 'bar', '9',
	72	# weird, when pipelining, the real redis doesn't always include the command name?
	73	sub { cmp_deeply(\@_, [ undef, re(qr/^(\[hset\] )?ERR Operation against a key holding the wrong kind of value/) ], 'hset callback') },
	74	),
	75	'1',
	76	'hset operation sent',
	77	);
	78
	79	# flush all outstanding commands and test their callbacks
	80	$redis->wait_all_responses;
	81
	82
	83	TODO: {
	84	# this may be officially supported eventually -- see
	85	# https://github.com/melo/perl-redis/issues/17
	86
	87	local $TODO = 'Redis.pm docs recommend avoiding transactions + pipelining for now';
	88
	89	is(
	90	exception {
	91	$redis->multi;
	92	is($redis->set('pipeline_key_2', 'ohhai'), 'QUEUED', 'set command queued inside a transaction');
	93	is(
	94	$redis->exec(sub {
	95	cmp_deeply(
	96	\@_,
	97	[
	98	[
	99	[ 'OK', undef ], # result, error from 'set' call
	100	],
	101	undef,
	102	],
	103	'callback sent arrayref of result/error tuples from the transaction',
	104	)
	105	}),
	106	'1',
	107	'exec command sent',
	108	);
	109	$redis->wait_all_responses;
	110	},
	111	undef,
	112	'exec in a pipeline is supported',
	113	);
	114	}
	115	}
	116
	117
	118	done_testing;

-1

t/tlib/Test/SpawnRedisServer.pm less more

15	15
16	16	$fh->print("
17	17	appendonly no
18		vm-enabled no
19	18	daemonize no
20	19	port $port
21	20	bind 127.0.0.1