Commit 79276ac4d405e1562c2c6197fc2d84f4e3e85535 - libtest-mock-redis-perl

New upstream version 0.22 gregor herrmann 4 years ago

23 changed file(s) with 262 addition(s) and 151 deletion(s). Raw diff Collapse all Expand all

-0

Changes less more

0	0	Revision history for Perl module Test::Mock::Redis
	1
	2	0.22 2019-06-26
	3	- Major update via pull request 28 on github (Valery Kalesnik)
1	4
2	5	0.21 2018-12-19
3	6	- fix lrem issue with array length changing (Thomas Bloor)

-5

META.json less more

3	3	"Jeff Lavallee <jeff@zeroclue.com>"
4	4	],
5	5	"dynamic_config" : 1,
6		"generated_by" : "Module::Build version 0.422",
	6	"generated_by" : "Module::Build version 0.4229",
7	7	"license" : [
8	8	"perl_5"
9	9	],
10	10	"meta-spec" : {
11	11	"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
12		"version" : "2"
	12	"version" : 2
13	13	},
14	14	"name" : "Test-Mock-Redis",
15	15	"no_index" : {

48	48	"provides" : {
49	49	"Test::Mock::Redis" : {
50	50	"file" : "lib/Test/Mock/Redis.pm",
51		"version" : "0.21"
	51	"version" : "0.22"
52	52	},
53	53	"Test::Mock::Redis::Hash" : {
54	54	"file" : "lib/Test/Mock/Redis.pm"

78	78	"url" : "http://github.com/jlavallee/Test-Mock-Redis/"
79	79	}
80	80	},
81		"version" : "0.21",
82		"x_serialization_backend" : "JSON::PP version 2.27300"
	81	"version" : "0.22",
	82	"x_serialization_backend" : "JSON::PP version 2.97001"
83	83	}

-3

META.yml less more

9	9	configure_requires:
10	10	Module::Build: '0.4'
11	11	dynamic_config: 1
12		generated_by: 'Module::Build version 0.422, CPAN::Meta::Converter version 2.150010'
	12	generated_by: 'Module::Build version 0.4229, CPAN::Meta::Converter version 2.150010'
13	13	license: perl
14	14	meta-spec:
15	15	url: http://module-build.sourceforge.net/META-spec-v1.4.html

25	25	provides:
26	26	Test::Mock::Redis:
27	27	file: lib/Test/Mock/Redis.pm
28		version: '0.21'
	28	version: '0.22'
29	29	Test::Mock::Redis::Hash:
30	30	file: lib/Test/Mock/Redis.pm
31	31	Test::Mock::Redis::List:

46	46	bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Mock-Redis
47	47	license: http://dev.perl.org/licenses/
48	48	repository: http://github.com/jlavallee/Test-Mock-Redis/
49		version: '0.21'
	49	version: '0.22'
50	50	x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

+11

-11

Makefile.PL less more

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

+141

-81

lib/Test/Mock/Redis.pm less more

2	2	use warnings;
3	3	use strict;
4	4
5		use Carp;
	5	use Carp 'confess';
6	6	use Config;
7	7	use Scalar::Util qw/blessed/;
8	8	use Class::Method::Modifiers;
9		use Package::Stash;
	9	use Package::Stash ();
10	10	use Try::Tiny;
11	11	use namespace::clean; # important: clean all subs imported above this line
12	12

16	16
17	17	=head1 VERSION
18	18
19		Version 0.21
	19	Version 0.22
20	20
21	21	=cut
22	22
23		our $VERSION = '0.21';
	23	our $VERSION = '0.22';
24	24
25	25	=head1 SYNOPSIS
26	26

164	164
165	165	sub set {
166	166	my ( $self, $key, $value, @args ) = @_;
167		my $expires = 0;
	167
	168	my ( $expires, $expire_cmd, $cond_cmd );
168	169	while (my $option = shift @args) {
169		$option = lc $option;
170		# Only set if key exists
171		if ($option eq 'xx') {
172		return unless $self->exists($key);
173
174		# Only set if key doesn't exist
175		} elsif ($option eq 'nx') {
176		return if $self->exists($key);
177
178		# Set expire time (in seconds)
179		} elsif ($option eq 'ex') {
180		my $new_expires = shift @args;
181		if ($new_expires > $expires) {
182		$expires = $new_expires;
183		}
184
185		# Set expire time (in milliseconds)
186		} elsif ($option eq 'px') {
187		my $new_expires = shift @args;
188		$new_expires /= 1000; # To seconds
189		if ($new_expires > $expires) {
190		$expires = $new_expires;
191		}
192		} else {
193		confess '[error] ERR syntax error';
194		}
195		}
	170	$option = lc $option;
	171
	172	if ($option eq 'nx' \|\| $option eq 'xx') { # the same condition can be repeated but mix isn't allowed
	173	confess '[set] ERR syntax error'
	174	if defined $cond_cmd && $cond_cmd ne $option;
	175
	176	$cond_cmd = $option;
	177	} elsif ($option eq 'ex' \|\| $option eq 'px') { # same units can be repeated but mix isn't allowed
	178	confess '[set] ERR syntax error'
	179	if defined $expire_cmd && $expire_cmd ne $option;
	180
	181	$expire_cmd = $option;
	182
	183	$expires = shift @args; # do we need a validation here?
	184
	185	$expires /= 1000 # milliseconds to seconds
	186	if $expire_cmd eq 'px';
	187	} else {
	188	confess '[set] ERR syntax error';
	189	}
	190	}
	191
	192	if ( defined $cond_cmd ) {
	193	# Only set if key exists
	194	return
	195	if $cond_cmd eq 'xx'
	196	&& ! $self->exists($key);
	197
	198	# Only set if key doesn't exist
	199	return
	200	if $cond_cmd eq 'nx'
	201	&& $self->exists($key);
	202	}
	203
196	204	$self->_stash->{$key} = "$value";
197		if ($expires) {
198		$self->expire($key, $expires);
199		}
	205	$self->expire($key, $expires)
	206	if defined $expires;
200	207
201	208	return 'OK';
202	209	}

253	260	sub ttl {
254	261	my ( $self, $key, $ttl ) = @_;
255	262
256		return -1 unless exists $self->_stash->{$key};
	263	return -2 unless exists $self->_stash->{$key};
257	264
258	265	my $slot = $self->_stash;
259	266	my $tied = tied(%$slot);

435	442	}
436	443
437	444	sub rpush {
	445	my ( $self, $key, @values ) = @_;
	446
	447	confess "[rpush] ERR wrong number of arguments for 'rpush' command"
	448	unless @values;
	449
	450	confess "[rpush] WRONGTYPE Operation against a key holding the wrong kind of value"
	451	unless !$self->exists($key) or $self->_is_list($key);
	452
	453	$self->_make_list($key);
	454
	455	push @{ $self->_stash->{$key} }, map "$_", @values;
	456	return scalar @{ $self->_stash->{$key} };
	457	}
	458
	459	sub lpush {
	460	my ( $self, $key, @values ) = @_;
	461
	462	confess "[lpush] ERR wrong number of arguments for 'lpush' command"
	463	unless @values;
	464
	465	confess "[lpush] WRONGTYPE Operation against a key holding the wrong kind of value"
	466	unless !$self->exists($key) or $self->_is_list($key);
	467
	468	$self->_make_list($key);
	469
	470	unshift @{ $self->_stash->{$key} }, map "$_", reverse @values;
	471	return scalar @{ $self->_stash->{$key} };
	472	}
	473
	474	sub rpushx {
438	475	my ( $self, $key, $value ) = @_;
439	476
440		$self->_make_list($key);
	477	return unless $self->_is_list($key);
441	478
442	479	push @{ $self->_stash->{$key} }, "$value";
443	480	return scalar @{ $self->_stash->{$key} };
444	481	}
445	482
446		sub lpush {
	483	sub lpushx {
447	484	my ( $self, $key, $value ) = @_;
448	485
449		confess "[lpush] ERR Operation against a key holding the wrong kind of value"
450		unless !$self->exists($key) or $self->_is_list($key);
451
452		$self->_make_list($key);
	486	return unless $self->_is_list($key);
453	487
454	488	unshift @{ $self->_stash->{$key} }, "$value";
455	489	return scalar @{ $self->_stash->{$key} };
456	490	}
457	491
458		sub rpushx {
459		my ( $self, $key, $value ) = @_;
460
461		return unless $self->_is_list($key);
462
463		push @{ $self->_stash->{$key} }, "$value";
464		return scalar @{ $self->_stash->{$key} };
465		}
466
467		sub lpushx {
468		my ( $self, $key, $value ) = @_;
469
470		return unless $self->_is_list($key);
471
472		unshift @{ $self->_stash->{$key} }, "$value";
473		return scalar @{ $self->_stash->{$key} };
474		}
475
476	492	sub rpoplpush {
477	493	my ( $self, $source_key, $destination_key ) = @_;
478	494

494	510	sub lrange {
495	511	my ( $self, $key, $start, $end ) = @_;
496	512
497		my $array = $self->_stash->{$key};
498		($start,$end) = _normalize_range(scalar(@$array),$start,$end);
499		return @{ $array }[$start..$end];
	513	my @result;
	514
	515	if ( my $array = $self->_stash->{$key} ) {
	516	($start,$end) = _normalize_range(scalar(@$array),$start,$end);
	517	@result = @{ $array }[$start..$end];
	518	}
	519
	520	return wantarray ? @result : \ @result;
500	521	}
501	522
502	523	sub ltrim {

634	655	sub smove {
635	656	my ( $self, $source, $dest, $value ) = @_;
636	657
637		confess "[smove] ERR Operation against a key holding the wrong kind of value"
	658	confess "[smove] WRONGTYPE Operation against a key holding the wrong kind of value"
638	659	if ( $self->exists($source) and not $self->_is_set($source) )
639	660	or ( $self->exists($dest) and not $self->_is_set($dest) );
640	661

723	744	sub hset {
724	745	my ( $self, $key, $hkey, $value ) = @_;
725	746
726		confess '[hset] ERR Operation against a key holding the wrong kind of value'
	747	confess '[hset] WRONGTYPE Operation against a key holding the wrong kind of value'
727	748	if $self->exists($key) and !$self->_is_hash($key);
728	749
729	750

778	799	sub hexists {
779	800	my ( $self, $key, $hkey ) = @_;
780	801
781		confess '[hexists] ERR Operation against a key holding the wrong kind of value'
	802	confess '[hexists] WRONGTYPE Operation against a key holding the wrong kind of value'
782	803	if $self->exists($key) and !$self->_is_hash($key);
783	804
784		return exists $self->_stash->{$key}->{$hkey} ? 1 : 0;
	805	return $self->exists($key) && exists $self->_stash->{$key}->{$hkey} ? 1 : 0;
785	806	}
786	807
787	808	sub hdel {

804	825	if $self->exists($key) and !$self->_is_hash($key);
805	826
806	827	confess "[hincrby] ERR hash value is not an integer"
807		if $self->hexists($key, $hkey) # it exists
808		and $self->hget($key, $hkey) !~ /^-?\d+$\|^$/ # and it doesn't look like an integer (and it isn't empty)
	828	if $self->hexists($key, $hkey) # it exists
	829	and $self->hget($key, $hkey) !~ /^-?\d+$/ # and it doesn't look like an integer (and it isn't empty)
809	830	;
810	831
811	832	$self->_make_hash($key) unless $self->_is_hash($key);

826	847	sub hkeys {
827	848	my ( $self, $key ) = @_;
828	849
829		confess '[hkeys] ERR Operation against a key holding the wrong kind of value'
	850	confess '[hkeys] WRONGTYPE Operation against a key holding the wrong kind of value'
830	851	if $self->exists($key) and !$self->_is_hash($key);
831	852
832	853	return () unless $self->exists($key);

837	858	sub hvals {
838	859	my ( $self, $key ) = @_;
839	860
840		confess '[hvals] ERR Operation against a key holding the wrong kind of value'
	861	confess '[hvals] WRONGTYPE Operation against a key holding the wrong kind of value'
841	862	if $self->exists($key) and !$self->_is_hash($key);
842	863
843	864	return values %{ $self->_stash->{$key} };

846	867	sub hgetall {
847	868	my ( $self, $key ) = @_;
848	869
849		confess "[hgetall] ERR Operation against a key holding the wrong kind of value"
	870	confess "[hgetall] WRONGTYPE Operation against a key holding the wrong kind of value"
850	871	if $self->exists($key) and !$self->_is_hash($key);
851	872
852	873	return $self->exists( $key )

972	993	used_memory_peak => '1055728',
973	994	used_memory_peak_human => '1.01M',
974	995	used_memory_rss => '1699840',
975		map { 'db'.$_ => sprintf('keys=%d,expires=%d',
	996	map { 'db'.$_ => sprintf('keys=%d,expires=%d,avg_ttl=%d',
976	997	scalar keys %{ $self->_stash($_) },
977		$self->_expires_count_for_db($_),
	998	$self->_expires_count_and_avg_ttl_for_db($_),
978	999	)
979	1000	} grep { scalar keys %{ $self->_stash($_) } > 0 }
980	1001	(0..15)
981	1002	};
982	1003	}
983	1004
984		sub _expires_count_for_db {
	1005	sub _expires_count_and_avg_ttl_for_db {
985	1006	my ( $self, $db_index ) = @_;
986	1007
987	1008	my $slot = $self->_stash($db_index);
988	1009	my $tied = tied(%$slot);
989	1010
990		$tied->expire_count;
	1011	$tied->expire_count_and_avg_ttl;
991	1012	}
992	1013
993	1014	sub zadd {

1228	1249
1229	1250	=item * Thomas Bloor
1230	1251
	1252	=item * Valery Kalesnik
	1253
1231	1254	=item * Yaakov Shaul
1232	1255
1233	1256	=back

1341	1364	my %want_list = map { $_ => 1 } @want_list;
1342	1365
1343	1366	sub exec {
1344		my ( $self ) = @_;
	1367	my ( $self, $cb ) = @_;
1345	1368
1346	1369	# we are going to commit all the changes we saved up;
1347	1370	# replay them now and return all their output

1352	1375	delete $self->{_multi_commands};
1353	1376
1354	1377	# replay all the queries that were queued up
	1378	# exec has special behaviour when run in a pipeline:
	1379	# the $reply argument to the pipeline callback is an array ref whose elements are themselves [$reply, $error] pairs.
	1380	if ( $cb && 'CODE' eq ref $cb ) {
	1381	my @reply = map {
	1382	my ( $method, @args ) = @$_;
	1383	try {
	1384	my @result = $self->$method( @args );
	1385	[ $want_list{ $method } ? \ @result : $result[ 0 ],
	1386	undef,
	1387	];
	1388	} catch {
	1389	s/^\[\w+\] //;
	1390	[ undef, $_ ];
	1391	};
	1392	} @commands;
	1393
	1394	$cb->( \ @reply, undef );
	1395
	1396	return 1;
	1397	}
	1398
1355	1399	# the returned result is a nested array of the results of all the commands
1356	1400	my @exceptions;
1357	1401	my @results = map {

1446	1490	psubscribe => 1,
1447	1491	punsubscribe => 1,
1448	1492	wait_all_responses => 1,
	1493	exec => 1, # doc: 'exec has special behaviour when run in a pipeline'. covered in the method
1449	1494	);
1450	1495
1451	1496	my @pipeline_wrapped_methods =

1475	1520	# and "Pipeline management" in the Redis docs
1476	1521	# To make this work, we just need to special-case exec, to collect all the
1477	1522	# results and errors in tuples and send that to the $cb
1478		die 'cannot combine pipelining with MULTI' if $self->{_multi_commands};
	1523	# die 'cannot combine pipelining with MULTI' if $self->{_multi_commands};
1479	1524
1480	1525	# We could also implement this with a queue, not bothering to process
1481	1526	# the commands until wait_all_responses is called - but then we need to

1569	1614	$expires->{$self}->{$key} = $time;
1570	1615	}
1571	1616
1572		sub expire_count {
	1617	sub expire_count_and_avg_ttl {
1573	1618	my ( $self ) = @_;
1574	1619
1575		# really, we should probably only count keys that haven't expired
1576		scalar keys %{ $expires->{$self} };
	1620	my $now = time();
	1621	my $count = 0;
	1622	my $ttl = 0; # looks like actual redis uses more complicated calculations here. let's do something simple to start with
	1623	for my $key ( keys %{ $expires->{$self} } ) {
	1624	if ( $now >= $expires->{$self}->{$key} ) {
	1625	delete $self->{$key};
	1626	delete $expires->{$self}->{$key};
	1627	} else {
	1628	++ $count;
	1629	$ttl += $expires->{$self}->{$key} - $now;
	1630	}
	1631	}
	1632
	1633	$ttl = int( $ttl / $count * 1_000 )
	1634	if $count;
	1635
	1636	( $count, $ttl );
1577	1637	}
1578	1638
1579	1639	sub persist {

-1

t/00-load.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

-3

t/01-basic.t less more

0		#!perl
	0	#!/usr/bin/env perl
1	1	#
2	2	# borrowed from Redis.pm's test suite with permission
3	3	#

8	8	use Test::More;
9	9	use Test::Fatal;
10	10	use Test::Mock::Redis;
	11	use Encode ();
11	12
12	13	ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server');
13	14	my @redi = ($r);

45	46	cmp_ok($o->get('foo'), 'eq', 'baz', 'get foo = baz');
46	47
47	48	my $euro = "\x{20ac}";
48		ok($o->set(utf8 => $euro), 'set utf8');
49		cmp_ok($o->get('utf8'), 'eq', $euro, 'get utf8');
	49	ok($o->set(utf8 => Encode::encode( 'UTF-8', $euro ) ), 'set utf8');
	50	cmp_ok( Encode::decode( 'UTF-8', $o->get('utf8') ), 'eq', $euro, 'get utf8');
50	51
51	52	ok($o->set('test-undef' => 42), 'set test-undef');
52	53	ok($o->exists('test-undef'), 'exists undef');

-2

t/02-new.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;
4	4	use Test::More;
5		use Test::Mock::Redis;
	5	use Test::Mock::Redis ();
6	6
7	7
8	8	my $r = Test::Mock::Redis->new;

-3

t/05-server.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

110	110	like($info->{run_id},qr/^[0-9a-f]{40}/, 'run_id is 40 random hex chars');
111	111
112	112	for(0..14){
113		is($info->{"db$_"}, 'keys=1,expires=0', "db$_ info is correct");
	113	is($info->{"db$_"}, 'keys=1,expires=0,avg_ttl=0', "db$_ info is correct");
114	114	}
115	115	# db15 was left with nothing in it, since it was the last one flushed
116	116	is($info->{"db15"}, undef, 'info returns no data about databases with no keys');

118	118	$r->setex("volitile-key-$_", 15, 'some value') for (1..5);
119	119
120	120
121		is($r->info->{'db0'}, 'keys=6,expires=5', 'db0 info now has six keys and five expire');
	121	like $r->info->{'db0'}, qr/^keys=6,expires=5,avg_ttl=\d+$/,
	122	'db0 info now has six keys and five expires';
122	123
123	124	ok($r->quit, 'quit returns true');
124	125	ok(!$r->quit, 'quit returns false the second time');

-4

t/06-keys.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

66	66
67	67	ok(grep { $_ eq $rand } qw/foo bar baz/, 'random returned one of our keys');
68	68
69		like exception { $r->rename('foo', 'foo') }, qr/^\Q[rename] ERR source and destination objects are the same\E/,
70		'rename with identical source and dest returns false';
	69	# commenting this out as 'Before Redis 3.2.0, an error is returned if source and destination names are the same'
	70	# modern versions don't return an error
	71	# like exception { $r->rename('foo', 'foo') }, qr/^\Q[rename] ERR source and destination objects are the same\E/,
	72	# 'rename with identical source and dest returns false';
71	73
72	74	like exception { $r->rename('quizlebub', 'foo') }, qr/^\Q[rename] ERR no such key\E/,
73	75	"rename with source that doesn't exist returns false";

90	92	is( $r->get('newfoo2'), 'foobar', 'renamenx worked');
91	93
92	94	is($r->ttl('newfoo2'), -1, 'ttl for key with no timeout is -1');
93		is($r->ttl('quizlebub'), -1, "ttl for key that doesn't exist is -1");
	95	is($r->ttl('quizlebub'), -2, "ttl for key that doesn't exist is -2");
94	96
95	97	$r->expire('newfoo2', 3);
96	98	ok($r->ttl('newfoo2') >= 2, 'ttl for newfoo2 is at least 2');

-2

t/07-expires.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Mock::Redis;
	6	use Test::Mock::Redis ();
7	7
8	8	=pod
9	9	x SETEX

+15

-7

t/08-get-set.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use utf8;
3	3	use strict;
4	4	use warnings;
5	5	use lib 't/tlib';
6	6	use Test::More;
	7	use Test::Fatal 'exception';
7	8	use Test::Mock::Redis;
	9	use Encode ();
8	10
9	11	=pod
10	12	x APPEND

77	79	ok($r->set('raboof', 'bar', 'XX', EX => 20), 'Called set with XX and EX');
78	80	is($r->get('raboof'), 'bar', ' - updated key');
79	81	ok($r->ttl('raboof') > 19 && $r->ttl('raboof') <= 20, ' - reset TTL');
80		ok(! defined $r->set('finaltest', 'baz', 'NX', 'XX'), 'Returns nil with NX and XX');
81	82
82		ok($r->set('raboof', 'val', 'EX', 100, 'PX', 10), 'Called set with EX and PX, EX greater');
83		ok($r->ttl('raboof') > 99 && $r->ttl('raboof') <= 100, 'Used EX value');
84		ok($r->set('raboof', 'val', 'PX', 5000, 'EX', 2), 'Called set with EX and PX, PX greater');
85		ok($r->ttl('raboof') > 4 && $r->ttl('raboof') <= 5, 'Used PX value');
	83	like exception { $r->set('finaltest', 'baz', 'NX', 'XX') },
	84	qr/\[set\] ERR syntax error/,
	85	'Combining NX and XX is a syntax error';
	86
	87	like exception { $r->set('raboof', 'val', 'EX', 100, 'PX', 10) },
	88	qr/^\[set\] ERR syntax error/,
	89	'Combining EX and PX is a syntax error';
	90
	91	like exception { $r->set('raboof', 'val', 'EXX') },
	92	qr/^\[set\] ERR syntax error/,
	93	'Using unknown option is a syntax error';
86	94	};
87	95
88	96	ok(! $r->setnx('foo', 'foobar'), 'setnx returns false for existing key');

115	123
116	124	is($r->strlen('append-test'), 9, 'length of append-test key is now 9');
117	125
118		is($r->append('append-test', '€'), 12, 'euro character (multi-byte) only counted by bytes');
	126	is($r->append('append-test', Encode::encode( 'UTF-8', '€') ), 12, 'euro character (multi-byte) only counted by bytes');
119	127
120	128	is($r->getset('foo', 'whee!'), 'foobar', 'getset returned old value of foo');
121	129	is($r->getset('foo', 'foobar'), 'whee!', 'getset returned old value of foo again (so it must have been set)');

+33

-4

t/09-list.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Mock::Redis;
	6	use Test::Mock::Redis ();
7	7
8	8	=pod
9	9	BLPOP

53	53	is $r->llen('list'), 0, "llen returns 0 for a list that doesn't exist";
54	54
55	55	for my $op (qw/lpush rpush/){
56		eval { $r->lpush('foo', 'barfoo') };
57		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";
	56	eval { $r->$op('foo', 'barfoo') };
	57	like $@, qr/^\Q[$op] WRONGTYPE Operation against a key holding the wrong kind of value\E/, "$op against a key that doesn't hold a list died";
	58
	59	eval { $r->$op('foo') };
	60	like $@, qr/^\[$op\] ERR wrong number of arguments for '$op' command/,
	61	"$op without values against a key of wrong kind errors out complaining about values, not wrong kind of the key";
58	62
59	63	ok ! $r->exists("list-$op"), "key 'list-$op' does not exist yet";
60	64	is $r->$op("list-$op", 'foobar'), 1, "$op returns length of list";

65	69	is $r->llen("list-$op"), 3, "llen agrees";
66	70	is $r->$op("list-$op", 'quxqux'), 4, "$op returns length of list";
67	71	is $r->llen("list-$op"), 4, "llen agrees";
	72
	73	eval { $r->$op("list-$op") };
	74	like $@, qr/^\[$op\] ERR wrong number of arguments for '$op' command/,
	75	"$op without values errors out";
	76
	77	is $r->$op( "list-$op", qw/ a b c / ), 7,
	78	"$op can push multiple values at once";
	79
	80	if ( $op eq 'lpush' ) {
	81	is_deeply scalar $r->lrange( "list-$op", 0, 2 ), [ reverse qw/ a b c / ],
	82	"$op has multiple values stored in correct order";
	83	} else {
	84	is_deeply scalar $r->lrange( "list-$op", -3, -1 ), [ qw/ a b c / ],
	85	"$op has multiple values stored in correct order";
	86	}
68	87	}
69	88
70	89	$r->rpush('list', $_) for 0..9;

105	124	is_deeply([$r->lrange(destination => 2, -2)], [qw/x/]);
106	125	is_deeply([$r->lrange(destination => -3, 5)], [qw/c x y/]);
107	126	is_deeply([$r->lrange(destination => 3, 1)], []);
	127	is_deeply([$r->lrange(nonexisting => 0, -1)], []);
	128
	129	# arrayref versions of the above block
	130	is_deeply scalar $r->lrange(destination => 0, 2), [qw/z c x/];
	131	is_deeply scalar $r->lrange(destination => 1, 2), [qw/c x/];
	132	is_deeply scalar $r->lrange(destination => 1, -1), [qw/c x y/];
	133	is_deeply scalar $r->lrange(destination => 2, -2), [qw/x/];
	134	is_deeply scalar $r->lrange(destination => -3, 5), [qw/c x y/];
	135	is_deeply scalar $r->lrange(destination => 3, 1), [];
	136	is_deeply scalar $r->lrange(nonexisting => 0, -1), [];
108	137
109	138	$r->lset(destination => 0, 'a');
110	139	$r->lset(destination => -1, 'f');

+13

-7

t/10-hash.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

37	37	foreach my $r (@redi){
38	38	diag("testing $r") if $ENV{RELEASE_TESTING};
39	39
	40	ok ! $r->hexists('hash', 'foo'), "hexists on an empty hash returns false";
	41
	42	ok ! $r->hexists('hash', 'foo'), "hexists on the same empty hash returns false proving there was no autovivification";
	43
40	44	is $r->hget('hash', 'foo'), undef, "hget for a hash that doesn't exist is undef";
41	45
42	46	is_deeply([sort $r->hkeys('hash')], [], "hkeys returned no keys for a hash that doesn't exist");

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

94	98	$r->set('not a hash', 'foo bar');
95	99
96	100	like exception { $r->hkeys('not a hash') },
97		qr/^\Q[hkeys] ERR Operation against a key holding the wrong kind of value\E/,
	101	qr/^\Q[hkeys] WRONGTYPE Operation against a key holding the wrong kind of value\E/,
98	102	"hkeys on key that isn't a hash throws error";
99	103
100	104	# OK seems inconsistient

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

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

146	150
147	151	is $r->hset('hash', 'emptystr', ''), 1, "can set hash value to empty string";
148	152
149		is $r->hincrby('hash', 'emptystr', 1), 1, "incrby 1 on the empty string returns 1";
	153	like exception { $r->hincrby('hash', 'emptystr', 1) },
	154	qr/^\Q[hincrby] ERR hash value is not an integer\E/,
	155	"hincrby dies when an empty string is incremented";
150	156	}
151	157
152	158

-3

t/11-sets.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

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

-2

t/12-sorted-sets.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;
4	4	use Test::More;
5		use Test::Mock::Redis;
	5	use Test::Mock::Redis ();
6	6
7	7	=pod
8	8	ZADD

-1

t/13-multi.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1	2	use warnings FATAL => 'all';
2	3

126	127
127	128	like(
128	129	exception { $redis->exec },
129		qr/^\[exec\] ERR Operation against a key holding the wrong kind of value/,
	130	qr/^\Q[exec] WRONGTYPE Operation against a key holding the wrong kind of value\E/,
130	131	'a bad transaction results in an exception',
131	132	);
132	133

-3

t/14-pipeline.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1	2	use warnings FATAL => 'all';
2	3
3	4	use Test::More 0.88;
4	5	use Test::Deep;
5		use Test::Fatal;
	6	use Test::Fatal 'exception';
6	7	use Test::Deep::UnorderedPairs;
7		use Test::Mock::Redis;
	8	use Test::Mock::Redis ();
8	9
9	10	use lib 't/tlib';
10	11

70	71	$redis->hset(
71	72	'pipeline_key_2', 'bar', '9',
72	73	# 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	sub { cmp_deeply(\@_, [ undef, re(qr/^(\[hset\] )?WRONGTYPE Operation against a key holding the wrong kind of value/) ], 'hset callback') },
74	75	),
75	76	'1',
76	77	'hset operation sent',

-3

t/15-import.t less more

0		#!perl
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;
4	4	use Test::More;
5		use Test::Fatal;
	5	use Test::Fatal 'exception';
6	6	use Test::Deep;
7		use Test::Mock::Redis;
	7	use Test::Mock::Redis ();
8	8
9	9	#
10	10	# first demonstrate failure

-3

t/50-lrem.t less more

0		#!perl
	0	#!/usr/bin/env perl
1	1
2	2	use warnings;
3	3	use strict;
4	4	use lib 't/tlib';
5	5	use Test::More;
6		use Test::Fatal;
7		use Test::Mock::Redis;
	6	use Test::Mock::Redis ();
8	7
9	8	ok(my $r = Test::Mock::Redis->new, 'pretended to connect to our test redis-server');
10	9	my @redi = ($r);

-1

t/boilerplate.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

-1

t/manifest.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;

-1

t/pod.t less more

0		#!perl -T
	0	#!/usr/bin/env perl
1	1
2	2	use strict;
3	3	use warnings;