summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorbyte2016 <[email protected]>2018-06-12 19:55:38 +0800
committerbyte2016 <[email protected]>2018-06-12 19:55:38 +0800
commit76f2c13d7c27d7419af79ea0bdc7ab7717b6935b (patch)
treeaa2ca741501d40990b892d504a1cc3b7defe57aa /tests
Init commit.HEADmaster
Diffstat (limited to 'tests')
-rw-r--r--tests/assets/default.conf27
-rw-r--r--tests/assets/encodings.rdbbin0 -> 667 bytes
-rw-r--r--tests/assets/hash-zipmap.rdbbin0 -> 35 bytes
-rw-r--r--tests/cluster/cluster.tcl130
-rw-r--r--tests/cluster/run.tcl28
-rw-r--r--tests/cluster/tests/00-base.tcl59
-rw-r--r--tests/cluster/tests/01-faildet.tcl38
-rw-r--r--tests/cluster/tests/02-failover.tcl65
-rw-r--r--tests/cluster/tests/03-failover-loop.tcl115
-rw-r--r--tests/cluster/tests/04-resharding.tcl172
-rw-r--r--tests/cluster/tests/05-slave-selection.tcl94
-rw-r--r--tests/cluster/tests/06-slave-stop-cond.tcl73
-rw-r--r--tests/cluster/tests/07-replica-migration.tcl103
-rw-r--r--tests/cluster/tests/08-update-msg.tcl90
-rw-r--r--tests/cluster/tests/09-pubsub.tcl40
-rw-r--r--tests/cluster/tests/10-manual-failover.tcl192
-rw-r--r--tests/cluster/tests/11-manual-takeover.tcl59
-rw-r--r--tests/cluster/tests/12-replica-migration-2.tcl64
-rw-r--r--tests/cluster/tests/helpers/onlydots.tcl16
-rw-r--r--tests/cluster/tests/includes/init-tests.tcl70
-rw-r--r--tests/cluster/tmp/.gitignore2
-rw-r--r--tests/helpers/bg_complex_data.tcl10
-rw-r--r--tests/helpers/gen_write_load.tcl15
-rw-r--r--tests/instances.tcl511
-rw-r--r--tests/integration/aof-race.tcl35
-rw-r--r--tests/integration/aof.tcl260
-rw-r--r--tests/integration/convert-zipmap-hash-on-load.tcl35
-rw-r--r--tests/integration/logging.tcl24
-rw-r--r--tests/integration/psync2.tcl182
-rw-r--r--tests/integration/rdb.tcl98
-rw-r--r--tests/integration/redis-cli.tcl208
-rw-r--r--tests/integration/replication-2.tcl87
-rw-r--r--tests/integration/replication-3.tcl113
-rw-r--r--tests/integration/replication-4.tcl155
-rw-r--r--tests/integration/replication-psync.tcl128
-rw-r--r--tests/integration/replication.tcl268
-rw-r--r--tests/sentinel/run.tcl23
-rw-r--r--tests/sentinel/tests/00-base.tcl126
-rw-r--r--tests/sentinel/tests/01-conf-update.tcl39
-rw-r--r--tests/sentinel/tests/02-slaves-reconf.tcl84
-rw-r--r--tests/sentinel/tests/03-runtime-reconf.tcl1
-rw-r--r--tests/sentinel/tests/04-slave-selection.tcl5
-rw-r--r--tests/sentinel/tests/05-manual.tcl45
-rw-r--r--tests/sentinel/tests/06-ckquorum.tcl34
-rw-r--r--tests/sentinel/tests/07-down-conditions.tcl68
-rw-r--r--tests/sentinel/tests/includes/init-tests.tcl72
-rw-r--r--tests/sentinel/tmp/.gitignore2
-rw-r--r--tests/support/cluster.tcl307
-rw-r--r--tests/support/redis.tcl294
-rw-r--r--tests/support/server.tcl329
-rw-r--r--tests/support/test.tcl127
-rw-r--r--tests/support/tmpfile.tcl15
-rw-r--r--tests/support/util.tcl377
-rw-r--r--tests/test_helper.tcl563
-rw-r--r--tests/unit/aofrw.tcl213
-rw-r--r--tests/unit/auth.tcl27
-rw-r--r--tests/unit/bitfield.tcl201
-rw-r--r--tests/unit/bitops.tcl351
-rw-r--r--tests/unit/dump.tcl311
-rw-r--r--tests/unit/expire.tcl207
-rw-r--r--tests/unit/geo.tcl308
-rw-r--r--tests/unit/hyperloglog.tcl185
-rw-r--r--tests/unit/introspection-2.tcl23
-rw-r--r--tests/unit/introspection.tcl60
-rw-r--r--tests/unit/keyspace.tcl275
-rw-r--r--tests/unit/latency-monitor.tcl50
-rw-r--r--tests/unit/lazyfree.tcl39
-rw-r--r--tests/unit/limits.tcl16
-rw-r--r--tests/unit/maxmemory.tcl144
-rw-r--r--tests/unit/memefficiency.tcl37
-rw-r--r--tests/unit/multi.tcl309
-rw-r--r--tests/unit/obuf-limits.tcl73
-rw-r--r--tests/unit/other.tcl246
-rw-r--r--tests/unit/printver.tcl6
-rw-r--r--tests/unit/protocol.tcl117
-rw-r--r--tests/unit/pubsub.tcl390
-rw-r--r--tests/unit/quit.tcl40
-rw-r--r--tests/unit/scan.tcl239
-rw-r--r--tests/unit/scripting.tcl735
-rw-r--r--tests/unit/slowlog.tcl70
-rw-r--r--tests/unit/sort.tcl318
-rw-r--r--tests/unit/type/hash.tcl536
-rw-r--r--tests/unit/type/incr.tcl147
-rw-r--r--tests/unit/type/list-2.tcl47
-rw-r--r--tests/unit/type/list-3.tcl122
-rw-r--r--tests/unit/type/list-common.tcl5
-rw-r--r--tests/unit/type/list.tcl837
-rw-r--r--tests/unit/type/set.tcl601
-rw-r--r--tests/unit/type/string.tcl422
-rw-r--r--tests/unit/type/zset.tcl1030
-rw-r--r--tests/unit/wait.tcl42
91 files changed, 14856 insertions, 0 deletions
diff --git a/tests/assets/default.conf b/tests/assets/default.conf
new file mode 100644
index 0000000..d7b8a75
--- /dev/null
+++ b/tests/assets/default.conf
@@ -0,0 +1,27 @@
+# Redis configuration for testing.
+
+always-show-logo yes
+notify-keyspace-events KEA
+daemonize no
+pidfile /var/run/redis.pid
+port 6379
+timeout 0
+bind 127.0.0.1
+loglevel verbose
+logfile ''
+databases 16
+latency-monitor-threshold 1
+
+save 900 1
+save 300 10
+save 60 10000
+
+rdbcompression yes
+dbfilename dump.rdb
+dir ./
+
+slave-serve-stale-data yes
+appendonly no
+appendfsync everysec
+no-appendfsync-on-rewrite no
+activerehashing yes
diff --git a/tests/assets/encodings.rdb b/tests/assets/encodings.rdb
new file mode 100644
index 0000000..9fd9b70
--- /dev/null
+++ b/tests/assets/encodings.rdb
Binary files differ
diff --git a/tests/assets/hash-zipmap.rdb b/tests/assets/hash-zipmap.rdb
new file mode 100644
index 0000000..27a42ed
--- /dev/null
+++ b/tests/assets/hash-zipmap.rdb
Binary files differ
diff --git a/tests/cluster/cluster.tcl b/tests/cluster/cluster.tcl
new file mode 100644
index 0000000..0647914
--- /dev/null
+++ b/tests/cluster/cluster.tcl
@@ -0,0 +1,130 @@
+# Cluster-specific test functions.
+#
+# Copyright (C) 2014 Salvatore Sanfilippo [email protected]
+# This software is released under the BSD License. See the COPYING file for
+# more information.
+
+# Returns a parsed CLUSTER NODES output as a list of dictionaries.
+proc get_cluster_nodes id {
+ set lines [split [R $id cluster nodes] "\r\n"]
+ set nodes {}
+ foreach l $lines {
+ set l [string trim $l]
+ if {$l eq {}} continue
+ set args [split $l]
+ set node [dict create \
+ id [lindex $args 0] \
+ addr [lindex $args 1] \
+ flags [split [lindex $args 2] ,] \
+ slaveof [lindex $args 3] \
+ ping_sent [lindex $args 4] \
+ pong_recv [lindex $args 5] \
+ config_epoch [lindex $args 6] \
+ linkstate [lindex $args 7] \
+ slots [lrange $args 8 -1] \
+ ]
+ lappend nodes $node
+ }
+ return $nodes
+}
+
+# Test node for flag.
+proc has_flag {node flag} {
+ expr {[lsearch -exact [dict get $node flags] $flag] != -1}
+}
+
+# Returns the parsed myself node entry as a dictionary.
+proc get_myself id {
+ set nodes [get_cluster_nodes $id]
+ foreach n $nodes {
+ if {[has_flag $n myself]} {return $n}
+ }
+ return {}
+}
+
+# Return the value of the specified CLUSTER INFO field.
+proc CI {n field} {
+ get_info_field [R $n cluster info] $field
+}
+
+# Assuming nodes are reest, this function performs slots allocation.
+# Only the first 'n' nodes are used.
+proc cluster_allocate_slots {n} {
+ set slot 16383
+ while {$slot >= 0} {
+ # Allocate successive slots to random nodes.
+ set node [randomInt $n]
+ lappend slots_$node $slot
+ incr slot -1
+ }
+ for {set j 0} {$j < $n} {incr j} {
+ R $j cluster addslots {*}[set slots_${j}]
+ }
+}
+
+# Check that cluster nodes agree about "state", or raise an error.
+proc assert_cluster_state {state} {
+ foreach_redis_id id {
+ if {[instance_is_killed redis $id]} continue
+ wait_for_condition 1000 50 {
+ [CI $id cluster_state] eq $state
+ } else {
+ fail "Cluster node $id cluster_state:[CI $id cluster_state]"
+ }
+ }
+}
+
+# Search the first node starting from ID $first that is not
+# already configured as a slave.
+proc cluster_find_available_slave {first} {
+ foreach_redis_id id {
+ if {$id < $first} continue
+ if {[instance_is_killed redis $id]} continue
+ set me [get_myself $id]
+ if {[dict get $me slaveof] eq {-}} {return $id}
+ }
+ fail "No available slaves"
+}
+
+# Add 'slaves' slaves to a cluster composed of 'masters' masters.
+# It assumes that masters are allocated sequentially from instance ID 0
+# to N-1.
+proc cluster_allocate_slaves {masters slaves} {
+ for {set j 0} {$j < $slaves} {incr j} {
+ set master_id [expr {$j % $masters}]
+ set slave_id [cluster_find_available_slave $masters]
+ set master_myself [get_myself $master_id]
+ R $slave_id cluster replicate [dict get $master_myself id]
+ }
+}
+
+# Create a cluster composed of the specified number of masters and slaves.
+proc create_cluster {masters slaves} {
+ cluster_allocate_slots $masters
+ if {$slaves} {
+ cluster_allocate_slaves $masters $slaves
+ }
+ assert_cluster_state ok
+}
+
+# Set the cluster node-timeout to all the reachalbe nodes.
+proc set_cluster_node_timeout {to} {
+ foreach_redis_id id {
+ catch {R $id CONFIG SET cluster-node-timeout $to}
+ }
+}
+
+# Check if the cluster is writable and readable. Use node "id"
+# as a starting point to talk with the cluster.
+proc cluster_write_test {id} {
+ set prefix [randstring 20 20 alpha]
+ set port [get_instance_attrib redis $id port]
+ set cluster [redis_cluster 127.0.0.1:$port]
+ for {set j 0} {$j < 100} {incr j} {
+ $cluster set key.$j $prefix.$j
+ }
+ for {set j 0} {$j < 100} {incr j} {
+ assert {[$cluster get key.$j] eq "$prefix.$j"}
+ }
+ $cluster close
+}
diff --git a/tests/cluster/run.tcl b/tests/cluster/run.tcl
new file mode 100644
index 0000000..93603dd
--- /dev/null
+++ b/tests/cluster/run.tcl
@@ -0,0 +1,28 @@
+# Cluster test suite. Copyright (C) 2014 Salvatore Sanfilippo [email protected]
+# This software is released under the BSD License. See the COPYING file for
+# more information.
+
+cd tests/cluster
+source cluster.tcl
+source ../instances.tcl
+source ../../support/cluster.tcl ; # Redis Cluster client.
+
+set ::instances_count 20 ; # How many instances we use at max.
+
+proc main {} {
+ parse_options
+ spawn_instance redis $::redis_base_port $::instances_count {
+ "cluster-enabled yes"
+ "appendonly yes"
+ }
+ run_tests
+ cleanup
+ end_tests
+}
+
+if {[catch main e]} {
+ puts $::errorInfo
+ if {$::pause_on_error} pause_on_error
+ cleanup
+ exit 1
+}
diff --git a/tests/cluster/tests/00-base.tcl b/tests/cluster/tests/00-base.tcl
new file mode 100644
index 0000000..280befb
--- /dev/null
+++ b/tests/cluster/tests/00-base.tcl
@@ -0,0 +1,59 @@
+# Check the basic monitoring and failover capabilities.
+
+source "../tests/includes/init-tests.tcl"
+
+if {$::simulate_error} {
+ test "This test will fail" {
+ fail "Simulated error"
+ }
+}
+
+test "Different nodes have different IDs" {
+ set ids {}
+ set numnodes 0
+ foreach_redis_id id {
+ incr numnodes
+ # Every node should just know itself.
+ set nodeid [dict get [get_myself $id] id]
+ assert {$nodeid ne {}}
+ lappend ids $nodeid
+ }
+ set numids [llength [lsort -unique $ids]]
+ assert {$numids == $numnodes}
+}
+
+test "It is possible to perform slot allocation" {
+ cluster_allocate_slots 5
+}
+
+test "After the join, every node gets a different config epoch" {
+ set trynum 60
+ while {[incr trynum -1] != 0} {
+ # We check that this condition is true for *all* the nodes.
+ set ok 1 ; # Will be set to 0 every time a node is not ok.
+ foreach_redis_id id {
+ set epochs {}
+ foreach n [get_cluster_nodes $id] {
+ lappend epochs [dict get $n config_epoch]
+ }
+ if {[lsort $epochs] != [lsort -unique $epochs]} {
+ set ok 0 ; # At least one collision!
+ }
+ }
+ if {$ok} break
+ after 1000
+ puts -nonewline .
+ flush stdout
+ }
+ if {$trynum == 0} {
+ fail "Config epoch conflict resolution is not working."
+ }
+}
+
+test "Nodes should report cluster_state is ok now" {
+ assert_cluster_state ok
+}
+
+test "It is possible to write and read from the cluster" {
+ cluster_write_test 0
+}
diff --git a/tests/cluster/tests/01-faildet.tcl b/tests/cluster/tests/01-faildet.tcl
new file mode 100644
index 0000000..8fe87c9
--- /dev/null
+++ b/tests/cluster/tests/01-faildet.tcl
@@ -0,0 +1,38 @@
+# Check the basic monitoring and failover capabilities.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster should start ok" {
+ assert_cluster_state ok
+}
+
+test "Killing two slave nodes" {
+ kill_instance redis 5
+ kill_instance redis 6
+}
+
+test "Cluster should be still up" {
+ assert_cluster_state ok
+}
+
+test "Killing one master node" {
+ kill_instance redis 0
+}
+
+# Note: the only slave of instance 0 is already down so no
+# failover is possible, that would change the state back to ok.
+test "Cluster should be down now" {
+ assert_cluster_state fail
+}
+
+test "Restarting master node" {
+ restart_instance redis 0
+}
+
+test "Cluster should be up again" {
+ assert_cluster_state ok
+}
diff --git a/tests/cluster/tests/02-failover.tcl b/tests/cluster/tests/02-failover.tcl
new file mode 100644
index 0000000..6b2fd09
--- /dev/null
+++ b/tests/cluster/tests/02-failover.tcl
@@ -0,0 +1,65 @@
+# Check the basic monitoring and failover capabilities.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Instance #5 is a slave" {
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+set current_epoch [CI 1 cluster_current_epoch]
+
+test "Killing one master node" {
+ kill_instance redis 0
+}
+
+test "Wait for failover" {
+ wait_for_condition 1000 50 {
+ [CI 1 cluster_current_epoch] > $current_epoch
+ } else {
+ fail "No failover detected"
+ }
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 1
+}
+
+test "Instance #5 is now a master" {
+ assert {[RI 5 role] eq {master}}
+}
+
+test "Restarting the previously killed master node" {
+ restart_instance redis 0
+}
+
+test "Instance #0 gets converted into a slave" {
+ wait_for_condition 1000 50 {
+ [RI 0 role] eq {slave}
+ } else {
+ fail "Old master was not converted into slave"
+ }
+}
diff --git a/tests/cluster/tests/03-failover-loop.tcl b/tests/cluster/tests/03-failover-loop.tcl
new file mode 100644
index 0000000..8e1bcd6
--- /dev/null
+++ b/tests/cluster/tests/03-failover-loop.tcl
@@ -0,0 +1,115 @@
+# Failover stress test.
+# In this test a different node is killed in a loop for N
+# iterations. The test checks that certain properties
+# are preseved across iterations.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+set iterations 20
+set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
+
+while {[incr iterations -1]} {
+ set tokill [randomInt 10]
+ set other [expr {($tokill+1)%10}] ; # Some other instance.
+ set key [randstring 20 20 alpha]
+ set val [randstring 20 20 alpha]
+ set role [RI $tokill role]
+ if {$role eq {master}} {
+ set slave {}
+ set myid [dict get [get_myself $tokill] id]
+ foreach_redis_id id {
+ if {$id == $tokill} continue
+ if {[dict get [get_myself $id] slaveof] eq $myid} {
+ set slave $id
+ }
+ }
+ if {$slave eq {}} {
+ fail "Unable to retrieve slave's ID for master #$tokill"
+ }
+ }
+
+ puts "--- Iteration $iterations ---"
+
+ if {$role eq {master}} {
+ test "Wait for slave of #$tokill to sync" {
+ wait_for_condition 1000 50 {
+ [string match {*state=online*} [RI $tokill slave0]]
+ } else {
+ fail "Slave of node #$tokill is not ok"
+ }
+ }
+ set slave_config_epoch [CI $slave cluster_my_epoch]
+ }
+
+ test "Cluster is writable before failover" {
+ for {set i 0} {$i < 100} {incr i} {
+ catch {$cluster set $key:$i $val:$i} err
+ assert {$err eq {OK}}
+ }
+ # Wait for the write to propagate to the slave if we
+ # are going to kill a master.
+ if {$role eq {master}} {
+ R $tokill wait 1 20000
+ }
+ }
+
+ test "Killing node #$tokill" {
+ kill_instance redis $tokill
+ }
+
+ if {$role eq {master}} {
+ test "Wait failover by #$slave with old epoch $slave_config_epoch" {
+ wait_for_condition 1000 50 {
+ [CI $slave cluster_my_epoch] > $slave_config_epoch
+ } else {
+ fail "No failover detected, epoch is still [CI $slave cluster_my_epoch]"
+ }
+ }
+ }
+
+ test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+ }
+
+ test "Cluster is writable again" {
+ for {set i 0} {$i < 100} {incr i} {
+ catch {$cluster set $key:$i:2 $val:$i:2} err
+ assert {$err eq {OK}}
+ }
+ }
+
+ test "Restarting node #$tokill" {
+ restart_instance redis $tokill
+ }
+
+ test "Instance #$tokill is now a slave" {
+ wait_for_condition 1000 50 {
+ [RI $tokill role] eq {slave}
+ } else {
+ fail "Restarted instance is not a slave"
+ }
+ }
+
+ test "We can read back the value we set before" {
+ for {set i 0} {$i < 100} {incr i} {
+ catch {$cluster get $key:$i} err
+ assert {$err eq "$val:$i"}
+ catch {$cluster get $key:$i:2} err
+ assert {$err eq "$val:$i:2"}
+ }
+ }
+}
+
+test "Post condition: current_epoch >= my_epoch everywhere" {
+ foreach_redis_id id {
+ assert {[CI $id cluster_current_epoch] >= [CI $id cluster_my_epoch]}
+ }
+}
diff --git a/tests/cluster/tests/04-resharding.tcl b/tests/cluster/tests/04-resharding.tcl
new file mode 100644
index 0000000..0ccbf71
--- /dev/null
+++ b/tests/cluster/tests/04-resharding.tcl
@@ -0,0 +1,172 @@
+# Failover stress test.
+# In this test a different node is killed in a loop for N
+# iterations. The test checks that certain properties
+# are preseved across iterations.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Enable AOF in all the instances" {
+ foreach_redis_id id {
+ R $id config set appendonly yes
+ # We use "appendfsync no" because it's fast but also guarantees that
+ # write(2) is performed before replying to client.
+ R $id config set appendfsync no
+ }
+
+ foreach_redis_id id {
+ wait_for_condition 1000 500 {
+ [RI $id aof_rewrite_in_progress] == 0 &&
+ [RI $id aof_enabled] == 1
+ } else {
+ fail "Failed to enable AOF on instance #$id"
+ }
+ }
+}
+
+# Return nno-zero if the specified PID is about a process still in execution,
+# otherwise 0 is returned.
+proc process_is_running {pid} {
+ # PS should return with an error if PID is non existing,
+ # and catch will return non-zero. We want to return non-zero if
+ # the PID exists, so we invert the return value with expr not operator.
+ expr {![catch {exec ps -p $pid}]}
+}
+
+# Our resharding test performs the following actions:
+#
+# - N commands are sent to the cluster in the course of the test.
+# - Every command selects a random key from key:0 to key:MAX-1.
+# - The operation RPUSH key <randomvalue> is perforemd.
+# - Tcl remembers into an array all the values pushed to each list.
+# - After N/2 commands, the resharding process is started in background.
+# - The test continues while the resharding is in progress.
+# - At the end of the test, we wait for the resharding process to stop.
+# - Finally the keys are checked to see if they contain the value they should.
+
+set numkeys 50000
+set numops 200000
+set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
+catch {unset content}
+array set content {}
+set tribpid {}
+
+test "Cluster consistency during live resharding" {
+ set ele 0
+ for {set j 0} {$j < $numops} {incr j} {
+ # Trigger the resharding once we execute half the ops.
+ if {$tribpid ne {} &&
+ ($j % 10000) == 0 &&
+ ![process_is_running $tribpid]} {
+ set tribpid {}
+ }
+
+ if {$j >= $numops/2 && $tribpid eq {}} {
+ puts -nonewline "...Starting resharding..."
+ flush stdout
+ set target [dict get [get_myself [randomInt 5]] id]
+ set tribpid [lindex [exec \
+ ../../../src/redis-trib.rb reshard \
+ --from all \
+ --to $target \
+ --slots 100 \
+ --yes \
+ 127.0.0.1:[get_instance_attrib redis 0 port] \
+ | [info nameofexecutable] \
+ ../tests/helpers/onlydots.tcl \
+ &] 0]
+ }
+
+ # Write random data to random list.
+ set listid [randomInt $numkeys]
+ set key "key:$listid"
+ incr ele
+ # We write both with Lua scripts and with plain commands.
+ # This way we are able to stress Lua -> Redis command invocation
+ # as well, that has tests to prevent Lua to write into wrong
+ # hash slots.
+ if {$listid % 2} {
+ $cluster rpush $key $ele
+ } else {
+ $cluster eval {redis.call("rpush",KEYS[1],ARGV[1])} 1 $key $ele
+ }
+ lappend content($key) $ele
+
+ if {($j % 1000) == 0} {
+ puts -nonewline W; flush stdout
+ }
+ }
+
+ # Wait for the resharding process to end
+ wait_for_condition 1000 500 {
+ [process_is_running $tribpid] == 0
+ } else {
+ fail "Resharding is not terminating after some time."
+ }
+
+}
+
+test "Verify $numkeys keys for consistency with logical content" {
+ # Check that the Redis Cluster content matches our logical content.
+ foreach {key value} [array get content] {
+ if {[$cluster lrange $key 0 -1] ne $value} {
+ fail "Key $key expected to hold '$value' but actual content is [$cluster lrange $key 0 -1]"
+ }
+ }
+}
+
+test "Crash and restart all the instances" {
+ foreach_redis_id id {
+ kill_instance redis $id
+ restart_instance redis $id
+ }
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Verify $numkeys keys after the crash & restart" {
+ # Check that the Redis Cluster content matches our logical content.
+ foreach {key value} [array get content] {
+ if {[$cluster lrange $key 0 -1] ne $value} {
+ fail "Key $key expected to hold '$value' but actual content is [$cluster lrange $key 0 -1]"
+ }
+ }
+}
+
+test "Disable AOF in all the instances" {
+ foreach_redis_id id {
+ R $id config set appendonly no
+ }
+}
+
+test "Verify slaves consistency" {
+ set verified_masters 0
+ foreach_redis_id id {
+ set role [R $id role]
+ lassign $role myrole myoffset slaves
+ if {$myrole eq {slave}} continue
+ set masterport [get_instance_attrib redis $id port]
+ set masterdigest [R $id debug digest]
+ foreach_redis_id sid {
+ set srole [R $sid role]
+ if {[lindex $srole 0] eq {master}} continue
+ if {[lindex $srole 2] != $masterport} continue
+ wait_for_condition 1000 500 {
+ [R $sid debug digest] eq $masterdigest
+ } else {
+ fail "Master and slave data digest are different"
+ }
+ incr verified_masters
+ }
+ }
+ assert {$verified_masters >= 5}
+}
diff --git a/tests/cluster/tests/05-slave-selection.tcl b/tests/cluster/tests/05-slave-selection.tcl
new file mode 100644
index 0000000..6efedce
--- /dev/null
+++ b/tests/cluster/tests/05-slave-selection.tcl
@@ -0,0 +1,94 @@
+# Slave selection test
+# Check the algorithm trying to pick the slave with the most complete history.
+
+source "../tests/includes/init-tests.tcl"
+
+# Create a cluster with 5 master and 10 slaves, so that we have 2
+# slaves for each master.
+test "Create a 5 nodes cluster" {
+ create_cluster 5 10
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "The first master has actually two slaves" {
+ assert {[llength [lindex [R 0 role] 2]] == 2}
+}
+
+test {Slaves of #0 are instance #5 and #10 as expected} {
+ set port0 [get_instance_attrib redis 0 port]
+ assert {[lindex [R 5 role] 2] == $port0}
+ assert {[lindex [R 10 role] 2] == $port0}
+}
+
+test "Instance #5 and #10 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up} &&
+ [RI 10 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 or #10 master link status is not up"
+ }
+}
+
+set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
+
+test "Slaves are both able to receive and acknowledge writes" {
+ for {set j 0} {$j < 100} {incr j} {
+ $cluster set $j $j
+ }
+ assert {[R 0 wait 2 60000] == 2}
+}
+
+test "Write data while slave #10 is paused and can't receive it" {
+ # Stop the slave with a multi/exec transaction so that the master will
+ # be killed as soon as it can accept writes again.
+ R 10 multi
+ R 10 debug sleep 10
+ R 10 client kill 127.0.0.1:$port0
+ R 10 deferred 1
+ R 10 exec
+
+ # Write some data the slave can't receive.
+ for {set j 0} {$j < 100} {incr j} {
+ $cluster set $j $j
+ }
+
+ # Prevent the master from accepting new slaves.
+ # Use a large pause value since we'll kill it anyway.
+ R 0 CLIENT PAUSE 60000
+
+ # Wait for the slave to return available again
+ R 10 deferred 0
+ assert {[R 10 read] eq {OK OK}}
+
+ # Kill the master so that a reconnection will not be possible.
+ kill_instance redis 0
+}
+
+test "Wait for instance #5 (and not #10) to turn into a master" {
+ wait_for_condition 1000 50 {
+ [RI 5 role] eq {master}
+ } else {
+ fail "No failover detected"
+ }
+}
+
+test "Wait for the node #10 to return alive before ending the test" {
+ R 10 ping
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Node #10 should eventually replicate node #5" {
+ set port5 [get_instance_attrib redis 5 port]
+ wait_for_condition 1000 50 {
+ ([lindex [R 10 role] 2] == $port5) &&
+ ([lindex [R 10 role] 3] eq {connected})
+ } else {
+ fail "#10 didn't became slave of #5"
+ }
+}
diff --git a/tests/cluster/tests/06-slave-stop-cond.tcl b/tests/cluster/tests/06-slave-stop-cond.tcl
new file mode 100644
index 0000000..f2e6705
--- /dev/null
+++ b/tests/cluster/tests/06-slave-stop-cond.tcl
@@ -0,0 +1,73 @@
+# Slave stop condition test
+# Check that if there is a disconnection time limit, the slave will not try
+# to failover its master.
+
+source "../tests/includes/init-tests.tcl"
+
+# Create a cluster with 5 master and 5 slaves.
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "The first master has actually one slave" {
+ assert {[llength [lindex [R 0 role] 2]] == 1}
+}
+
+test {Slaves of #0 is instance #5 as expected} {
+ set port0 [get_instance_attrib redis 0 port]
+ assert {[lindex [R 5 role] 2] == $port0}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+test "Lower the slave validity factor of #5 to the value of 2" {
+ assert {[R 5 config set cluster-slave-validity-factor 2] eq {OK}}
+}
+
+test "Break master-slave link and prevent further reconnections" {
+ # Stop the slave with a multi/exec transaction so that the master will
+ # be killed as soon as it can accept writes again.
+ R 5 multi
+ R 5 client kill 127.0.0.1:$port0
+ # here we should sleep 6 or more seconds (node_timeout * slave_validity)
+ # but the actual validity time is actually incremented by the
+ # repl-ping-slave-period value which is 10 seconds by default. So we
+ # need to wait more than 16 seconds.
+ R 5 debug sleep 20
+ R 5 deferred 1
+ R 5 exec
+
+ # Prevent the master from accepting new slaves.
+ # Use a large pause value since we'll kill it anyway.
+ R 0 CLIENT PAUSE 60000
+
+ # Wait for the slave to return available again
+ R 5 deferred 0
+ assert {[R 5 read] eq {OK OK}}
+
+ # Kill the master so that a reconnection will not be possible.
+ kill_instance redis 0
+}
+
+test "Slave #5 is reachable and alive" {
+ assert {[R 5 ping] eq {PONG}}
+}
+
+test "Slave #5 should not be able to failover" {
+ after 10000
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Cluster should be down" {
+ assert_cluster_state fail
+}
diff --git a/tests/cluster/tests/07-replica-migration.tcl b/tests/cluster/tests/07-replica-migration.tcl
new file mode 100644
index 0000000..68231cd
--- /dev/null
+++ b/tests/cluster/tests/07-replica-migration.tcl
@@ -0,0 +1,103 @@
+# Replica migration test.
+# Check that orphaned masters are joined by replicas of masters having
+# multiple replicas attached, according to the migration barrier settings.
+
+source "../tests/includes/init-tests.tcl"
+
+# Create a cluster with 5 master and 10 slaves, so that we have 2
+# slaves for each master.
+test "Create a 5 nodes cluster" {
+ create_cluster 5 10
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Each master should have two replicas attached" {
+ foreach_redis_id id {
+ if {$id < 5} {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R 0 role] 2]] == 2
+ } else {
+ fail "Master #$id does not have 2 slaves as expected"
+ }
+ }
+ }
+}
+
+test "Killing all the slaves of master #0 and #1" {
+ kill_instance redis 5
+ kill_instance redis 10
+ kill_instance redis 6
+ kill_instance redis 11
+ after 4000
+}
+
+foreach_redis_id id {
+ if {$id < 5} {
+ test "Master #$id should have at least one replica" {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R $id role] 2]] >= 1
+ } else {
+ fail "Master #$id has no replicas"
+ }
+ }
+ }
+}
+
+# Now test the migration to a master which used to be a slave, after
+# a failver.
+
+source "../tests/includes/init-tests.tcl"
+
+# Create a cluster with 5 master and 10 slaves, so that we have 2
+# slaves for each master.
+test "Create a 5 nodes cluster" {
+ create_cluster 5 10
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Kill slave #7 of master #2. Only slave left is #12 now" {
+ kill_instance redis 7
+}
+
+set current_epoch [CI 1 cluster_current_epoch]
+
+test "Killing master node #2, #12 should failover" {
+ kill_instance redis 2
+}
+
+test "Wait for failover" {
+ wait_for_condition 1000 50 {
+ [CI 1 cluster_current_epoch] > $current_epoch
+ } else {
+ fail "No failover detected"
+ }
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 1
+}
+
+test "Instance 12 is now a master without slaves" {
+ assert {[RI 12 role] eq {master}}
+}
+
+# The remaining instance is now without slaves. Some other slave
+# should migrate to it.
+
+test "Master #12 should get at least one migrated replica" {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R 12 role] 2]] >= 1
+ } else {
+ fail "Master #12 has no replicas"
+ }
+}
diff --git a/tests/cluster/tests/08-update-msg.tcl b/tests/cluster/tests/08-update-msg.tcl
new file mode 100644
index 0000000..6f9661d
--- /dev/null
+++ b/tests/cluster/tests/08-update-msg.tcl
@@ -0,0 +1,90 @@
+# Test UPDATE messages sent by other nodes when the currently authorirative
+# master is unavaialble. The test is performed in the following steps:
+#
+# 1) Master goes down.
+# 2) Slave failover and becomes new master.
+# 3) New master is partitoned away.
+# 4) Old master returns.
+# 5) At this point we expect the old master to turn into a slave ASAP because
+# of the UPDATE messages it will receive from the other nodes when its
+# configuration will be found to be outdated.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Instance #5 is a slave" {
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+set current_epoch [CI 1 cluster_current_epoch]
+
+test "Killing one master node" {
+ kill_instance redis 0
+}
+
+test "Wait for failover" {
+ wait_for_condition 1000 50 {
+ [CI 1 cluster_current_epoch] > $current_epoch
+ } else {
+ fail "No failover detected"
+ }
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 1
+}
+
+test "Instance #5 is now a master" {
+ assert {[RI 5 role] eq {master}}
+}
+
+test "Killing the new master #5" {
+ kill_instance redis 5
+}
+
+test "Cluster should be down now" {
+ assert_cluster_state fail
+}
+
+test "Restarting the old master node" {
+ restart_instance redis 0
+}
+
+test "Instance #0 gets converted into a slave" {
+ wait_for_condition 1000 50 {
+ [RI 0 role] eq {slave}
+ } else {
+ fail "Old master was not converted into slave"
+ }
+}
+
+test "Restarting the new master node" {
+ restart_instance redis 5
+}
+
+test "Cluster is up again" {
+ assert_cluster_state ok
+}
diff --git a/tests/cluster/tests/09-pubsub.tcl b/tests/cluster/tests/09-pubsub.tcl
new file mode 100644
index 0000000..e62b91c
--- /dev/null
+++ b/tests/cluster/tests/09-pubsub.tcl
@@ -0,0 +1,40 @@
+# Test PUBLISH propagation across the cluster.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+proc test_cluster_publish {instance instances} {
+ # Subscribe all the instances but the one we use to send.
+ for {set j 0} {$j < $instances} {incr j} {
+ if {$j != $instance} {
+ R $j deferred 1
+ R $j subscribe testchannel
+ R $j read; # Read the subscribe reply
+ }
+ }
+
+ set data [randomValue]
+ R $instance PUBLISH testchannel $data
+
+ # Read the message back from all the nodes.
+ for {set j 0} {$j < $instances} {incr j} {
+ if {$j != $instance} {
+ set msg [R $j read]
+ assert {$data eq [lindex $msg 2]}
+ R $j unsubscribe testchannel
+ R $j read; # Read the unsubscribe reply
+ R $j deferred 0
+ }
+ }
+}
+
+test "Test publishing to master" {
+ test_cluster_publish 0 10
+}
+
+test "Test publishing to slave" {
+ test_cluster_publish 5 10
+}
diff --git a/tests/cluster/tests/10-manual-failover.tcl b/tests/cluster/tests/10-manual-failover.tcl
new file mode 100644
index 0000000..5441b79
--- /dev/null
+++ b/tests/cluster/tests/10-manual-failover.tcl
@@ -0,0 +1,192 @@
+# Check the manual failover
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Instance #5 is a slave" {
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+set current_epoch [CI 1 cluster_current_epoch]
+
+set numkeys 50000
+set numops 10000
+set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
+catch {unset content}
+array set content {}
+
+test "Send CLUSTER FAILOVER to #5, during load" {
+ for {set j 0} {$j < $numops} {incr j} {
+ # Write random data to random list.
+ set listid [randomInt $numkeys]
+ set key "key:$listid"
+ set ele [randomValue]
+ # We write both with Lua scripts and with plain commands.
+ # This way we are able to stress Lua -> Redis command invocation
+ # as well, that has tests to prevent Lua to write into wrong
+ # hash slots.
+ if {$listid % 2} {
+ $cluster rpush $key $ele
+ } else {
+ $cluster eval {redis.call("rpush",KEYS[1],ARGV[1])} 1 $key $ele
+ }
+ lappend content($key) $ele
+
+ if {($j % 1000) == 0} {
+ puts -nonewline W; flush stdout
+ }
+
+ if {$j == $numops/2} {R 5 cluster failover}
+ }
+}
+
+test "Wait for failover" {
+ wait_for_condition 1000 50 {
+ [CI 1 cluster_current_epoch] > $current_epoch
+ } else {
+ fail "No failover detected"
+ }
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 1
+}
+
+test "Instance #5 is now a master" {
+ assert {[RI 5 role] eq {master}}
+}
+
+test "Verify $numkeys keys for consistency with logical content" {
+ # Check that the Redis Cluster content matches our logical content.
+ foreach {key value} [array get content] {
+ assert {[$cluster lrange $key 0 -1] eq $value}
+ }
+}
+
+test "Instance #0 gets converted into a slave" {
+ wait_for_condition 1000 50 {
+ [RI 0 role] eq {slave}
+ } else {
+ fail "Old master was not converted into slave"
+ }
+}
+
+## Check that manual failover does not happen if we can't talk with the master.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Instance #5 is a slave" {
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+test "Make instance #0 unreachable without killing it" {
+ R 0 deferred 1
+ R 0 DEBUG SLEEP 10
+}
+
+test "Send CLUSTER FAILOVER to instance #5" {
+ R 5 cluster failover
+}
+
+test "Instance #5 is still a slave after some time (no failover)" {
+ after 5000
+ assert {[RI 5 role] eq {master}}
+}
+
+test "Wait for instance #0 to return back alive" {
+ R 0 deferred 0
+ assert {[R 0 read] eq {OK}}
+}
+
+## Check with "force" failover happens anyway.
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Instance #5 is a slave" {
+ assert {[RI 5 role] eq {slave}}
+}
+
+test "Instance #5 synced with the master" {
+ wait_for_condition 1000 50 {
+ [RI 5 master_link_status] eq {up}
+ } else {
+ fail "Instance #5 master link status is not up"
+ }
+}
+
+test "Make instance #0 unreachable without killing it" {
+ R 0 deferred 1
+ R 0 DEBUG SLEEP 10
+}
+
+test "Send CLUSTER FAILOVER to instance #5" {
+ R 5 cluster failover force
+}
+
+test "Instance #5 is a master after some time" {
+ wait_for_condition 1000 50 {
+ [RI 5 role] eq {master}
+ } else {
+ fail "Instance #5 is not a master after some time regardless of FORCE"
+ }
+}
+
+test "Wait for instance #0 to return back alive" {
+ R 0 deferred 0
+ assert {[R 0 read] eq {OK}}
+}
diff --git a/tests/cluster/tests/11-manual-takeover.tcl b/tests/cluster/tests/11-manual-takeover.tcl
new file mode 100644
index 0000000..f567c69
--- /dev/null
+++ b/tests/cluster/tests/11-manual-takeover.tcl
@@ -0,0 +1,59 @@
+# Manual takeover test
+
+source "../tests/includes/init-tests.tcl"
+
+test "Create a 5 nodes cluster" {
+ create_cluster 5 5
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 0
+}
+
+test "Killing majority of master nodes" {
+ kill_instance redis 0
+ kill_instance redis 1
+ kill_instance redis 2
+}
+
+test "Cluster should eventually be down" {
+ assert_cluster_state fail
+}
+
+test "Use takeover to bring slaves back" {
+ R 5 cluster failover takeover
+ R 6 cluster failover takeover
+ R 7 cluster failover takeover
+}
+
+test "Cluster should eventually be up again" {
+ assert_cluster_state ok
+}
+
+test "Cluster is writable" {
+ cluster_write_test 4
+}
+
+test "Instance #5, #6, #7 are now masters" {
+ assert {[RI 5 role] eq {master}}
+ assert {[RI 6 role] eq {master}}
+ assert {[RI 7 role] eq {master}}
+}
+
+test "Restarting the previously killed master nodes" {
+ restart_instance redis 0
+ restart_instance redis 1
+ restart_instance redis 2
+}
+
+test "Instance #0, #1, #2 gets converted into a slaves" {
+ wait_for_condition 1000 50 {
+ [RI 0 role] eq {slave} && [RI 1 role] eq {slave} && [RI 2 role] eq {slave}
+ } else {
+ fail "Old masters not converted into slaves"
+ }
+}
diff --git a/tests/cluster/tests/12-replica-migration-2.tcl b/tests/cluster/tests/12-replica-migration-2.tcl
new file mode 100644
index 0000000..48ecd1d
--- /dev/null
+++ b/tests/cluster/tests/12-replica-migration-2.tcl
@@ -0,0 +1,64 @@
+# Replica migration test #2.
+#
+# Check that the status of master that can be targeted by replica migration
+# is acquired again, after being getting slots again, in a cluster where the
+# other masters have slaves.
+
+source "../tests/includes/init-tests.tcl"
+
+# Create a cluster with 5 master and 15 slaves, to make sure there are no
+# empty masters and make rebalancing simpler to handle during the test.
+test "Create a 5 nodes cluster" {
+ create_cluster 5 15
+}
+
+test "Cluster is up" {
+ assert_cluster_state ok
+}
+
+test "Each master should have at least two replicas attached" {
+ foreach_redis_id id {
+ if {$id < 5} {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R 0 role] 2]] >= 2
+ } else {
+ fail "Master #$id does not have 2 slaves as expected"
+ }
+ }
+ }
+}
+
+set master0_id [dict get [get_myself 0] id]
+test "Resharding all the master #0 slots away from it" {
+ set output [exec \
+ ../../../src/redis-trib.rb rebalance \
+ --weight ${master0_id}=0 \
+ 127.0.0.1:[get_instance_attrib redis 0 port] >@ stdout]
+}
+
+test "Master #0 should lose its replicas" {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R 0 role] 2]] == 0
+ } else {
+ fail "Master #0 still has replicas"
+ }
+}
+
+test "Resharding back some slot to master #0" {
+ # Wait for the cluster config to propagate before attempting a
+ # new resharding.
+ after 10000
+ set output [exec \
+ ../../../src/redis-trib.rb rebalance \
+ --weight ${master0_id}=.01 \
+ --use-empty-masters \
+ 127.0.0.1:[get_instance_attrib redis 0 port] >@ stdout]
+}
+
+test "Master #0 should re-acquire one or more replicas" {
+ wait_for_condition 1000 50 {
+ [llength [lindex [R 0 role] 2]] >= 1
+ } else {
+ fail "Master #0 has no has replicas"
+ }
+}
diff --git a/tests/cluster/tests/helpers/onlydots.tcl b/tests/cluster/tests/helpers/onlydots.tcl
new file mode 100644
index 0000000..4a6d1ae
--- /dev/null
+++ b/tests/cluster/tests/helpers/onlydots.tcl
@@ -0,0 +1,16 @@
+# Read the standard input and only shows dots in the output, filtering out
+# all the other characters. Designed to avoid bufferization so that when
+# we get the output of redis-trib and want to show just the dots, we'll see
+# the dots as soon as redis-trib will output them.
+
+fconfigure stdin -buffering none
+
+while 1 {
+ set c [read stdin 1]
+ if {$c eq {}} {
+ exit 0; # EOF
+ } elseif {$c eq {.}} {
+ puts -nonewline .
+ flush stdout
+ }
+}
diff --git a/tests/cluster/tests/includes/init-tests.tcl b/tests/cluster/tests/includes/init-tests.tcl
new file mode 100644
index 0000000..466ab8f
--- /dev/null
+++ b/tests/cluster/tests/includes/init-tests.tcl
@@ -0,0 +1,70 @@
+# Initialization tests -- most units will start including this.
+
+test "(init) Restart killed instances" {
+ foreach type {redis} {
+ foreach_${type}_id id {
+ if {[get_instance_attrib $type $id pid] == -1} {
+ puts -nonewline "$type/$id "
+ flush stdout
+ restart_instance $type $id
+ }
+ }
+ }
+}
+
+test "Cluster nodes are reachable" {
+ foreach_redis_id id {
+ # Every node should be reachable.
+ wait_for_condition 1000 50 {
+ ([catch {R $id ping} ping_reply] == 0) &&
+ ($ping_reply eq {PONG})
+ } else {
+ catch {R $id ping} err
+ fail "Node #$id keeps replying '$err' to PING."
+ }
+ }
+}
+
+test "Cluster nodes hard reset" {
+ foreach_redis_id id {
+ if {$::valgrind} {
+ set node_timeout 10000
+ } else {
+ set node_timeout 3000
+ }
+ catch {R $id flushall} ; # May fail for readonly slaves.
+ R $id MULTI
+ R $id cluster reset hard
+ R $id cluster set-config-epoch [expr {$id+1}]
+ R $id EXEC
+ R $id config set cluster-node-timeout $node_timeout
+ R $id config set cluster-slave-validity-factor 10
+ R $id config rewrite
+ }
+}
+
+test "Cluster Join and auto-discovery test" {
+ # Join node 0 with 1, 1 with 2, ... and so forth.
+ # If auto-discovery works all nodes will know every other node
+ # eventually.
+ set ids {}
+ foreach_redis_id id {lappend ids $id}
+ for {set j 0} {$j < [expr [llength $ids]-1]} {incr j} {
+ set a [lindex $ids $j]
+ set b [lindex $ids [expr $j+1]]
+ set b_port [get_instance_attrib redis $b port]
+ R $a cluster meet 127.0.0.1 $b_port
+ }
+
+ foreach_redis_id id {
+ wait_for_condition 1000 50 {
+ [llength [get_cluster_nodes $id]] == [llength $ids]
+ } else {
+ fail "Cluster failed to join into a full mesh."
+ }
+ }
+}
+
+test "Before slots allocation, all nodes report cluster failure" {
+ assert_cluster_state fail
+}
diff --git a/tests/cluster/tmp/.gitignore b/tests/cluster/tmp/.gitignore
new file mode 100644
index 0000000..f581f73
--- /dev/null
+++ b/tests/cluster/tmp/.gitignore
@@ -0,0 +1,2 @@
+redis_*
+sentinel_*
diff --git a/tests/helpers/bg_complex_data.tcl b/tests/helpers/bg_complex_data.tcl
new file mode 100644
index 0000000..dffd7c6
--- /dev/null
+++ b/tests/helpers/bg_complex_data.tcl
@@ -0,0 +1,10 @@
+source tests/support/redis.tcl
+source tests/support/util.tcl
+
+proc bg_complex_data {host port db ops} {
+ set r [redis $host $port]
+ $r select $db
+ createComplexDataset $r $ops
+}
+
+bg_complex_data [lindex $argv 0] [lindex $argv 1] [lindex $argv 2] [lindex $argv 3]
diff --git a/tests/helpers/gen_write_load.tcl b/tests/helpers/gen_write_load.tcl
new file mode 100644
index 0000000..6d1a345
--- /dev/null
+++ b/tests/helpers/gen_write_load.tcl
@@ -0,0 +1,15 @@
+source tests/support/redis.tcl
+
+proc gen_write_load {host port seconds} {
+ set start_time [clock seconds]
+ set r [redis $host $port 1]
+ $r select 9
+ while 1 {
+ $r set [expr rand()] [expr rand()]
+ if {[clock seconds]-$start_time > $seconds} {
+ exit 0
+ }
+ }
+}
+
+gen_write_load [lindex $argv 0] [lindex $argv 1] [lindex $argv 2]
diff --git a/tests/instances.tcl b/tests/instances.tcl
new file mode 100644
index 0000000..2ba67ac
--- /dev/null
+++ b/tests/instances.tcl
@@ -0,0 +1,511 @@
+# Multi-instance test framework.
+# This is used in order to test Sentinel and Redis Cluster, and provides
+# basic capabilities for spawning and handling N parallel Redis / Sentinel
+# instances.
+#
+# Copyright (C) 2014 Salvatore Sanfilippo [email protected]
+# This software is released under the BSD License. See the COPYING file for
+# more information.
+
+package require Tcl 8.5
+
+set tcl_precision 17
+source ../support/redis.tcl
+source ../support/util.tcl
+source ../support/server.tcl
+source ../support/test.tcl
+
+set ::verbose 0
+set ::valgrind 0
+set ::pause_on_error 0
+set ::simulate_error 0
+set ::failed 0
+set ::sentinel_instances {}
+set ::redis_instances {}
+set ::sentinel_base_port 20000
+set ::redis_base_port 30000
+set ::pids {} ; # We kill everything at exit
+set ::dirs {} ; # We remove all the temp dirs at exit
+set ::run_matching {} ; # If non empty, only tests matching pattern are run.
+
+if {[catch {cd tmp}]} {
+ puts "tmp directory not found."
+ puts "Please run this test from the Redis source root."
+ exit 1
+}
+
+# Execute the specified instance of the server specified by 'type', using
+# the provided configuration file. Returns the PID of the process.
+proc exec_instance {type cfgfile} {
+ if {$type eq "redis"} {
+ set prgname redis-server
+ } elseif {$type eq "sentinel"} {
+ set prgname redis-sentinel
+ } else {
+ error "Unknown instance type."
+ }
+
+ if {$::valgrind} {
+ set pid [exec valgrind --track-origins=yes --suppressions=../../../src/valgrind.sup --show-reachable=no --show-possibly-lost=no --leak-check=full ../../../src/${prgname} $cfgfile &]
+ } else {
+ set pid [exec ../../../src/${prgname} $cfgfile &]
+ }
+ return $pid
+}
+
+# Spawn a redis or sentinel instance, depending on 'type'.
+proc spawn_instance {type base_port count {conf {}}} {
+ for {set j 0} {$j < $count} {incr j} {
+ set port [find_available_port $base_port]
+ incr base_port
+ puts "Starting $type #$j at port $port"
+
+ # Create a directory for this instance.
+ set dirname "${type}_${j}"
+ lappend ::dirs $dirname
+ catch {exec rm -rf $dirname}
+ file mkdir $dirname
+
+ # Write the instance config file.
+ set cfgfile [file join $dirname $type.conf]
+ set cfg [open $cfgfile w]
+ puts $cfg "port $port"
+ puts $cfg "dir ./$dirname"
+ puts $cfg "logfile log.txt"
+ # Add additional config files
+ foreach directive $conf {
+ puts $cfg $directive
+ }
+ close $cfg
+
+ # Finally exec it and remember the pid for later cleanup.
+ set pid [exec_instance $type $cfgfile]
+ lappend ::pids $pid
+
+ # Check availability
+ if {[server_is_up 127.0.0.1 $port 100] == 0} {
+ abort_sentinel_test "Problems starting $type #$j: ping timeout"
+ }
+
+ # Push the instance into the right list
+ set link [redis 127.0.0.1 $port]
+ $link reconnect 1
+ lappend ::${type}_instances [list \
+ pid $pid \
+ host 127.0.0.1 \
+ port $port \
+ link $link \
+ ]
+ }
+}
+
+proc log_crashes {} {
+ set start_pattern {*REDIS BUG REPORT START*}
+ set logs [glob */log.txt]
+ foreach log $logs {
+ set fd [open $log]
+ set found 0
+ while {[gets $fd line] >= 0} {
+ if {[string match $start_pattern $line]} {
+ puts "\n*** Crash report found in $log ***"
+ set found 1
+ }
+ if {$found} {puts $line}
+ }
+ }
+}
+
+proc cleanup {} {
+ puts "Cleaning up..."
+ log_crashes
+ foreach pid $::pids {
+ catch {exec kill -9 $pid}
+ }
+ foreach dir $::dirs {
+ catch {exec rm -rf $dir}
+ }
+}
+
+proc abort_sentinel_test msg {
+ incr ::failed
+ puts "WARNING: Aborting the test."
+ puts ">>>>>>>> $msg"
+ if {$::pause_on_error} pause_on_error
+ cleanup
+ exit 1
+}
+
+proc parse_options {} {
+ for {set j 0} {$j < [llength $::argv]} {incr j} {
+ set opt [lindex $::argv $j]
+ set val [lindex $::argv [expr $j+1]]
+ if {$opt eq "--single"} {
+ incr j
+ set ::run_matching "*${val}*"
+ } elseif {$opt eq "--pause-on-error"} {
+ set ::pause_on_error 1
+ } elseif {$opt eq "--fail"} {
+ set ::simulate_error 1
+ } elseif {$opt eq {--valgrind}} {
+ set ::valgrind 1
+ } elseif {$opt eq "--help"} {
+ puts "Hello, I'm sentinel.tcl and I run Sentinel unit tests."
+ puts "\nOptions:"
+ puts "--single <pattern> Only runs tests specified by pattern."
+ puts "--pause-on-error Pause for manual inspection on error."
+ puts "--fail Simulate a test failure."
+ puts "--valgrind Run with valgrind."
+ puts "--help Shows this help."
+ exit 0
+ } else {
+ puts "Unknown option $opt"
+ exit 1
+ }
+ }
+}
+
+# If --pause-on-error option was passed at startup this function is called
+# on error in order to give the developer a chance to understand more about
+# the error condition while the instances are still running.
+proc pause_on_error {} {
+ puts ""
+ puts [colorstr yellow "*** Please inspect the error now ***"]
+ puts "\nType \"continue\" to resume the test, \"help\" for help screen.\n"
+ while 1 {
+ puts -nonewline "> "
+ flush stdout
+ set line [gets stdin]
+ set argv [split $line " "]
+ set cmd [lindex $argv 0]
+ if {$cmd eq {continue}} {
+ break
+ } elseif {$cmd eq {show-redis-logs}} {
+ set count 10
+ if {[lindex $argv 1] ne {}} {set count [lindex $argv 1]}
+ foreach_redis_id id {
+ puts "=== REDIS $id ===="
+ puts [exec tail -$count redis_$id/log.txt]
+ puts "---------------------\n"
+ }
+ } elseif {$cmd eq {show-sentinel-logs}} {
+ set count 10
+ if {[lindex $argv 1] ne {}} {set count [lindex $argv 1]}
+ foreach_sentinel_id id {
+ puts "=== SENTINEL $id ===="
+ puts [exec tail -$count sentinel_$id/log.txt]
+ puts "---------------------\n"
+ }
+ } elseif {$cmd eq {ls}} {
+ foreach_redis_id id {
+ puts -nonewline "Redis $id"
+ set errcode [catch {
+ set str {}
+ append str "@[RI $id tcp_port]: "
+ append str "[RI $id role] "
+ if {[RI $id role] eq {slave}} {
+ append str "[RI $id master_host]:[RI $id master_port]"
+ }
+ set str
+ } retval]
+ if {$errcode} {
+ puts " -- $retval"
+ } else {
+ puts $retval
+ }
+ }
+ foreach_sentinel_id id {
+ puts -nonewline "Sentinel $id"
+ set errcode [catch {
+ set str {}
+ append str "@[SI $id tcp_port]: "
+ append str "[join [S $id sentinel get-master-addr-by-name mymaster]]"
+ set str
+ } retval]
+ if {$errcode} {
+ puts " -- $retval"
+ } else {
+ puts $retval
+ }
+ }
+ } elseif {$cmd eq {help}} {
+ puts "ls List Sentinel and Redis instances."
+ puts "show-sentinel-logs \[N\] Show latest N lines of logs."
+ puts "show-redis-logs \[N\] Show latest N lines of logs."
+ puts "S <id> cmd ... arg Call command in Sentinel <id>."
+ puts "R <id> cmd ... arg Call command in Redis <id>."
+ puts "SI <id> <field> Show Sentinel <id> INFO <field>."
+ puts "RI <id> <field> Show Sentinel <id> INFO <field>."
+ puts "continue Resume test."
+ } else {
+ set errcode [catch {eval $line} retval]
+ if {$retval ne {}} {puts "$retval"}
+ }
+ }
+}
+
+# We redefine 'test' as for Sentinel we don't use the server-client
+# architecture for the test, everything is sequential.
+proc test {descr code} {
+ set ts [clock format [clock seconds] -format %H:%M:%S]
+ puts -nonewline "$ts> $descr: "
+ flush stdout
+
+ if {[catch {set retval [uplevel 1 $code]} error]} {
+ incr ::failed
+ if {[string match "assertion:*" $error]} {
+ set msg [string range $error 10 end]
+ puts [colorstr red $msg]
+ if {$::pause_on_error} pause_on_error
+ puts "(Jumping to next unit after error)"
+ return -code continue
+ } else {
+ # Re-raise, let handler up the stack take care of this.
+ error $error $::errorInfo
+ }
+ } else {
+ puts [colorstr green OK]
+ }
+}
+
+# Check memory leaks when running on OSX using the "leaks" utility.
+proc check_leaks instance_types {
+ if {[string match {*Darwin*} [exec uname -a]]} {
+ puts -nonewline "Testing for memory leaks..."; flush stdout
+ foreach type $instance_types {
+ foreach_instance_id [set ::${type}_instances] id {
+ if {[instance_is_killed $type $id]} continue
+ set pid [get_instance_attrib $type $id pid]
+ set output {0 leaks}
+ catch {exec leaks $pid} output
+ if {[string match {*process does not exist*} $output] ||
+ [string match {*cannot examine*} $output]} {
+ # In a few tests we kill the server process.
+ set output "0 leaks"
+ } else {
+ puts -nonewline "$type/$pid "
+ flush stdout
+ }
+ if {![string match {*0 leaks*} $output]} {
+ puts [colorstr red "=== MEMORY LEAK DETECTED ==="]
+ puts "Instance type $type, ID $id:"
+ puts $output
+ puts "==="
+ incr ::failed
+ }
+ }
+ }
+ puts ""
+ }
+}
+
+# Execute all the units inside the 'tests' directory.
+proc run_tests {} {
+ set tests [lsort [glob ../tests/*]]
+ foreach test $tests {
+ if {$::run_matching ne {} && [string match $::run_matching $test] == 0} {
+ continue
+ }
+ if {[file isdirectory $test]} continue
+ puts [colorstr yellow "Testing unit: [lindex [file split $test] end]"]
+ source $test
+ check_leaks {redis sentinel}
+ }
+}
+
+# Print a message and exists with 0 / 1 according to zero or more failures.
+proc end_tests {} {
+ if {$::failed == 0} {
+ puts "GOOD! No errors."
+ exit 0
+ } else {
+ puts "WARNING $::failed tests faield."
+ exit 1
+ }
+}
+
+# The "S" command is used to interact with the N-th Sentinel.
+# The general form is:
+#
+# S <sentinel-id> command arg arg arg ...
+#
+# Example to ping the Sentinel 0 (first instance): S 0 PING
+proc S {n args} {
+ set s [lindex $::sentinel_instances $n]
+ [dict get $s link] {*}$args
+}
+
+# Like R but to chat with Redis instances.
+proc R {n args} {
+ set r [lindex $::redis_instances $n]
+ [dict get $r link] {*}$args
+}
+
+proc get_info_field {info field} {
+ set fl [string length $field]
+ append field :
+ foreach line [split $info "\n"] {
+ set line [string trim $line "\r\n "]
+ if {[string range $line 0 $fl] eq $field} {
+ return [string range $line [expr {$fl+1}] end]
+ }
+ }
+ return {}
+}
+
+proc SI {n field} {
+ get_info_field [S $n info] $field
+}
+
+proc RI {n field} {
+ get_info_field [R $n info] $field
+}
+
+# Iterate over IDs of sentinel or redis instances.
+proc foreach_instance_id {instances idvar code} {
+ upvar 1 $idvar id
+ for {set id 0} {$id < [llength $instances]} {incr id} {
+ set errcode [catch {uplevel 1 $code} result]
+ if {$errcode == 1} {
+ error $result $::errorInfo $::errorCode
+ } elseif {$errcode == 4} {
+ continue
+ } elseif {$errcode == 3} {
+ break
+ } elseif {$errcode != 0} {
+ return -code $errcode $result
+ }
+ }
+}
+
+proc foreach_sentinel_id {idvar code} {
+ set errcode [catch {uplevel 1 [list foreach_instance_id $::sentinel_instances $idvar $code]} result]
+ return -code $errcode $result
+}
+
+proc foreach_redis_id {idvar code} {
+ set errcode [catch {uplevel 1 [list foreach_instance_id $::redis_instances $idvar $code]} result]
+ return -code $errcode $result
+}
+
+# Get the specific attribute of the specified instance type, id.
+proc get_instance_attrib {type id attrib} {
+ dict get [lindex [set ::${type}_instances] $id] $attrib
+}
+
+# Set the specific attribute of the specified instance type, id.
+proc set_instance_attrib {type id attrib newval} {
+ set d [lindex [set ::${type}_instances] $id]
+ dict set d $attrib $newval
+ lset ::${type}_instances $id $d
+}
+
+# Create a master-slave cluster of the given number of total instances.
+# The first instance "0" is the master, all others are configured as
+# slaves.
+proc create_redis_master_slave_cluster n {
+ foreach_redis_id id {
+ if {$id == 0} {
+ # Our master.
+ R $id slaveof no one
+ R $id flushall
+ } elseif {$id < $n} {
+ R $id slaveof [get_instance_attrib redis 0 host] \
+ [get_instance_attrib redis 0 port]
+ } else {
+ # Instances not part of the cluster.
+ R $id slaveof no one
+ }
+ }
+ # Wait for all the slaves to sync.
+ wait_for_condition 1000 50 {
+ [RI 0 connected_slaves] == ($n-1)
+ } else {
+ fail "Unable to create a master-slaves cluster."
+ }
+}
+
+proc get_instance_id_by_port {type port} {
+ foreach_${type}_id id {
+ if {[get_instance_attrib $type $id port] == $port} {
+ return $id
+ }
+ }
+ fail "Instance $type port $port not found."
+}
+
+# Kill an instance of the specified type/id with SIGKILL.
+# This function will mark the instance PID as -1 to remember that this instance
+# is no longer running and will remove its PID from the list of pids that
+# we kill at cleanup.
+#
+# The instance can be restarted with restart-instance.
+proc kill_instance {type id} {
+ set pid [get_instance_attrib $type $id pid]
+ set port [get_instance_attrib $type $id port]
+
+ if {$pid == -1} {
+ error "You tried to kill $type $id twice."
+ }
+
+ exec kill -9 $pid
+ set_instance_attrib $type $id pid -1
+ set_instance_attrib $type $id link you_tried_to_talk_with_killed_instance
+
+ # Remove the PID from the list of pids to kill at exit.
+ set ::pids [lsearch -all -inline -not -exact $::pids $pid]
+
+ # Wait for the port it was using to be available again, so that's not
+ # an issue to start a new server ASAP with the same port.
+ set retry 10
+ while {[incr retry -1]} {
+ set port_is_free [catch {set s [socket 127.0.01 $port]}]
+ if {$port_is_free} break
+ catch {close $s}
+ after 1000
+ }
+ if {$retry == 0} {
+ error "Port $port does not return available after killing instance."
+ }
+}
+
+# Return true of the instance of the specified type/id is killed.
+proc instance_is_killed {type id} {
+ set pid [get_instance_attrib $type $id pid]
+ expr {$pid == -1}
+}
+
+# Restart an instance previously killed by kill_instance
+proc restart_instance {type id} {
+ set dirname "${type}_${id}"
+ set cfgfile [file join $dirname $type.conf]
+ set port [get_instance_attrib $type $id port]
+
+ # Execute the instance with its old setup and append the new pid
+ # file for cleanup.
+ set pid [exec_instance $type $cfgfile]
+ set_instance_attrib $type $id pid $pid
+ lappend ::pids $pid
+
+ # Check that the instance is running
+ if {[server_is_up 127.0.0.1 $port 100] == 0} {
+ abort_sentinel_test "Problems starting $type #$id: ping timeout"
+ }
+
+ # Connect with it with a fresh link
+ set link [redis 127.0.0.1 $port]
+ $link reconnect 1
+ set_instance_attrib $type $id link $link
+
+ # Make sure the instance is not loading the dataset when this
+ # function returns.
+ while 1 {
+ catch {[$link ping]} retval
+ if {[string match {*LOADING*} $retval]} {
+ after 100
+ continue
+ } else {
+ break
+ }
+ }
+}
+
diff --git a/tests/integration/aof-race.tcl b/tests/integration/aof-race.tcl
new file mode 100644
index 0000000..207f207
--- /dev/null
+++ b/tests/integration/aof-race.tcl
@@ -0,0 +1,35 @@
+set defaults { appendonly {yes} appendfilename {appendonly.aof} }
+set server_path [tmpdir server.aof]
+set aof_path "$server_path/appendonly.aof"
+
+proc start_server_aof {overrides code} {
+ upvar defaults defaults srv srv server_path server_path
+ set config [concat $defaults $overrides]
+ start_server [list overrides $config] $code
+}
+
+tags {"aof"} {
+ # Specific test for a regression where internal buffers were not properly
+ # cleaned after a child responsible for an AOF rewrite exited. This buffer
+ # was subsequently appended to the new AOF, resulting in duplicate commands.
+ start_server_aof [list dir $server_path] {
+ set client [redis [srv host] [srv port]]
+ set bench [open "|src/redis-benchmark -q -p [srv port] -c 20 -n 20000 incr foo" "r+"]
+ after 100
+
+ # Benchmark should be running by now: start background rewrite
+ $client bgrewriteaof
+
+ # Read until benchmark pipe reaches EOF
+ while {[string length [read $bench]] > 0} {}
+
+ # Check contents of foo
+ assert_equal 20000 [$client get foo]
+ }
+
+ # Restart server to replay AOF
+ start_server_aof [list dir $server_path] {
+ set client [redis [srv host] [srv port]]
+ assert_equal 20000 [$client get foo]
+ }
+}
diff --git a/tests/integration/aof.tcl b/tests/integration/aof.tcl
new file mode 100644
index 0000000..e397fae
--- /dev/null
+++ b/tests/integration/aof.tcl
@@ -0,0 +1,260 @@
+set defaults { appendonly {yes} appendfilename {appendonly.aof} }
+set server_path [tmpdir server.aof]
+set aof_path "$server_path/appendonly.aof"
+
+proc append_to_aof {str} {
+ upvar fp fp
+ puts -nonewline $fp $str
+}
+
+proc create_aof {code} {
+ upvar fp fp aof_path aof_path
+ set fp [open $aof_path w+]
+ uplevel 1 $code
+ close $fp
+}
+
+proc start_server_aof {overrides code} {
+ upvar defaults defaults srv srv server_path server_path
+ set config [concat $defaults $overrides]
+ set srv [start_server [list overrides $config]]
+ uplevel 1 $code
+ kill_server $srv
+}
+
+tags {"aof"} {
+ ## Server can start when aof-load-truncated is set to yes and AOF
+ ## is truncated, with an incomplete MULTI block.
+ create_aof {
+ append_to_aof [formatCommand set foo hello]
+ append_to_aof [formatCommand multi]
+ append_to_aof [formatCommand set bar world]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated yes] {
+ test "Unfinished MULTI: Server should start if load-truncated is yes" {
+ assert_equal 1 [is_alive $srv]
+ }
+ }
+
+ ## Should also start with truncated AOF without incomplete MULTI block.
+ create_aof {
+ append_to_aof [formatCommand incr foo]
+ append_to_aof [formatCommand incr foo]
+ append_to_aof [formatCommand incr foo]
+ append_to_aof [formatCommand incr foo]
+ append_to_aof [formatCommand incr foo]
+ append_to_aof [string range [formatCommand incr foo] 0 end-1]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated yes] {
+ test "Short read: Server should start if load-truncated is yes" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ set client [redis [dict get $srv host] [dict get $srv port]]
+
+ test "Truncated AOF loaded: we expect foo to be equal to 5" {
+ assert {[$client get foo] eq "5"}
+ }
+
+ test "Append a new command after loading an incomplete AOF" {
+ $client incr foo
+ }
+ }
+
+ # Now the AOF file is expected to be correct
+ start_server_aof [list dir $server_path aof-load-truncated yes] {
+ test "Short read + command: Server should start" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ set client [redis [dict get $srv host] [dict get $srv port]]
+
+ test "Truncated AOF loaded: we expect foo to be equal to 6 now" {
+ assert {[$client get foo] eq "6"}
+ }
+ }
+
+ ## Test that the server exits when the AOF contains a format error
+ create_aof {
+ append_to_aof [formatCommand set foo hello]
+ append_to_aof "!!!"
+ append_to_aof [formatCommand set foo hello]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated yes] {
+ test "Bad format: Server should have logged an error" {
+ set pattern "*Bad file format reading the append only file*"
+ set retry 10
+ while {$retry} {
+ set result [exec tail -1 < [dict get $srv stdout]]
+ if {[string match $pattern $result]} {
+ break
+ }
+ incr retry -1
+ after 1000
+ }
+ if {$retry == 0} {
+ error "assertion:expected error not found on config file"
+ }
+ }
+ }
+
+ ## Test the server doesn't start when the AOF contains an unfinished MULTI
+ create_aof {
+ append_to_aof [formatCommand set foo hello]
+ append_to_aof [formatCommand multi]
+ append_to_aof [formatCommand set bar world]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated no] {
+ test "Unfinished MULTI: Server should have logged an error" {
+ set pattern "*Unexpected end of file reading the append only file*"
+ set retry 10
+ while {$retry} {
+ set result [exec tail -1 < [dict get $srv stdout]]
+ if {[string match $pattern $result]} {
+ break
+ }
+ incr retry -1
+ after 1000
+ }
+ if {$retry == 0} {
+ error "assertion:expected error not found on config file"
+ }
+ }
+ }
+
+ ## Test that the server exits when the AOF contains a short read
+ create_aof {
+ append_to_aof [formatCommand set foo hello]
+ append_to_aof [string range [formatCommand set bar world] 0 end-1]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated no] {
+ test "Short read: Server should have logged an error" {
+ set pattern "*Unexpected end of file reading the append only file*"
+ set retry 10
+ while {$retry} {
+ set result [exec tail -1 < [dict get $srv stdout]]
+ if {[string match $pattern $result]} {
+ break
+ }
+ incr retry -1
+ after 1000
+ }
+ if {$retry == 0} {
+ error "assertion:expected error not found on config file"
+ }
+ }
+ }
+
+ ## Test that redis-check-aof indeed sees this AOF is not valid
+ test "Short read: Utility should confirm the AOF is not valid" {
+ catch {
+ exec src/redis-check-aof $aof_path
+ } result
+ assert_match "*not valid*" $result
+ }
+
+ test "Short read: Utility should be able to fix the AOF" {
+ set result [exec src/redis-check-aof --fix $aof_path << "y\n"]
+ assert_match "*Successfully truncated AOF*" $result
+ }
+
+ ## Test that the server can be started using the truncated AOF
+ start_server_aof [list dir $server_path aof-load-truncated no] {
+ test "Fixed AOF: Server should have been started" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ test "Fixed AOF: Keyspace should contain values that were parseable" {
+ set client [redis [dict get $srv host] [dict get $srv port]]
+ wait_for_condition 50 100 {
+ [catch {$client ping} e] == 0
+ } else {
+ fail "Loading DB is taking too much time."
+ }
+ assert_equal "hello" [$client get foo]
+ assert_equal "" [$client get bar]
+ }
+ }
+
+ ## Test that SPOP (that modifies the client's argc/argv) is correctly free'd
+ create_aof {
+ append_to_aof [formatCommand sadd set foo]
+ append_to_aof [formatCommand sadd set bar]
+ append_to_aof [formatCommand spop set]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated no] {
+ test "AOF+SPOP: Server should have been started" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ test "AOF+SPOP: Set should have 1 member" {
+ set client [redis [dict get $srv host] [dict get $srv port]]
+ wait_for_condition 50 100 {
+ [catch {$client ping} e] == 0
+ } else {
+ fail "Loading DB is taking too much time."
+ }
+ assert_equal 1 [$client scard set]
+ }
+ }
+
+ ## Uses the alsoPropagate() API.
+ create_aof {
+ append_to_aof [formatCommand sadd set foo]
+ append_to_aof [formatCommand sadd set bar]
+ append_to_aof [formatCommand sadd set gah]
+ append_to_aof [formatCommand spop set 2]
+ }
+
+ start_server_aof [list dir $server_path] {
+ test "AOF+SPOP: Server should have been started" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ test "AOF+SPOP: Set should have 1 member" {
+ set client [redis [dict get $srv host] [dict get $srv port]]
+ wait_for_condition 50 100 {
+ [catch {$client ping} e] == 0
+ } else {
+ fail "Loading DB is taking too much time."
+ }
+ assert_equal 1 [$client scard set]
+ }
+ }
+
+ ## Test that EXPIREAT is loaded correctly
+ create_aof {
+ append_to_aof [formatCommand rpush list foo]
+ append_to_aof [formatCommand expireat list 1000]
+ append_to_aof [formatCommand rpush list bar]
+ }
+
+ start_server_aof [list dir $server_path aof-load-truncated no] {
+ test "AOF+EXPIRE: Server should have been started" {
+ assert_equal 1 [is_alive $srv]
+ }
+
+ test "AOF+EXPIRE: List should be empty" {
+ set client [redis [dict get $srv host] [dict get $srv port]]
+ wait_for_condition 50 100 {
+ [catch {$client ping} e] == 0
+ } else {
+ fail "Loading DB is taking too much time."
+ }
+ assert_equal 0 [$client llen list]
+ }
+ }
+
+ start_server {overrides {appendonly {yes} appendfilename {appendonly.aof}}} {
+ test {Redis should not try to convert DEL into EXPIREAT for EXPIRE -1} {
+ r set x 10
+ r expire x -1
+ }
+ }
+}
diff --git a/tests/integration/convert-zipmap-hash-on-load.tcl b/tests/integration/convert-zipmap-hash-on-load.tcl
new file mode 100644
index 0000000..cf3577f
--- /dev/null
+++ b/tests/integration/convert-zipmap-hash-on-load.tcl
@@ -0,0 +1,35 @@
+# Copy RDB with zipmap encoded hash to server path
+set server_path [tmpdir "server.convert-zipmap-hash-on-load"]
+
+exec cp -f tests/assets/hash-zipmap.rdb $server_path
+start_server [list overrides [list "dir" $server_path "dbfilename" "hash-zipmap.rdb"]] {
+ test "RDB load zipmap hash: converts to ziplist" {
+ r select 0
+
+ assert_match "*ziplist*" [r debug object hash]
+ assert_equal 2 [r hlen hash]
+ assert_match {v1 v2} [r hmget hash f1 f2]
+ }
+}
+
+exec cp -f tests/assets/hash-zipmap.rdb $server_path
+start_server [list overrides [list "dir" $server_path "dbfilename" "hash-zipmap.rdb" "hash-max-ziplist-entries" 1]] {
+ test "RDB load zipmap hash: converts to hash table when hash-max-ziplist-entries is exceeded" {
+ r select 0
+
+ assert_match "*hashtable*" [r debug object hash]
+ assert_equal 2 [r hlen hash]
+ assert_match {v1 v2} [r hmget hash f1 f2]
+ }
+}
+
+exec cp -f tests/assets/hash-zipmap.rdb $server_path
+start_server [list overrides [list "dir" $server_path "dbfilename" "hash-zipmap.rdb" "hash-max-ziplist-value" 1]] {
+ test "RDB load zipmap hash: converts to hash table when hash-max-ziplist-value is exceeded" {
+ r select 0
+
+ assert_match "*hashtable*" [r debug object hash]
+ assert_equal 2 [r hlen hash]
+ assert_match {v1 v2} [r hmget hash f1 f2]
+ }
+}
diff --git a/tests/integration/logging.tcl b/tests/integration/logging.tcl
new file mode 100644
index 0000000..c1f4854
--- /dev/null
+++ b/tests/integration/logging.tcl
@@ -0,0 +1,24 @@
+set server_path [tmpdir server.log]
+set system_name [string tolower [exec uname -s]]
+
+if {$system_name eq {linux} || $system_name eq {darwin}} {
+ start_server [list overrides [list dir $server_path]] {
+ test "Server is able to generate a stack trace on selected systems" {
+ r config set watchdog-period 200
+ r debug sleep 1
+ set pattern "*debugCommand*"
+ set retry 10
+ while {$retry} {
+ set result [exec tail -100 < [srv 0 stdout]]
+ if {[string match $pattern $result]} {
+ break
+ }
+ incr retry -1
+ after 1000
+ }
+ if {$retry == 0} {
+ error "assertion:expected stack trace not found into log file"
+ }
+ }
+ }
+}
diff --git a/tests/integration/psync2.tcl b/tests/integration/psync2.tcl
new file mode 100644
index 0000000..d91969e
--- /dev/null
+++ b/tests/integration/psync2.tcl
@@ -0,0 +1,182 @@
+start_server {tags {"psync2"}} {
+start_server {} {
+start_server {} {
+start_server {} {
+start_server {} {
+ set master_id 0 ; # Current master
+ set start_time [clock seconds] ; # Test start time
+ set counter_value 0 ; # Current value of the Redis counter "x"
+
+ # Config
+ set debug_msg 0 ; # Enable additional debug messages
+
+ set no_exit 0; ; # Do not exit at end of the test
+
+ set duration 20 ; # Total test seconds
+
+ set genload 1 ; # Load master with writes at every cycle
+
+ set genload_time 5000 ; # Writes duration time in ms
+
+ set disconnect 1 ; # Break replication link between random
+ # master and slave instances while the
+ # master is loaded with writes.
+
+ set disconnect_period 1000 ; # Disconnect repl link every N ms.
+
+ for {set j 0} {$j < 5} {incr j} {
+ set R($j) [srv [expr 0-$j] client]
+ set R_host($j) [srv [expr 0-$j] host]
+ set R_port($j) [srv [expr 0-$j] port]
+ if {$debug_msg} {puts "Log file: [srv [expr 0-$j] stdout]"}
+ }
+
+ set cycle 1
+ while {([clock seconds]-$start_time) < $duration} {
+ test "PSYNC2: --- CYCLE $cycle ---" {
+ incr cycle
+ }
+
+ # Create a random replication layout.
+ # Start with switching master (this simulates a failover).
+
+ # 1) Select the new master.
+ set master_id [randomInt 5]
+ set used [list $master_id]
+ test "PSYNC2: \[NEW LAYOUT\] Set #$master_id as master" {
+ $R($master_id) slaveof no one
+ if {$counter_value == 0} {
+ $R($master_id) set x $counter_value
+ }
+ }
+
+ # 2) Attach all the slaves to a random instance
+ while {[llength $used] != 5} {
+ while 1 {
+ set slave_id [randomInt 5]
+ if {[lsearch -exact $used $slave_id] == -1} break
+ }
+ set rand [randomInt [llength $used]]
+ set mid [lindex $used $rand]
+ set master_host $R_host($mid)
+ set master_port $R_port($mid)
+
+ test "PSYNC2: Set #$slave_id to replicate from #$mid" {
+ $R($slave_id) slaveof $master_host $master_port
+ }
+ lappend used $slave_id
+ }
+
+ # 3) Increment the counter and wait for all the instances
+ # to converge.
+ test "PSYNC2: cluster is consistent after failover" {
+ $R($master_id) incr x; incr counter_value
+ for {set j 0} {$j < 5} {incr j} {
+ wait_for_condition 50 1000 {
+ [$R($j) get x] == $counter_value
+ } else {
+ fail "Instance #$j x variable is inconsistent"
+ }
+ }
+ }
+
+ # 4) Generate load while breaking the connection of random
+ # slave-master pairs.
+ test "PSYNC2: generate load while killing replication links" {
+ set t [clock milliseconds]
+ set next_break [expr {$t+$disconnect_period}]
+ while {[clock milliseconds]-$t < $genload_time} {
+ if {$genload} {
+ $R($master_id) incr x; incr counter_value
+ }
+ if {[clock milliseconds] == $next_break} {
+ set next_break \
+ [expr {[clock milliseconds]+$disconnect_period}]
+ set slave_id [randomInt 5]
+ if {$disconnect} {
+ $R($slave_id) client kill type master
+ if {$debug_msg} {
+ puts "+++ Breaking link for slave #$slave_id"
+ }
+ }
+ }
+ }
+ }
+
+ # 5) Increment the counter and wait for all the instances
+ set x [$R($master_id) get x]
+ test "PSYNC2: cluster is consistent after load (x = $x)" {
+ for {set j 0} {$j < 5} {incr j} {
+ wait_for_condition 50 1000 {
+ [$R($j) get x] == $counter_value
+ } else {
+ fail "Instance #$j x variable is inconsistent"
+ }
+ }
+ }
+
+ # Put down the old master so that it cannot generate more
+ # replication stream, this way in the next master switch, the time at
+ # which we move slaves away is not important, each will have full
+ # history (otherwise PINGs will make certain slaves have more history),
+ # and sometimes a full resync will be needed.
+ $R($master_id) slaveof 127.0.0.1 0 ;# We use port zero to make it fail.
+
+ if {$debug_msg} {
+ for {set j 0} {$j < 5} {incr j} {
+ puts "$j: sync_full: [status $R($j) sync_full]"
+ puts "$j: id1 : [status $R($j) master_replid]:[status $R($j) master_repl_offset]"
+ puts "$j: id2 : [status $R($j) master_replid2]:[status $R($j) second_repl_offset]"
+ puts "$j: backlog : firstbyte=[status $R($j) repl_backlog_first_byte_offset] len=[status $R($j) repl_backlog_histlen]"
+ puts "---"
+ }
+ }
+
+ test "PSYNC2: total sum of full synchronizations is exactly 4" {
+ set sum 0
+ for {set j 0} {$j < 5} {incr j} {
+ incr sum [status $R($j) sync_full]
+ }
+ assert {$sum == 4}
+ }
+ }
+
+ test "PSYNC2: Bring the master back again for next test" {
+ $R($master_id) slaveof no one
+ set master_host $R_host($master_id)
+ set master_port $R_port($master_id)
+ for {set j 0} {$j < 5} {incr j} {
+ if {$j == $master_id} continue
+ $R($j) slaveof $master_host $master_port
+ }
+
+ # Wait for slaves to sync
+ wait_for_condition 50 1000 {
+ [status $R($master_id) connected_slaves] == 4
+ } else {
+ fail "Slave not reconnecting"
+ }
+ }
+
+ test "PSYNC2: Partial resync after restart using RDB aux fields" {
+ # Pick a random slave
+ set slave_id [expr {($master_id+1)%5}]
+ set sync_count [status $R($master_id) sync_full]
+ catch {
+ $R($slave_id) config rewrite
+ $R($slave_id) debug restart
+ }
+ wait_for_condition 50 1000 {
+ [status $R($master_id) connected_slaves] == 4
+ } else {
+ fail "Slave not reconnecting"
+ }
+ set new_sync_count [status $R($master_id) sync_full]
+ assert {$sync_count == $new_sync_count}
+ }
+
+ if {$no_exit} {
+ while 1 { puts -nonewline .; flush stdout; after 1000}
+ }
+
+}}}}}
diff --git a/tests/integration/rdb.tcl b/tests/integration/rdb.tcl
new file mode 100644
index 0000000..66aad4c
--- /dev/null
+++ b/tests/integration/rdb.tcl
@@ -0,0 +1,98 @@
+set server_path [tmpdir "server.rdb-encoding-test"]
+
+# Copy RDB with different encodings in server path
+exec cp tests/assets/encodings.rdb $server_path
+
+start_server [list overrides [list "dir" $server_path "dbfilename" "encodings.rdb"]] {
+ test "RDB encoding loading test" {
+ r select 0
+ csvdump r
+ } {"0","compressible","string","aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+"0","hash","hash","a","1","aa","10","aaa","100","b","2","bb","20","bbb","200","c","3","cc","30","ccc","300","ddd","400","eee","5000000000",
+"0","hash_zipped","hash","a","1","b","2","c","3",
+"0","list","list","1","2","3","a","b","c","100000","6000000000","1","2","3","a","b","c","100000","6000000000","1","2","3","a","b","c","100000","6000000000",
+"0","list_zipped","list","1","2","3","a","b","c","100000","6000000000",
+"0","number","string","10"
+"0","set","set","1","100000","2","3","6000000000","a","b","c",
+"0","set_zipped_1","set","1","2","3","4",
+"0","set_zipped_2","set","100000","200000","300000","400000",
+"0","set_zipped_3","set","1000000000","2000000000","3000000000","4000000000","5000000000","6000000000",
+"0","string","string","Hello World"
+"0","zset","zset","a","1","b","2","c","3","aa","10","bb","20","cc","30","aaa","100","bbb","200","ccc","300","aaaa","1000","cccc","123456789","bbbb","5000000000",
+"0","zset_zipped","zset","a","1","b","2","c","3",
+}
+}
+
+set server_path [tmpdir "server.rdb-startup-test"]
+
+start_server [list overrides [list "dir" $server_path]] {
+ test {Server started empty with non-existing RDB file} {
+ r debug digest
+ } {0000000000000000000000000000000000000000}
+ # Save an RDB file, needed for the next test.
+ r save
+}
+
+start_server [list overrides [list "dir" $server_path]] {
+ test {Server started empty with empty RDB file} {
+ r debug digest
+ } {0000000000000000000000000000000000000000}
+}
+
+# Helper function to start a server and kill it, just to check the error
+# logged.
+set defaults {}
+proc start_server_and_kill_it {overrides code} {
+ upvar defaults defaults srv srv server_path server_path
+ set config [concat $defaults $overrides]
+ set srv [start_server [list overrides $config]]
+ uplevel 1 $code
+ kill_server $srv
+}
+
+# Make the RDB file unreadable
+file attributes [file join $server_path dump.rdb] -permissions 0222
+
+# Detect root account (it is able to read the file even with 002 perm)
+set isroot 0
+catch {
+ open [file join $server_path dump.rdb]
+ set isroot 1
+}
+
+# Now make sure the server aborted with an error
+if {!$isroot} {
+ start_server_and_kill_it [list "dir" $server_path] {
+ test {Server should not start if RDB file can't be open} {
+ wait_for_condition 50 100 {
+ [string match {*Fatal error loading*} \
+ [exec tail -1 < [dict get $srv stdout]]]
+ } else {
+ fail "Server started even if RDB was unreadable!"
+ }
+ }
+ }
+}
+
+# Fix permissions of the RDB file.
+file attributes [file join $server_path dump.rdb] -permissions 0666
+
+# Corrupt its CRC64 checksum.
+set filesize [file size [file join $server_path dump.rdb]]
+set fd [open [file join $server_path dump.rdb] r+]
+fconfigure $fd -translation binary
+seek $fd -8 end
+puts -nonewline $fd "foobar00"; # Corrupt the checksum
+close $fd
+
+# Now make sure the server aborted with an error
+start_server_and_kill_it [list "dir" $server_path] {
+ test {Server should not start if RDB is corrupted} {
+ wait_for_condition 50 100 {
+ [string match {*CRC error*} \
+ [exec tail -10 < [dict get $srv stdout]]]
+ } else {
+ fail "Server started even if RDB was corrupted!"
+ }
+ }
+}
diff --git a/tests/integration/redis-cli.tcl b/tests/integration/redis-cli.tcl
new file mode 100644
index 0000000..40e4222
--- /dev/null
+++ b/tests/integration/redis-cli.tcl
@@ -0,0 +1,208 @@
+start_server {tags {"cli"}} {
+ proc open_cli {} {
+ set ::env(TERM) dumb
+ set fd [open [format "|src/redis-cli -p %d -n 9" [srv port]] "r+"]
+ fconfigure $fd -buffering none
+ fconfigure $fd -blocking false
+ fconfigure $fd -translation binary
+ assert_equal "redis> " [read_cli $fd]
+ set _ $fd
+ }
+
+ proc close_cli {fd} {
+ close $fd
+ }
+
+ proc read_cli {fd} {
+ set buf [read $fd]
+ while {[string length $buf] == 0} {
+ # wait some time and try again
+ after 10
+ set buf [read $fd]
+ }
+ set _ $buf
+ }
+
+ proc write_cli {fd buf} {
+ puts $fd $buf
+ flush $fd
+ }
+
+ # Helpers to run tests in interactive mode
+ proc run_command {fd cmd} {
+ write_cli $fd $cmd
+ set lines [split [read_cli $fd] "\n"]
+ assert_equal "redis> " [lindex $lines end]
+ join [lrange $lines 0 end-1] "\n"
+ }
+
+ proc test_interactive_cli {name code} {
+ set ::env(FAKETTY) 1
+ set fd [open_cli]
+ test "Interactive CLI: $name" $code
+ close_cli $fd
+ unset ::env(FAKETTY)
+ }
+
+ # Helpers to run tests where stdout is not a tty
+ proc write_tmpfile {contents} {
+ set tmp [tmpfile "cli"]
+ set tmpfd [open $tmp "w"]
+ puts -nonewline $tmpfd $contents
+ close $tmpfd
+ set _ $tmp
+ }
+
+ proc _run_cli {opts args} {
+ set cmd [format "src/redis-cli -p %d -n 9 $args" [srv port]]
+ foreach {key value} $opts {
+ if {$key eq "pipe"} {
+ set cmd "sh -c \"$value | $cmd\""
+ }
+ if {$key eq "path"} {
+ set cmd "$cmd < $value"
+ }
+ }
+
+ set fd [open "|$cmd" "r"]
+ fconfigure $fd -buffering none
+ fconfigure $fd -translation binary
+ set resp [read $fd 1048576]
+ close $fd
+ set _ $resp
+ }
+
+ proc run_cli {args} {
+ _run_cli {} {*}$args
+ }
+
+ proc run_cli_with_input_pipe {cmd args} {
+ _run_cli [list pipe $cmd] {*}$args
+ }
+
+ proc run_cli_with_input_file {path args} {
+ _run_cli [list path $path] {*}$args
+ }
+
+ proc test_nontty_cli {name code} {
+ test "Non-interactive non-TTY CLI: $name" $code
+ }
+
+ # Helpers to run tests where stdout is a tty (fake it)
+ proc test_tty_cli {name code} {
+ set ::env(FAKETTY) 1
+ test "Non-interactive TTY CLI: $name" $code
+ unset ::env(FAKETTY)
+ }
+
+ test_interactive_cli "INFO response should be printed raw" {
+ set lines [split [run_command $fd info] "\n"]
+ foreach line $lines {
+ assert [regexp {^[a-z0-9_]+:[a-z0-9_]+} $line]
+ }
+ }
+
+ test_interactive_cli "Status reply" {
+ assert_equal "OK" [run_command $fd "set key foo"]
+ }
+
+ test_interactive_cli "Integer reply" {
+ assert_equal "(integer) 1" [run_command $fd "incr counter"]
+ }
+
+ test_interactive_cli "Bulk reply" {
+ r set key foo
+ assert_equal "\"foo\"" [run_command $fd "get key"]
+ }
+
+ test_interactive_cli "Multi-bulk reply" {
+ r rpush list foo
+ r rpush list bar
+ assert_equal "1. \"foo\"\n2. \"bar\"" [run_command $fd "lrange list 0 -1"]
+ }
+
+ test_interactive_cli "Parsing quotes" {
+ assert_equal "OK" [run_command $fd "set key \"bar\""]
+ assert_equal "bar" [r get key]
+ assert_equal "OK" [run_command $fd "set key \" bar \""]
+ assert_equal " bar " [r get key]
+ assert_equal "OK" [run_command $fd "set key \"\\\"bar\\\"\""]
+ assert_equal "\"bar\"" [r get key]
+ assert_equal "OK" [run_command $fd "set key \"\tbar\t\""]
+ assert_equal "\tbar\t" [r get key]
+
+ # invalid quotation
+ assert_equal "Invalid argument(s)" [run_command $fd "get \"\"key"]
+ assert_equal "Invalid argument(s)" [run_command $fd "get \"key\"x"]
+
+ # quotes after the argument are weird, but should be allowed
+ assert_equal "OK" [run_command $fd "set key\"\" bar"]
+ assert_equal "bar" [r get key]
+ }
+
+ test_tty_cli "Status reply" {
+ assert_equal "OK\n" [run_cli set key bar]
+ assert_equal "bar" [r get key]
+ }
+
+ test_tty_cli "Integer reply" {
+ r del counter
+ assert_equal "(integer) 1\n" [run_cli incr counter]
+ }
+
+ test_tty_cli "Bulk reply" {
+ r set key "tab\tnewline\n"
+ assert_equal "\"tab\\tnewline\\n\"\n" [run_cli get key]
+ }
+
+ test_tty_cli "Multi-bulk reply" {
+ r del list
+ r rpush list foo
+ r rpush list bar
+ assert_equal "1. \"foo\"\n2. \"bar\"\n" [run_cli lrange list 0 -1]
+ }
+
+ test_tty_cli "Read last argument from pipe" {
+ assert_equal "OK\n" [run_cli_with_input_pipe "echo foo" set key]
+ assert_equal "foo\n" [r get key]
+ }
+
+ test_tty_cli "Read last argument from file" {
+ set tmpfile [write_tmpfile "from file"]
+ assert_equal "OK\n" [run_cli_with_input_file $tmpfile set key]
+ assert_equal "from file" [r get key]
+ }
+
+ test_nontty_cli "Status reply" {
+ assert_equal "OK" [run_cli set key bar]
+ assert_equal "bar" [r get key]
+ }
+
+ test_nontty_cli "Integer reply" {
+ r del counter
+ assert_equal "1" [run_cli incr counter]
+ }
+
+ test_nontty_cli "Bulk reply" {
+ r set key "tab\tnewline\n"
+ assert_equal "tab\tnewline\n" [run_cli get key]
+ }
+
+ test_nontty_cli "Multi-bulk reply" {
+ r del list
+ r rpush list foo
+ r rpush list bar
+ assert_equal "foo\nbar" [run_cli lrange list 0 -1]
+ }
+
+ test_nontty_cli "Read last argument from pipe" {
+ assert_equal "OK" [run_cli_with_input_pipe "echo foo" set key]
+ assert_equal "foo\n" [r get key]
+ }
+
+ test_nontty_cli "Read last argument from file" {
+ set tmpfile [write_tmpfile "from file"]
+ assert_equal "OK" [run_cli_with_input_file $tmpfile set key]
+ assert_equal "from file" [r get key]
+ }
+}
diff --git a/tests/integration/replication-2.tcl b/tests/integration/replication-2.tcl
new file mode 100644
index 0000000..9446e5c
--- /dev/null
+++ b/tests/integration/replication-2.tcl
@@ -0,0 +1,87 @@
+start_server {tags {"repl"}} {
+ start_server {} {
+ test {First server should have role slave after SLAVEOF} {
+ r -1 slaveof [srv 0 host] [srv 0 port]
+ after 1000
+ s -1 role
+ } {slave}
+
+ test {If min-slaves-to-write is honored, write is accepted} {
+ r config set min-slaves-to-write 1
+ r config set min-slaves-max-lag 10
+ r set foo 12345
+ wait_for_condition 50 100 {
+ [r -1 get foo] eq {12345}
+ } else {
+ fail "Write did not reached slave"
+ }
+ }
+
+ test {No write if min-slaves-to-write is < attached slaves} {
+ r config set min-slaves-to-write 2
+ r config set min-slaves-max-lag 10
+ catch {r set foo 12345} err
+ set err
+ } {NOREPLICAS*}
+
+ test {If min-slaves-to-write is honored, write is accepted (again)} {
+ r config set min-slaves-to-write 1
+ r config set min-slaves-max-lag 10
+ r set foo 12345
+ wait_for_condition 50 100 {
+ [r -1 get foo] eq {12345}
+ } else {
+ fail "Write did not reached slave"
+ }
+ }
+
+ test {No write if min-slaves-max-lag is > of the slave lag} {
+ r -1 deferred 1
+ r config set min-slaves-to-write 1
+ r config set min-slaves-max-lag 2
+ r -1 debug sleep 6
+ assert {[r set foo 12345] eq {OK}}
+ after 4000
+ catch {r set foo 12345} err
+ assert {[r -1 read] eq {OK}}
+ r -1 deferred 0
+ set err
+ } {NOREPLICAS*}
+
+ test {min-slaves-to-write is ignored by slaves} {
+ r config set min-slaves-to-write 1
+ r config set min-slaves-max-lag 10
+ r -1 config set min-slaves-to-write 1
+ r -1 config set min-slaves-max-lag 10
+ r set foo aaabbb
+ wait_for_condition 50 100 {
+ [r -1 get foo] eq {aaabbb}
+ } else {
+ fail "Write did not reached slave"
+ }
+ }
+
+ # Fix parameters for the next test to work
+ r config set min-slaves-to-write 0
+ r -1 config set min-slaves-to-write 0
+ r flushall
+
+ test {MASTER and SLAVE dataset should be identical after complex ops} {
+ createComplexDataset r 10000
+ after 500
+ if {[r debug digest] ne [r -1 debug digest]} {
+ set csv1 [csvdump r]
+ set csv2 [csvdump {r -1}]
+ set fd [open /tmp/repldump1.txt w]
+ puts -nonewline $fd $csv1
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts -nonewline $fd $csv2
+ close $fd
+ puts "Master - Slave inconsistency"
+ puts "Run diff -u against /tmp/repldump*.txt for more info"
+ }
+ assert_equal [r debug digest] [r -1 debug digest]
+ }
+ }
+}
diff --git a/tests/integration/replication-3.tcl b/tests/integration/replication-3.tcl
new file mode 100644
index 0000000..50dcb9a
--- /dev/null
+++ b/tests/integration/replication-3.tcl
@@ -0,0 +1,113 @@
+start_server {tags {"repl"}} {
+ start_server {} {
+ test {First server should have role slave after SLAVEOF} {
+ r -1 slaveof [srv 0 host] [srv 0 port]
+ wait_for_condition 50 100 {
+ [s -1 master_link_status] eq {up}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ if {$::accurate} {set numops 50000} else {set numops 5000}
+
+ test {MASTER and SLAVE consistency with expire} {
+ createComplexDataset r $numops useexpire
+ after 4000 ;# Make sure everything expired before taking the digest
+ r keys * ;# Force DEL syntesizing to slave
+ after 1000 ;# Wait another second. Now everything should be fine.
+ if {[r debug digest] ne [r -1 debug digest]} {
+ set csv1 [csvdump r]
+ set csv2 [csvdump {r -1}]
+ set fd [open /tmp/repldump1.txt w]
+ puts -nonewline $fd $csv1
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts -nonewline $fd $csv2
+ close $fd
+ puts "Master - Slave inconsistency"
+ puts "Run diff -u against /tmp/repldump*.txt for more info"
+ }
+ assert_equal [r debug digest] [r -1 debug digest]
+ }
+
+ test {Slave is able to evict keys created in writable slaves} {
+ r -1 select 5
+ assert {[r -1 dbsize] == 0}
+ r -1 config set slave-read-only no
+ r -1 set key1 1 ex 5
+ r -1 set key2 2 ex 5
+ r -1 set key3 3 ex 5
+ assert {[r -1 dbsize] == 3}
+ after 6000
+ r -1 dbsize
+ } {0}
+ }
+}
+
+start_server {tags {"repl"}} {
+ start_server {} {
+ test {First server should have role slave after SLAVEOF} {
+ r -1 slaveof [srv 0 host] [srv 0 port]
+ wait_for_condition 50 100 {
+ [s -1 master_link_status] eq {up}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ set numops 20000 ;# Enough to trigger the Script Cache LRU eviction.
+
+ # While we are at it, enable AOF to test it will be consistent as well
+ # after the test.
+ r config set appendonly yes
+
+ test {MASTER and SLAVE consistency with EVALSHA replication} {
+ array set oldsha {}
+ for {set j 0} {$j < $numops} {incr j} {
+ set key "key:$j"
+ # Make sure to create scripts that have different SHA1s
+ set script "return redis.call('incr','$key')"
+ set sha1 [r eval "return redis.sha1hex(\"$script\")" 0]
+ set oldsha($j) $sha1
+ r eval $script 0
+ set res [r evalsha $sha1 0]
+ assert {$res == 2}
+ # Additionally call one of the old scripts as well, at random.
+ set res [r evalsha $oldsha([randomInt $j]) 0]
+ assert {$res > 2}
+
+ # Trigger an AOF rewrite while we are half-way, this also
+ # forces the flush of the script cache, and we will cover
+ # more code as a result.
+ if {$j == $numops / 2} {
+ catch {r bgrewriteaof}
+ }
+ }
+
+ wait_for_condition 50 100 {
+ [r dbsize] == $numops &&
+ [r -1 dbsize] == $numops &&
+ [r debug digest] eq [r -1 debug digest]
+ } else {
+ set csv1 [csvdump r]
+ set csv2 [csvdump {r -1}]
+ set fd [open /tmp/repldump1.txt w]
+ puts -nonewline $fd $csv1
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts -nonewline $fd $csv2
+ close $fd
+ puts "Master - Slave inconsistency"
+ puts "Run diff -u against /tmp/repldump*.txt for more info"
+
+ }
+
+ set old_digest [r debug digest]
+ r config set appendonly no
+ r debug loadaof
+ set new_digest [r debug digest]
+ assert {$old_digest eq $new_digest}
+ }
+ }
+}
diff --git a/tests/integration/replication-4.tcl b/tests/integration/replication-4.tcl
new file mode 100644
index 0000000..1c559b7
--- /dev/null
+++ b/tests/integration/replication-4.tcl
@@ -0,0 +1,155 @@
+proc start_bg_complex_data {host port db ops} {
+ set tclsh [info nameofexecutable]
+ exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops &
+}
+
+proc stop_bg_complex_data {handle} {
+ catch {exec /bin/kill -9 $handle}
+}
+
+start_server {tags {"repl"}} {
+ start_server {} {
+
+ set master [srv -1 client]
+ set master_host [srv -1 host]
+ set master_port [srv -1 port]
+ set slave [srv 0 client]
+
+ set load_handle0 [start_bg_complex_data $master_host $master_port 9 100000]
+ set load_handle1 [start_bg_complex_data $master_host $master_port 11 100000]
+ set load_handle2 [start_bg_complex_data $master_host $master_port 12 100000]
+
+ test {First server should have role slave after SLAVEOF} {
+ $slave slaveof $master_host $master_port
+ after 1000
+ s 0 role
+ } {slave}
+
+ test {Test replication with parallel clients writing in differnet DBs} {
+ after 5000
+ stop_bg_complex_data $load_handle0
+ stop_bg_complex_data $load_handle1
+ stop_bg_complex_data $load_handle2
+ set retry 10
+ while {$retry && ([$master debug digest] ne [$slave debug digest])}\
+ {
+ after 1000
+ incr retry -1
+ }
+ assert {[$master dbsize] > 0}
+
+ if {[$master debug digest] ne [$slave debug digest]} {
+ set csv1 [csvdump r]
+ set csv2 [csvdump {r -1}]
+ set fd [open /tmp/repldump1.txt w]
+ puts -nonewline $fd $csv1
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts -nonewline $fd $csv2
+ close $fd
+ puts "Master - Slave inconsistency"
+ puts "Run diff -u against /tmp/repldump*.txt for more info"
+ }
+ assert_equal [r debug digest] [r -1 debug digest]
+ }
+ }
+}
+
+start_server {tags {"repl"}} {
+ start_server {} {
+ set master [srv -1 client]
+ set master_host [srv -1 host]
+ set master_port [srv -1 port]
+ set slave [srv 0 client]
+
+ test {First server should have role slave after SLAVEOF} {
+ $slave slaveof $master_host $master_port
+ wait_for_condition 50 100 {
+ [s 0 master_link_status] eq {up}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ test {With min-slaves-to-write (1,3): master should be writable} {
+ $master config set min-slaves-max-lag 3
+ $master config set min-slaves-to-write 1
+ $master set foo bar
+ } {OK}
+
+ test {With min-slaves-to-write (2,3): master should not be writable} {
+ $master config set min-slaves-max-lag 3
+ $master config set min-slaves-to-write 2
+ catch {$master set foo bar} e
+ set e
+ } {NOREPLICAS*}
+
+ test {With min-slaves-to-write: master not writable with lagged slave} {
+ $master config set min-slaves-max-lag 2
+ $master config set min-slaves-to-write 1
+ assert {[$master set foo bar] eq {OK}}
+ $slave deferred 1
+ $slave debug sleep 6
+ after 4000
+ catch {$master set foo bar} e
+ set e
+ } {NOREPLICAS*}
+ }
+}
+
+start_server {tags {"repl"}} {
+ start_server {} {
+ set master [srv -1 client]
+ set master_host [srv -1 host]
+ set master_port [srv -1 port]
+ set slave [srv 0 client]
+
+ test {First server should have role slave after SLAVEOF} {
+ $slave slaveof $master_host $master_port
+ wait_for_condition 50 100 {
+ [s 0 role] eq {slave}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ test {Replication: commands with many arguments (issue #1221)} {
+ # We now issue large MSET commands, that may trigger a specific
+ # class of bugs, see issue #1221.
+ for {set j 0} {$j < 100} {incr j} {
+ set cmd [list mset]
+ for {set x 0} {$x < 1000} {incr x} {
+ lappend cmd [randomKey] [randomValue]
+ }
+ $master {*}$cmd
+ }
+
+ set retry 10
+ while {$retry && ([$master debug digest] ne [$slave debug digest])}\
+ {
+ after 1000
+ incr retry -1
+ }
+ assert {[$master dbsize] > 0}
+ }
+
+ test {Replication of SPOP command -- alsoPropagate() API} {
+ $master del myset
+ set size [expr 1+[randomInt 100]]
+ set content {}
+ for {set j 0} {$j < $size} {incr j} {
+ lappend content [randomValue]
+ }
+ $master sadd myset {*}$content
+
+ set count [randomInt 100]
+ set result [$master spop myset $count]
+
+ wait_for_condition 50 100 {
+ [$master debug digest] eq [$slave debug digest]
+ } else {
+ fail "SPOP replication inconsistency"
+ }
+ }
+ }
+}
diff --git a/tests/integration/replication-psync.tcl b/tests/integration/replication-psync.tcl
new file mode 100644
index 0000000..da1e9cf
--- /dev/null
+++ b/tests/integration/replication-psync.tcl
@@ -0,0 +1,128 @@
+proc start_bg_complex_data {host port db ops} {
+ set tclsh [info nameofexecutable]
+ exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops &
+}
+
+proc stop_bg_complex_data {handle} {
+ catch {exec /bin/kill -9 $handle}
+}
+
+# Creates a master-slave pair and breaks the link continuously to force
+# partial resyncs attempts, all this while flooding the master with
+# write queries.
+#
+# You can specifiy backlog size, ttl, delay before reconnection, test duration
+# in seconds, and an additional condition to verify at the end.
+#
+# If reconnect is > 0, the test actually try to break the connection and
+# reconnect with the master, otherwise just the initial synchronization is
+# checked for consistency.
+proc test_psync {descr duration backlog_size backlog_ttl delay cond diskless reconnect} {
+ start_server {tags {"repl"}} {
+ start_server {} {
+
+ set master [srv -1 client]
+ set master_host [srv -1 host]
+ set master_port [srv -1 port]
+ set slave [srv 0 client]
+
+ $master config set repl-backlog-size $backlog_size
+ $master config set repl-backlog-ttl $backlog_ttl
+ $master config set repl-diskless-sync $diskless
+ $master config set repl-diskless-sync-delay 1
+
+ set load_handle0 [start_bg_complex_data $master_host $master_port 9 100000]
+ set load_handle1 [start_bg_complex_data $master_host $master_port 11 100000]
+ set load_handle2 [start_bg_complex_data $master_host $master_port 12 100000]
+
+ test {Slave should be able to synchronize with the master} {
+ $slave slaveof $master_host $master_port
+ wait_for_condition 50 100 {
+ [lindex [r role] 0] eq {slave} &&
+ [lindex [r role] 3] eq {connected}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ # Check that the background clients are actually writing.
+ test {Detect write load to master} {
+ wait_for_condition 50 1000 {
+ [$master dbsize] > 100
+ } else {
+ fail "Can't detect write load from background clients."
+ }
+ }
+
+ test "Test replication partial resync: $descr (diskless: $diskless, reconnect: $reconnect)" {
+ # Now while the clients are writing data, break the maste-slave
+ # link multiple times.
+ if ($reconnect) {
+ for {set j 0} {$j < $duration*10} {incr j} {
+ after 100
+ # catch {puts "MASTER [$master dbsize] keys, SLAVE [$slave dbsize] keys"}
+
+ if {($j % 20) == 0} {
+ catch {
+ if {$delay} {
+ $slave multi
+ $slave client kill $master_host:$master_port
+ $slave debug sleep $delay
+ $slave exec
+ } else {
+ $slave client kill $master_host:$master_port
+ }
+ }
+ }
+ }
+ }
+ stop_bg_complex_data $load_handle0
+ stop_bg_complex_data $load_handle1
+ stop_bg_complex_data $load_handle2
+ set retry 10
+ while {$retry && ([$master debug digest] ne [$slave debug digest])}\
+ {
+ after 1000
+ incr retry -1
+ }
+ assert {[$master dbsize] > 0}
+
+ if {[$master debug digest] ne [$slave debug digest]} {
+ set csv1 [csvdump r]
+ set csv2 [csvdump {r -1}]
+ set fd [open /tmp/repldump1.txt w]
+ puts -nonewline $fd $csv1
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts -nonewline $fd $csv2
+ close $fd
+ puts "Master - Slave inconsistency"
+ puts "Run diff -u against /tmp/repldump*.txt for more info"
+ }
+ assert_equal [r debug digest] [r -1 debug digest]
+ eval $cond
+ }
+ }
+ }
+}
+
+foreach diskless {no yes} {
+ test_psync {no reconnection, just sync} 6 1000000 3600 0 {
+ } $diskless 0
+
+ test_psync {ok psync} 6 1000000 3600 0 {
+ assert {[s -1 sync_partial_ok] > 0}
+ } $diskless 1
+
+ test_psync {no backlog} 6 100 3600 0.5 {
+ assert {[s -1 sync_partial_err] > 0}
+ } $diskless 1
+
+ test_psync {ok after delay} 3 100000000 3600 3 {
+ assert {[s -1 sync_partial_ok] > 0}
+ } $diskless 1
+
+ test_psync {backlog expired} 3 100000000 1 3 {
+ assert {[s -1 sync_partial_err] > 0}
+ } $diskless 1
+}
diff --git a/tests/integration/replication.tcl b/tests/integration/replication.tcl
new file mode 100644
index 0000000..e811cf0
--- /dev/null
+++ b/tests/integration/replication.tcl
@@ -0,0 +1,268 @@
+proc log_file_matches {log pattern} {
+ set fp [open $log r]
+ set content [read $fp]
+ close $fp
+ string match $pattern $content
+}
+
+start_server {tags {"repl"}} {
+ set slave [srv 0 client]
+ set slave_host [srv 0 host]
+ set slave_port [srv 0 port]
+ set slave_log [srv 0 stdout]
+ start_server {} {
+ set master [srv 0 client]
+ set master_host [srv 0 host]
+ set master_port [srv 0 port]
+
+ # Configure the master in order to hang waiting for the BGSAVE
+ # operation, so that the slave remains in the handshake state.
+ $master config set repl-diskless-sync yes
+ $master config set repl-diskless-sync-delay 1000
+
+ # Use a short replication timeout on the slave, so that if there
+ # are no bugs the timeout is triggered in a reasonable amount
+ # of time.
+ $slave config set repl-timeout 5
+
+ # Start the replication process...
+ $slave slaveof $master_host $master_port
+
+ test {Slave enters handshake} {
+ wait_for_condition 50 1000 {
+ [string match *handshake* [$slave role]]
+ } else {
+ fail "Slave does not enter handshake state"
+ }
+ }
+
+ # But make the master unable to send
+ # the periodic newlines to refresh the connection. The slave
+ # should detect the timeout.
+ $master debug sleep 10
+
+ test {Slave is able to detect timeout during handshake} {
+ wait_for_condition 50 1000 {
+ [log_file_matches $slave_log "*Timeout connecting to the MASTER*"]
+ } else {
+ fail "Slave is not able to detect timeout"
+ }
+ }
+ }
+}
+
+start_server {tags {"repl"}} {
+ set A [srv 0 client]
+ set A_host [srv 0 host]
+ set A_port [srv 0 port]
+ start_server {} {
+ set B [srv 0 client]
+ set B_host [srv 0 host]
+ set B_port [srv 0 port]
+
+ test {Set instance A as slave of B} {
+ $A slaveof $B_host $B_port
+ wait_for_condition 50 100 {
+ [lindex [$A role] 0] eq {slave} &&
+ [string match {*master_link_status:up*} [$A info replication]]
+ } else {
+ fail "Can't turn the instance into a slave"
+ }
+ }
+
+ test {BRPOPLPUSH replication, when blocking against empty list} {
+ set rd [redis_deferring_client]
+ $rd brpoplpush a b 5
+ r lpush a foo
+ wait_for_condition 50 100 {
+ [$A debug digest] eq [$B debug digest]
+ } else {
+ fail "Master and slave have different digest: [$A debug digest] VS [$B debug digest]"
+ }
+ }
+
+ test {BRPOPLPUSH replication, list exists} {
+ set rd [redis_deferring_client]
+ r lpush c 1
+ r lpush c 2
+ r lpush c 3
+ $rd brpoplpush c d 5
+ after 1000
+ assert_equal [$A debug digest] [$B debug digest]
+ }
+
+ test {BLPOP followed by role change, issue #2473} {
+ set rd [redis_deferring_client]
+ $rd blpop foo 0 ; # Block while B is a master
+
+ # Turn B into master of A
+ $A slaveof no one
+ $B slaveof $A_host $A_port
+ wait_for_condition 50 100 {
+ [lindex [$B role] 0] eq {slave} &&
+ [string match {*master_link_status:up*} [$B info replication]]
+ } else {
+ fail "Can't turn the instance into a slave"
+ }
+
+ # Push elements into the "foo" list of the new slave.
+ # If the client is still attached to the instance, we'll get
+ # a desync between the two instances.
+ $A rpush foo a b c
+ after 100
+
+ wait_for_condition 50 100 {
+ [$A debug digest] eq [$B debug digest] &&
+ [$A lrange foo 0 -1] eq {a b c} &&
+ [$B lrange foo 0 -1] eq {a b c}
+ } else {
+ fail "Master and slave have different digest: [$A debug digest] VS [$B debug digest]"
+ }
+ }
+ }
+}
+
+start_server {tags {"repl"}} {
+ r set mykey foo
+
+ start_server {} {
+ test {Second server should have role master at first} {
+ s role
+ } {master}
+
+ test {SLAVEOF should start with link status "down"} {
+ r slaveof [srv -1 host] [srv -1 port]
+ s master_link_status
+ } {down}
+
+ test {The role should immediately be changed to "slave"} {
+ s role
+ } {slave}
+
+ wait_for_sync r
+ test {Sync should have transferred keys from master} {
+ r get mykey
+ } {foo}
+
+ test {The link status should be up} {
+ s master_link_status
+ } {up}
+
+ test {SET on the master should immediately propagate} {
+ r -1 set mykey bar
+
+ wait_for_condition 500 100 {
+ [r 0 get mykey] eq {bar}
+ } else {
+ fail "SET on master did not propagated on slave"
+ }
+ }
+
+ test {FLUSHALL should replicate} {
+ r -1 flushall
+ if {$::valgrind} {after 2000}
+ list [r -1 dbsize] [r 0 dbsize]
+ } {0 0}
+
+ test {ROLE in master reports master with a slave} {
+ set res [r -1 role]
+ lassign $res role offset slaves
+ assert {$role eq {master}}
+ assert {$offset > 0}
+ assert {[llength $slaves] == 1}
+ lassign [lindex $slaves 0] master_host master_port slave_offset
+ assert {$slave_offset <= $offset}
+ }
+
+ test {ROLE in slave reports slave in connected state} {
+ set res [r role]
+ lassign $res role master_host master_port slave_state slave_offset
+ assert {$role eq {slave}}
+ assert {$slave_state eq {connected}}
+ }
+ }
+}
+
+foreach dl {no yes} {
+ start_server {tags {"repl"}} {
+ set master [srv 0 client]
+ $master config set repl-diskless-sync $dl
+ set master_host [srv 0 host]
+ set master_port [srv 0 port]
+ set slaves {}
+ set load_handle0 [start_write_load $master_host $master_port 3]
+ set load_handle1 [start_write_load $master_host $master_port 5]
+ set load_handle2 [start_write_load $master_host $master_port 20]
+ set load_handle3 [start_write_load $master_host $master_port 8]
+ set load_handle4 [start_write_load $master_host $master_port 4]
+ start_server {} {
+ lappend slaves [srv 0 client]
+ start_server {} {
+ lappend slaves [srv 0 client]
+ start_server {} {
+ lappend slaves [srv 0 client]
+ test "Connect multiple slaves at the same time (issue #141), diskless=$dl" {
+ # Send SLAVEOF commands to slaves
+ [lindex $slaves 0] slaveof $master_host $master_port
+ [lindex $slaves 1] slaveof $master_host $master_port
+ [lindex $slaves 2] slaveof $master_host $master_port
+
+ # Wait for all the three slaves to reach the "online"
+ # state from the POV of the master.
+ set retry 500
+ while {$retry} {
+ set info [r -3 info]
+ if {[string match {*slave0:*state=online*slave1:*state=online*slave2:*state=online*} $info]} {
+ break
+ } else {
+ incr retry -1
+ after 100
+ }
+ }
+ if {$retry == 0} {
+ error "assertion:Slaves not correctly synchronized"
+ }
+
+ # Wait that slaves acknowledge they are online so
+ # we are sure that DBSIZE and DEBUG DIGEST will not
+ # fail because of timing issues.
+ wait_for_condition 500 100 {
+ [lindex [[lindex $slaves 0] role] 3] eq {connected} &&
+ [lindex [[lindex $slaves 1] role] 3] eq {connected} &&
+ [lindex [[lindex $slaves 2] role] 3] eq {connected}
+ } else {
+ fail "Slaves still not connected after some time"
+ }
+
+ # Stop the write load
+ stop_write_load $load_handle0
+ stop_write_load $load_handle1
+ stop_write_load $load_handle2
+ stop_write_load $load_handle3
+ stop_write_load $load_handle4
+
+ # Make sure that slaves and master have same
+ # number of keys
+ wait_for_condition 500 100 {
+ [$master dbsize] == [[lindex $slaves 0] dbsize] &&
+ [$master dbsize] == [[lindex $slaves 1] dbsize] &&
+ [$master dbsize] == [[lindex $slaves 2] dbsize]
+ } else {
+ fail "Different number of keys between masted and slave after too long time."
+ }
+
+ # Check digests
+ set digest [$master debug digest]
+ set digest0 [[lindex $slaves 0] debug digest]
+ set digest1 [[lindex $slaves 1] debug digest]
+ set digest2 [[lindex $slaves 2] debug digest]
+ assert {$digest ne 0000000000000000000000000000000000000000}
+ assert {$digest eq $digest0}
+ assert {$digest eq $digest1}
+ assert {$digest eq $digest2}
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/tests/sentinel/run.tcl b/tests/sentinel/run.tcl
new file mode 100644
index 0000000..9a2fcfb
--- /dev/null
+++ b/tests/sentinel/run.tcl
@@ -0,0 +1,23 @@
+# Sentinel test suite. Copyright (C) 2014 Salvatore Sanfilippo [email protected]
+# This software is released under the BSD License. See the COPYING file for
+# more information.
+
+cd tests/sentinel
+source ../instances.tcl
+
+set ::instances_count 5 ; # How many instances we use at max.
+
+proc main {} {
+ parse_options
+ spawn_instance sentinel $::sentinel_base_port $::instances_count
+ spawn_instance redis $::redis_base_port $::instances_count
+ run_tests
+ cleanup
+ end_tests
+}
+
+if {[catch main e]} {
+ puts $::errorInfo
+ cleanup
+ exit 1
+}
diff --git a/tests/sentinel/tests/00-base.tcl b/tests/sentinel/tests/00-base.tcl
new file mode 100644
index 0000000..a79d0c3
--- /dev/null
+++ b/tests/sentinel/tests/00-base.tcl
@@ -0,0 +1,126 @@
+# Check the basic monitoring and failover capabilities.
+
+source "../tests/includes/init-tests.tcl"
+
+if {$::simulate_error} {
+ test "This test will fail" {
+ fail "Simulated error"
+ }
+}
+
+test "Basic failover works if the master is down" {
+ set old_port [RI $master_id tcp_port]
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ kill_instance redis $master_id
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [lindex [S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "At least one Sentinel did not received failover info"
+ }
+ }
+ restart_instance redis $master_id
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ set master_id [get_instance_id_by_port redis [lindex $addr 1]]
+}
+
+test "New master [join $addr {:}] role matches" {
+ assert {[RI $master_id role] eq {master}}
+}
+
+test "All the other slaves now point to the new master" {
+ foreach_redis_id id {
+ if {$id != $master_id && $id != 0} {
+ wait_for_condition 1000 50 {
+ [RI $id master_port] == [lindex $addr 1]
+ } else {
+ fail "Redis ID $id not configured to replicate with new master"
+ }
+ }
+ }
+}
+
+test "The old master eventually gets reconfigured as a slave" {
+ wait_for_condition 1000 50 {
+ [RI 0 master_port] == [lindex $addr 1]
+ } else {
+ fail "Old master not reconfigured as slave of new master"
+ }
+}
+
+test "ODOWN is not possible without N (quorum) Sentinels reports" {
+ foreach_sentinel_id id {
+ S $id SENTINEL SET mymaster quorum [expr $sentinels+1]
+ }
+ set old_port [RI $master_id tcp_port]
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ kill_instance redis $master_id
+
+ # Make sure failover did not happened.
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ restart_instance redis $master_id
+}
+
+test "Failover is not possible without majority agreement" {
+ foreach_sentinel_id id {
+ S $id SENTINEL SET mymaster quorum $quorum
+ }
+
+ # Crash majority of sentinels
+ for {set id 0} {$id < $quorum} {incr id} {
+ kill_instance sentinel $id
+ }
+
+ # Kill the current master
+ kill_instance redis $master_id
+
+ # Make sure failover did not happened.
+ set addr [S $quorum SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ restart_instance redis $master_id
+
+ # Cleanup: restart Sentinels to monitor the master.
+ for {set id 0} {$id < $quorum} {incr id} {
+ restart_instance sentinel $id
+ }
+}
+
+test "Failover works if we configure for absolute agreement" {
+ foreach_sentinel_id id {
+ S $id SENTINEL SET mymaster quorum $sentinels
+ }
+
+ # Wait for Sentinels to monitor the master again
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [dict get [S $id SENTINEL MASTER mymaster] info-refresh] < 100000
+ } else {
+ fail "At least one Sentinel is not monitoring the master"
+ }
+ }
+
+ kill_instance redis $master_id
+
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [lindex [S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "At least one Sentinel did not received failover info"
+ }
+ }
+ restart_instance redis $master_id
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ set master_id [get_instance_id_by_port redis [lindex $addr 1]]
+
+ # Set the min ODOWN agreement back to strict majority.
+ foreach_sentinel_id id {
+ S $id SENTINEL SET mymaster quorum $quorum
+ }
+}
+
+test "New master [join $addr {:}] role matches" {
+ assert {[RI $master_id role] eq {master}}
+}
diff --git a/tests/sentinel/tests/01-conf-update.tcl b/tests/sentinel/tests/01-conf-update.tcl
new file mode 100644
index 0000000..4998104
--- /dev/null
+++ b/tests/sentinel/tests/01-conf-update.tcl
@@ -0,0 +1,39 @@
+# Test Sentinel configuration consistency after partitions heal.
+
+source "../tests/includes/init-tests.tcl"
+
+test "We can failover with Sentinel 1 crashed" {
+ set old_port [RI $master_id tcp_port]
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+
+ # Crash Sentinel 1
+ kill_instance sentinel 1
+
+ kill_instance redis $master_id
+ foreach_sentinel_id id {
+ if {$id != 1} {
+ wait_for_condition 1000 50 {
+ [lindex [S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "Sentinel $id did not received failover info"
+ }
+ }
+ }
+ restart_instance redis $master_id
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ set master_id [get_instance_id_by_port redis [lindex $addr 1]]
+}
+
+test "After Sentinel 1 is restarted, its config gets updated" {
+ restart_instance sentinel 1
+ wait_for_condition 1000 50 {
+ [lindex [S 1 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "Restarted Sentinel did not received failover info"
+ }
+}
+
+test "New master [join $addr {:}] role matches" {
+ assert {[RI $master_id role] eq {master}}
+}
diff --git a/tests/sentinel/tests/02-slaves-reconf.tcl b/tests/sentinel/tests/02-slaves-reconf.tcl
new file mode 100644
index 0000000..fa15d2e
--- /dev/null
+++ b/tests/sentinel/tests/02-slaves-reconf.tcl
@@ -0,0 +1,84 @@
+# Check that slaves are reconfigured at a latter time if they are partitioned.
+#
+# Here we should test:
+# 1) That slaves point to the new master after failover.
+# 2) That partitioned slaves point to new master when they are partitioned
+# away during failover and return at a latter time.
+
+source "../tests/includes/init-tests.tcl"
+
+proc 02_test_slaves_replication {} {
+ uplevel 1 {
+ test "Check that slaves replicate from current master" {
+ set master_port [RI $master_id tcp_port]
+ foreach_redis_id id {
+ if {$id == $master_id} continue
+ if {[instance_is_killed redis $id]} continue
+ wait_for_condition 1000 50 {
+ ([RI $id master_port] == $master_port) &&
+ ([RI $id master_link_status] eq {up})
+ } else {
+ fail "Redis slave $id is replicating from wrong master"
+ }
+ }
+ }
+ }
+}
+
+proc 02_crash_and_failover {} {
+ uplevel 1 {
+ test "Crash the master and force a failover" {
+ set old_port [RI $master_id tcp_port]
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ kill_instance redis $master_id
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [lindex [S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "At least one Sentinel did not received failover info"
+ }
+ }
+ restart_instance redis $master_id
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ set master_id [get_instance_id_by_port redis [lindex $addr 1]]
+ }
+ }
+}
+
+02_test_slaves_replication
+02_crash_and_failover
+02_test_slaves_replication
+
+test "Kill a slave instance" {
+ foreach_redis_id id {
+ if {$id == $master_id} continue
+ set killed_slave_id $id
+ kill_instance redis $id
+ break
+ }
+}
+
+02_crash_and_failover
+02_test_slaves_replication
+
+test "Wait for failover to end" {
+ set inprogress 1
+ while {$inprogress} {
+ set inprogress 0
+ foreach_sentinel_id id {
+ if {[dict exists [S $id SENTINEL MASTER mymaster] failover-state]} {
+ incr inprogress
+ }
+ }
+ if {$inprogress} {after 100}
+ }
+}
+
+test "Restart killed slave and test replication of slaves again..." {
+ restart_instance redis $killed_slave_id
+}
+
+# Now we check if the slave rejoining the partition is reconfigured even
+# if the failover finished.
+02_test_slaves_replication
diff --git a/tests/sentinel/tests/03-runtime-reconf.tcl b/tests/sentinel/tests/03-runtime-reconf.tcl
new file mode 100644
index 0000000..426596c
--- /dev/null
+++ b/tests/sentinel/tests/03-runtime-reconf.tcl
@@ -0,0 +1 @@
+# Test runtime reconfiguration command SENTINEL SET.
diff --git a/tests/sentinel/tests/04-slave-selection.tcl b/tests/sentinel/tests/04-slave-selection.tcl
new file mode 100644
index 0000000..3d2ca64
--- /dev/null
+++ b/tests/sentinel/tests/04-slave-selection.tcl
@@ -0,0 +1,5 @@
+# Test slave selection algorithm.
+#
+# This unit should test:
+# 1) That when there are no suitable slaves no failover is performed.
+# 2) That among the available slaves, the one with better offset is picked.
diff --git a/tests/sentinel/tests/05-manual.tcl b/tests/sentinel/tests/05-manual.tcl
new file mode 100644
index 0000000..5214fdc
--- /dev/null
+++ b/tests/sentinel/tests/05-manual.tcl
@@ -0,0 +1,45 @@
+# Test manual failover
+
+source "../tests/includes/init-tests.tcl"
+
+test "Manual failover works" {
+ set old_port [RI $master_id tcp_port]
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ assert {[lindex $addr 1] == $old_port}
+ catch {S 0 SENTINEL FAILOVER mymaster} reply
+ assert {$reply eq "OK"}
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [lindex [S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] 1] != $old_port
+ } else {
+ fail "At least one Sentinel did not received failover info"
+ }
+ }
+ set addr [S 0 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster]
+ set master_id [get_instance_id_by_port redis [lindex $addr 1]]
+}
+
+test "New master [join $addr {:}] role matches" {
+ assert {[RI $master_id role] eq {master}}
+}
+
+test "All the other slaves now point to the new master" {
+ foreach_redis_id id {
+ if {$id != $master_id && $id != 0} {
+ wait_for_condition 1000 50 {
+ [RI $id master_port] == [lindex $addr 1]
+ } else {
+ fail "Redis ID $id not configured to replicate with new master"
+ }
+ }
+ }
+}
+
+test "The old master eventually gets reconfigured as a slave" {
+ wait_for_condition 1000 50 {
+ [RI 0 master_port] == [lindex $addr 1]
+ } else {
+ fail "Old master not reconfigured as slave of new master"
+ }
+}
+
diff --git a/tests/sentinel/tests/06-ckquorum.tcl b/tests/sentinel/tests/06-ckquorum.tcl
new file mode 100644
index 0000000..31e5fa2
--- /dev/null
+++ b/tests/sentinel/tests/06-ckquorum.tcl
@@ -0,0 +1,34 @@
+# Test for the SENTINEL CKQUORUM command
+
+source "../tests/includes/init-tests.tcl"
+set num_sentinels [llength $::sentinel_instances]
+
+test "CKQUORUM reports OK and the right amount of Sentinels" {
+ foreach_sentinel_id id {
+ assert_match "*OK $num_sentinels usable*" [S $id SENTINEL CKQUORUM mymaster]
+ }
+}
+
+test "CKQUORUM detects quorum cannot be reached" {
+ set orig_quorum [expr {$num_sentinels/2+1}]
+ S 0 SENTINEL SET mymaster quorum [expr {$num_sentinels+1}]
+ catch {[S 0 SENTINEL CKQUORUM mymaster]} err
+ assert_match "*NOQUORUM*" $err
+ S 0 SENTINEL SET mymaster quorum $orig_quorum
+}
+
+test "CKQUORUM detects failover authorization cannot be reached" {
+ set orig_quorum [expr {$num_sentinels/2+1}]
+ S 0 SENTINEL SET mymaster quorum 1
+ kill_instance sentinel 1
+ kill_instance sentinel 2
+ kill_instance sentinel 3
+ after 5000
+ catch {[S 0 SENTINEL CKQUORUM mymaster]} err
+ assert_match "*NOQUORUM*" $err
+ S 0 SENTINEL SET mymaster quorum $orig_quorum
+ restart_instance sentinel 1
+ restart_instance sentinel 2
+ restart_instance sentinel 3
+}
+
diff --git a/tests/sentinel/tests/07-down-conditions.tcl b/tests/sentinel/tests/07-down-conditions.tcl
new file mode 100644
index 0000000..a60656e
--- /dev/null
+++ b/tests/sentinel/tests/07-down-conditions.tcl
@@ -0,0 +1,68 @@
+# Test conditions where an instance is considered to be down
+
+source "../tests/includes/init-tests.tcl"
+
+proc ensure_master_up {} {
+ wait_for_condition 1000 50 {
+ [dict get [S 4 sentinel master mymaster] flags] eq "master"
+ } else {
+ fail "Master flags are not just 'master'"
+ }
+}
+
+proc ensure_master_down {} {
+ wait_for_condition 1000 50 {
+ [string match *down* \
+ [dict get [S 4 sentinel master mymaster] flags]]
+ } else {
+ fail "Master is not flagged SDOWN"
+ }
+}
+
+test "Crash the majority of Sentinels to prevent failovers for this unit" {
+ for {set id 0} {$id < $quorum} {incr id} {
+ kill_instance sentinel $id
+ }
+}
+
+test "SDOWN is triggered by non-responding but not crashed instance" {
+ lassign [S 4 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] host port
+ ensure_master_up
+ exec ../../../src/redis-cli -h $host -p $port debug sleep 10 > /dev/null &
+ ensure_master_down
+ ensure_master_up
+}
+
+test "SDOWN is triggered by crashed instance" {
+ lassign [S 4 SENTINEL GET-MASTER-ADDR-BY-NAME mymaster] host port
+ ensure_master_up
+ kill_instance redis 0
+ ensure_master_down
+ restart_instance redis 0
+ ensure_master_up
+}
+
+test "SDOWN is triggered by masters advertising as slaves" {
+ ensure_master_up
+ R 0 slaveof 127.0.0.1 34567
+ ensure_master_down
+ R 0 slaveof no one
+ ensure_master_up
+}
+
+test "SDOWN is triggered by misconfigured instance repling with errors" {
+ ensure_master_up
+ set orig_dir [lindex [R 0 config get dir] 1]
+ set orig_save [lindex [R 0 config get save] 1]
+ # Set dir to / and filename to "tmp" to make sure it will fail.
+ R 0 config set dir /
+ R 0 config set dbfilename tmp
+ R 0 config set save "1000000 1000000"
+ R 0 bgsave
+ ensure_master_down
+ R 0 config set save $orig_save
+ R 0 config set dir $orig_dir
+ R 0 config set dbfilename dump.rdb
+ R 0 bgsave
+ ensure_master_up
+}
diff --git a/tests/sentinel/tests/includes/init-tests.tcl b/tests/sentinel/tests/includes/init-tests.tcl
new file mode 100644
index 0000000..c8165dc
--- /dev/null
+++ b/tests/sentinel/tests/includes/init-tests.tcl
@@ -0,0 +1,72 @@
+# Initialization tests -- most units will start including this.
+
+test "(init) Restart killed instances" {
+ foreach type {redis sentinel} {
+ foreach_${type}_id id {
+ if {[get_instance_attrib $type $id pid] == -1} {
+ puts -nonewline "$type/$id "
+ flush stdout
+ restart_instance $type $id
+ }
+ }
+ }
+}
+
+test "(init) Remove old master entry from sentinels" {
+ foreach_sentinel_id id {
+ catch {S $id SENTINEL REMOVE mymaster}
+ }
+}
+
+set redis_slaves 4
+test "(init) Create a master-slaves cluster of [expr $redis_slaves+1] instances" {
+ create_redis_master_slave_cluster [expr {$redis_slaves+1}]
+}
+set master_id 0
+
+test "(init) Sentinels can start monitoring a master" {
+ set sentinels [llength $::sentinel_instances]
+ set quorum [expr {$sentinels/2+1}]
+ foreach_sentinel_id id {
+ S $id SENTINEL MONITOR mymaster \
+ [get_instance_attrib redis $master_id host] \
+ [get_instance_attrib redis $master_id port] $quorum
+ }
+ foreach_sentinel_id id {
+ assert {[S $id sentinel master mymaster] ne {}}
+ S $id SENTINEL SET mymaster down-after-milliseconds 2000
+ S $id SENTINEL SET mymaster failover-timeout 20000
+ S $id SENTINEL SET mymaster parallel-syncs 10
+ }
+}
+
+test "(init) Sentinels can talk with the master" {
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [catch {S $id SENTINEL GET-MASTER-ADDR-BY-NAME mymaster}] == 0
+ } else {
+ fail "Sentinel $id can't talk with the master."
+ }
+ }
+}
+
+test "(init) Sentinels are able to auto-discover other sentinels" {
+ set sentinels [llength $::sentinel_instances]
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [dict get [S $id SENTINEL MASTER mymaster] num-other-sentinels] == ($sentinels-1)
+ } else {
+ fail "At least some sentinel can't detect some other sentinel"
+ }
+ }
+}
+
+test "(init) Sentinels are able to auto-discover slaves" {
+ foreach_sentinel_id id {
+ wait_for_condition 1000 50 {
+ [dict get [S $id SENTINEL MASTER mymaster] num-slaves] == $redis_slaves
+ } else {
+ fail "At least some sentinel can't detect some slave"
+ }
+ }
+}
diff --git a/tests/sentinel/tmp/.gitignore b/tests/sentinel/tmp/.gitignore
new file mode 100644
index 0000000..f581f73
--- /dev/null
+++ b/tests/sentinel/tmp/.gitignore
@@ -0,0 +1,2 @@
+redis_*
+sentinel_*
diff --git a/tests/support/cluster.tcl b/tests/support/cluster.tcl
new file mode 100644
index 0000000..1576053
--- /dev/null
+++ b/tests/support/cluster.tcl
@@ -0,0 +1,307 @@
+# Tcl redis cluster client as a wrapper of redis.rb.
+# Copyright (C) 2014 Salvatore Sanfilippo
+# Released under the BSD license like Redis itself
+#
+# Example usage:
+#
+# set c [redis_cluster 127.0.0.1 6379 127.0.0.1 6380]
+# $c set foo
+# $c get foo
+# $c close
+
+package require Tcl 8.5
+package provide redis_cluster 0.1
+
+namespace eval redis_cluster {}
+set ::redis_cluster::id 0
+array set ::redis_cluster::startup_nodes {}
+array set ::redis_cluster::nodes {}
+array set ::redis_cluster::slots {}
+
+# List of "plain" commands, which are commands where the sole key is always
+# the first argument.
+set ::redis_cluster::plain_commands {
+ get set setnx setex psetex append strlen exists setbit getbit
+ setrange getrange substr incr decr rpush lpush rpushx lpushx
+ linsert rpop lpop brpop llen lindex lset lrange ltrim lrem
+ sadd srem sismember scard spop srandmember smembers sscan zadd
+ zincrby zrem zremrangebyscore zremrangebyrank zremrangebylex zrange
+ zrangebyscore zrevrangebyscore zrangebylex zrevrangebylex zcount
+ zlexcount zrevrange zcard zscore zrank zrevrank zscan hset hsetnx
+ hget hmset hmget hincrby hincrbyfloat hdel hlen hkeys hvals
+ hgetall hexists hscan incrby decrby incrbyfloat getset move
+ expire expireat pexpire pexpireat type ttl pttl persist restore
+ dump bitcount bitpos pfadd pfcount
+}
+
+proc redis_cluster {nodes} {
+ set id [incr ::redis_cluster::id]
+ set ::redis_cluster::startup_nodes($id) $nodes
+ set ::redis_cluster::nodes($id) {}
+ set ::redis_cluster::slots($id) {}
+ set handle [interp alias {} ::redis_cluster::instance$id {} ::redis_cluster::__dispatch__ $id]
+ $handle refresh_nodes_map
+ return $handle
+}
+
+# Totally reset the slots / nodes state for the client, calls
+# CLUSTER NODES in the first startup node available, populates the
+# list of nodes ::redis_cluster::nodes($id) with an hash mapping node
+# ip:port to a representation of the node (another hash), and finally
+# maps ::redis_cluster::slots($id) with an hash mapping slot numbers
+# to node IDs.
+#
+# This function is called when a new Redis Cluster client is initialized
+# and every time we get a -MOVED redirection error.
+proc ::redis_cluster::__method__refresh_nodes_map {id} {
+ # Contact the first responding startup node.
+ set idx 0; # Index of the node that will respond.
+ set errmsg {}
+ foreach start_node $::redis_cluster::startup_nodes($id) {
+ set ip_port [lindex [split $start_node @] 0]
+ lassign [split $ip_port :] start_host start_port
+ if {[catch {
+ set r {}
+ set r [redis $start_host $start_port]
+ set nodes_descr [$r cluster nodes]
+ $r close
+ } e]} {
+ if {$r ne {}} {catch {$r close}}
+ incr idx
+ if {[string length $errmsg] < 200} {
+ append errmsg " $ip_port: $e"
+ }
+ continue ; # Try next.
+ } else {
+ break; # Good node found.
+ }
+ }
+
+ if {$idx == [llength $::redis_cluster::startup_nodes($id)]} {
+ error "No good startup node found. $errmsg"
+ }
+
+ # Put the node that responded as first in the list if it is not
+ # already the first.
+ if {$idx != 0} {
+ set l $::redis_cluster::startup_nodes($id)
+ set left [lrange $l 0 [expr {$idx-1}]]
+ set right [lrange $l [expr {$idx+1}] end]
+ set l [concat [lindex $l $idx] $left $right]
+ set ::redis_cluster::startup_nodes($id) $l
+ }
+
+ # Parse CLUSTER NODES output to populate the nodes description.
+ set nodes {} ; # addr -> node description hash.
+ foreach line [split $nodes_descr "\n"] {
+ set line [string trim $line]
+ if {$line eq {}} continue
+ set args [split $line " "]
+ lassign $args nodeid addr flags slaveof pingsent pongrecv configepoch linkstate
+ set slots [lrange $args 8 end]
+ set addr [lindex [split $addr @] 0]
+ if {$addr eq {:0}} {
+ set addr $start_host:$start_port
+ }
+ lassign [split $addr :] host port
+
+ # Connect to the node
+ set link {}
+ catch {set link [redis $host $port]}
+
+ # Build this node description as an hash.
+ set node [dict create \
+ id $nodeid \
+ addr $addr \
+ host $host \
+ port $port \
+ flags $flags \
+ slaveof $slaveof \
+ slots $slots \
+ link $link \
+ ]
+ dict set nodes $addr $node
+ lappend ::redis_cluster::startup_nodes($id) $addr
+ }
+
+ # Close all the existing links in the old nodes map, and set the new
+ # map as current.
+ foreach n $::redis_cluster::nodes($id) {
+ catch {
+ [dict get $n link] close
+ }
+ }
+ set ::redis_cluster::nodes($id) $nodes
+
+ # Populates the slots -> nodes map.
+ dict for {addr node} $nodes {
+ foreach slotrange [dict get $node slots] {
+ lassign [split $slotrange -] start end
+ if {$end == {}} {set end $start}
+ for {set j $start} {$j <= $end} {incr j} {
+ dict set ::redis_cluster::slots($id) $j $addr
+ }
+ }
+ }
+
+ # Only retain unique entries in the startup nodes list
+ set ::redis_cluster::startup_nodes($id) [lsort -unique $::redis_cluster::startup_nodes($id)]
+}
+
+# Free a redis_cluster handle.
+proc ::redis_cluster::__method__close {id} {
+ catch {
+ set nodes $::redis_cluster::nodes($id)
+ dict for {addr node} $nodes {
+ catch {
+ [dict get $node link] close
+ }
+ }
+ }
+ catch {unset ::redis_cluster::startup_nodes($id)}
+ catch {unset ::redis_cluster::nodes($id)}
+ catch {unset ::redis_cluster::slots($id)}
+ catch {interp alias {} ::redis_cluster::instance$id {}}
+}
+
+proc ::redis_cluster::__dispatch__ {id method args} {
+ if {[info command ::redis_cluster::__method__$method] eq {}} {
+ # Get the keys from the command.
+ set keys [::redis_cluster::get_keys_from_command $method $args]
+ if {$keys eq {}} {
+ error "Redis command '$method' is not supported by redis_cluster."
+ }
+
+ # Resolve the keys in the corresponding hash slot they hash to.
+ set slot [::redis_cluster::get_slot_from_keys $keys]
+ if {$slot eq {}} {
+ error "Invalid command: multiple keys not hashing to the same slot."
+ }
+
+ # Get the node mapped to this slot.
+ set node_addr [dict get $::redis_cluster::slots($id) $slot]
+ if {$node_addr eq {}} {
+ error "No mapped node for slot $slot."
+ }
+
+ # Execute the command in the node we think is the slot owner.
+ set retry 100
+ while {[incr retry -1]} {
+ if {$retry < 5} {after 100}
+ set node [dict get $::redis_cluster::nodes($id) $node_addr]
+ set link [dict get $node link]
+ if {[catch {$link $method {*}$args} e]} {
+ if {$link eq {} || \
+ [string range $e 0 4] eq {MOVED} || \
+ [string range $e 0 2] eq {I/O} \
+ } {
+ # MOVED redirection.
+ ::redis_cluster::__method__refresh_nodes_map $id
+ set node_addr [dict get $::redis_cluster::slots($id) $slot]
+ continue
+ } elseif {[string range $e 0 2] eq {ASK}} {
+ # ASK redirection.
+ set node_addr [lindex $e 2]
+ continue
+ } else {
+ # Non redirecting error.
+ error $e $::errorInfo $::errorCode
+ }
+ } else {
+ # OK query went fine
+ return $e
+ }
+ }
+ error "Too many redirections or failures contacting Redis Cluster."
+ } else {
+ uplevel 1 [list ::redis_cluster::__method__$method $id] $args
+ }
+}
+
+proc ::redis_cluster::get_keys_from_command {cmd argv} {
+ set cmd [string tolower $cmd]
+ # Most Redis commands get just one key as first argument.
+ if {[lsearch -exact $::redis_cluster::plain_commands $cmd] != -1} {
+ return [list [lindex $argv 0]]
+ }
+
+ # Special handling for other commands
+ switch -exact $cmd {
+ mget {return $argv}
+ eval {return [lrange $argv 2 1+[lindex $argv 1]]}
+ evalsha {return [lrange $argv 2 1+[lindex $argv 1]]}
+ }
+
+ # All the remaining commands are not handled.
+ return {}
+}
+
+# Returns the CRC16 of the specified string.
+# The CRC parameters are described in the Redis Cluster specification.
+set ::redis_cluster::XMODEMCRC16Lookup {
+ 0x0000 0x1021 0x2042 0x3063 0x4084 0x50a5 0x60c6 0x70e7
+ 0x8108 0x9129 0xa14a 0xb16b 0xc18c 0xd1ad 0xe1ce 0xf1ef
+ 0x1231 0x0210 0x3273 0x2252 0x52b5 0x4294 0x72f7 0x62d6
+ 0x9339 0x8318 0xb37b 0xa35a 0xd3bd 0xc39c 0xf3ff 0xe3de
+ 0x2462 0x3443 0x0420 0x1401 0x64e6 0x74c7 0x44a4 0x5485
+ 0xa56a 0xb54b 0x8528 0x9509 0xe5ee 0xf5cf 0xc5ac 0xd58d
+ 0x3653 0x2672 0x1611 0x0630 0x76d7 0x66f6 0x5695 0x46b4
+ 0xb75b 0xa77a 0x9719 0x8738 0xf7df 0xe7fe 0xd79d 0xc7bc
+ 0x48c4 0x58e5 0x6886 0x78a7 0x0840 0x1861 0x2802 0x3823
+ 0xc9cc 0xd9ed 0xe98e 0xf9af 0x8948 0x9969 0xa90a 0xb92b
+ 0x5af5 0x4ad4 0x7ab7 0x6a96 0x1a71 0x0a50 0x3a33 0x2a12
+ 0xdbfd 0xcbdc 0xfbbf 0xeb9e 0x9b79 0x8b58 0xbb3b 0xab1a
+ 0x6ca6 0x7c87 0x4ce4 0x5cc5 0x2c22 0x3c03 0x0c60 0x1c41
+ 0xedae 0xfd8f 0xcdec 0xddcd 0xad2a 0xbd0b 0x8d68 0x9d49
+ 0x7e97 0x6eb6 0x5ed5 0x4ef4 0x3e13 0x2e32 0x1e51 0x0e70
+ 0xff9f 0xefbe 0xdfdd 0xcffc 0xbf1b 0xaf3a 0x9f59 0x8f78
+ 0x9188 0x81a9 0xb1ca 0xa1eb 0xd10c 0xc12d 0xf14e 0xe16f
+ 0x1080 0x00a1 0x30c2 0x20e3 0x5004 0x4025 0x7046 0x6067
+ 0x83b9 0x9398 0xa3fb 0xb3da 0xc33d 0xd31c 0xe37f 0xf35e
+ 0x02b1 0x1290 0x22f3 0x32d2 0x4235 0x5214 0x6277 0x7256
+ 0xb5ea 0xa5cb 0x95a8 0x8589 0xf56e 0xe54f 0xd52c 0xc50d
+ 0x34e2 0x24c3 0x14a0 0x0481 0x7466 0x6447 0x5424 0x4405
+ 0xa7db 0xb7fa 0x8799 0x97b8 0xe75f 0xf77e 0xc71d 0xd73c
+ 0x26d3 0x36f2 0x0691 0x16b0 0x6657 0x7676 0x4615 0x5634
+ 0xd94c 0xc96d 0xf90e 0xe92f 0x99c8 0x89e9 0xb98a 0xa9ab
+ 0x5844 0x4865 0x7806 0x6827 0x18c0 0x08e1 0x3882 0x28a3
+ 0xcb7d 0xdb5c 0xeb3f 0xfb1e 0x8bf9 0x9bd8 0xabbb 0xbb9a
+ 0x4a75 0x5a54 0x6a37 0x7a16 0x0af1 0x1ad0 0x2ab3 0x3a92
+ 0xfd2e 0xed0f 0xdd6c 0xcd4d 0xbdaa 0xad8b 0x9de8 0x8dc9
+ 0x7c26 0x6c07 0x5c64 0x4c45 0x3ca2 0x2c83 0x1ce0 0x0cc1
+ 0xef1f 0xff3e 0xcf5d 0xdf7c 0xaf9b 0xbfba 0x8fd9 0x9ff8
+ 0x6e17 0x7e36 0x4e55 0x5e74 0x2e93 0x3eb2 0x0ed1 0x1ef0
+}
+
+proc ::redis_cluster::crc16 {s} {
+ set s [encoding convertto ascii $s]
+ set crc 0
+ foreach char [split $s {}] {
+ scan $char %c byte
+ set crc [expr {(($crc<<8)&0xffff) ^ [lindex $::redis_cluster::XMODEMCRC16Lookup [expr {(($crc>>8)^$byte) & 0xff}]]}]
+ }
+ return $crc
+}
+
+# Hash a single key returning the slot it belongs to, Implemented hash
+# tags as described in the Redis Cluster specification.
+proc ::redis_cluster::hash {key} {
+ # TODO: Handle hash slots.
+ expr {[::redis_cluster::crc16 $key] & 16383}
+}
+
+# Return the slot the specified keys hash to.
+# If the keys hash to multiple slots, an empty string is returned to
+# signal that the command can't be run in Redis Cluster.
+proc ::redis_cluster::get_slot_from_keys {keys} {
+ set slot {}
+ foreach k $keys {
+ set s [::redis_cluster::hash $k]
+ if {$slot eq {}} {
+ set slot $s
+ } elseif {$slot != $s} {
+ return {} ; # Error
+ }
+ }
+ return $slot
+}
diff --git a/tests/support/redis.tcl b/tests/support/redis.tcl
new file mode 100644
index 0000000..cd8ae3a
--- /dev/null
+++ b/tests/support/redis.tcl
@@ -0,0 +1,294 @@
+# Tcl client library - used by the Redis test
+# Copyright (C) 2009-2014 Salvatore Sanfilippo
+# Released under the BSD license like Redis itself
+#
+# Example usage:
+#
+# set r [redis 127.0.0.1 6379]
+# $r lpush mylist foo
+# $r lpush mylist bar
+# $r lrange mylist 0 -1
+# $r close
+#
+# Non blocking usage example:
+#
+# proc handlePong {r type reply} {
+# puts "PONG $type '$reply'"
+# if {$reply ne "PONG"} {
+# $r ping [list handlePong]
+# }
+# }
+#
+# set r [redis]
+# $r blocking 0
+# $r get fo [list handlePong]
+#
+# vwait forever
+
+package require Tcl 8.5
+package provide redis 0.1
+
+namespace eval redis {}
+set ::redis::id 0
+array set ::redis::fd {}
+array set ::redis::addr {}
+array set ::redis::blocking {}
+array set ::redis::deferred {}
+array set ::redis::reconnect {}
+array set ::redis::callback {}
+array set ::redis::state {} ;# State in non-blocking reply reading
+array set ::redis::statestack {} ;# Stack of states, for nested mbulks
+
+proc redis {{server 127.0.0.1} {port 6379} {defer 0}} {
+ set fd [socket $server $port]
+ fconfigure $fd -translation binary
+ set id [incr ::redis::id]
+ set ::redis::fd($id) $fd
+ set ::redis::addr($id) [list $server $port]
+ set ::redis::blocking($id) 1
+ set ::redis::deferred($id) $defer
+ set ::redis::reconnect($id) 0
+ ::redis::redis_reset_state $id
+ interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
+}
+
+# This is a wrapper to the actual dispatching procedure that handles
+# reconnection if needed.
+proc ::redis::__dispatch__ {id method args} {
+ set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval]
+ if {$errorcode && $::redis::reconnect($id) && $::redis::fd($id) eq {}} {
+ # Try again if the connection was lost.
+ # FIXME: we don't re-select the previously selected DB, nor we check
+ # if we are inside a transaction that needs to be re-issued from
+ # scratch.
+ set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval]
+ }
+ return -code $errorcode $retval
+}
+
+proc ::redis::__dispatch__raw__ {id method argv} {
+ set fd $::redis::fd($id)
+
+ # Reconnect the link if needed.
+ if {$fd eq {}} {
+ lassign $::redis::addr($id) host port
+ set ::redis::fd($id) [socket $host $port]
+ fconfigure $::redis::fd($id) -translation binary
+ set fd $::redis::fd($id)
+ }
+
+ set blocking $::redis::blocking($id)
+ set deferred $::redis::deferred($id)
+ if {$blocking == 0} {
+ if {[llength $argv] == 0} {
+ error "Please provide a callback in non-blocking mode"
+ }
+ set callback [lindex $argv end]
+ set argv [lrange $argv 0 end-1]
+ }
+ if {[info command ::redis::__method__$method] eq {}} {
+ set cmd "*[expr {[llength $argv]+1}]\r\n"
+ append cmd "$[string length $method]\r\n$method\r\n"
+ foreach a $argv {
+ append cmd "$[string length $a]\r\n$a\r\n"
+ }
+ ::redis::redis_write $fd $cmd
+ if {[catch {flush $fd}]} {
+ set ::redis::fd($id) {}
+ return -code error "I/O error reading reply"
+ }
+
+ if {!$deferred} {
+ if {$blocking} {
+ ::redis::redis_read_reply $id $fd
+ } else {
+ # Every well formed reply read will pop an element from this
+ # list and use it as a callback. So pipelining is supported
+ # in non blocking mode.
+ lappend ::redis::callback($id) $callback
+ fileevent $fd readable [list ::redis::redis_readable $fd $id]
+ }
+ }
+ } else {
+ uplevel 1 [list ::redis::__method__$method $id $fd] $argv
+ }
+}
+
+proc ::redis::__method__blocking {id fd val} {
+ set ::redis::blocking($id) $val
+ fconfigure $fd -blocking $val
+}
+
+proc ::redis::__method__reconnect {id fd val} {
+ set ::redis::reconnect($id) $val
+}
+
+proc ::redis::__method__read {id fd} {
+ ::redis::redis_read_reply $id $fd
+}
+
+proc ::redis::__method__write {id fd buf} {
+ ::redis::redis_write $fd $buf
+}
+
+proc ::redis::__method__flush {id fd} {
+ flush $fd
+}
+
+proc ::redis::__method__close {id fd} {
+ catch {close $fd}
+ catch {unset ::redis::fd($id)}
+ catch {unset ::redis::addr($id)}
+ catch {unset ::redis::blocking($id)}
+ catch {unset ::redis::deferred($id)}
+ catch {unset ::redis::reconnect($id)}
+ catch {unset ::redis::state($id)}
+ catch {unset ::redis::statestack($id)}
+ catch {unset ::redis::callback($id)}
+ catch {interp alias {} ::redis::redisHandle$id {}}
+}
+
+proc ::redis::__method__channel {id fd} {
+ return $fd
+}
+
+proc ::redis::__method__deferred {id fd val} {
+ set ::redis::deferred($id) $val
+}
+
+proc ::redis::redis_write {fd buf} {
+ puts -nonewline $fd $buf
+}
+
+proc ::redis::redis_writenl {fd buf} {
+ redis_write $fd $buf
+ redis_write $fd "\r\n"
+ flush $fd
+}
+
+proc ::redis::redis_readnl {fd len} {
+ set buf [read $fd $len]
+ read $fd 2 ; # discard CR LF
+ return $buf
+}
+
+proc ::redis::redis_bulk_read {fd} {
+ set count [redis_read_line $fd]
+ if {$count == -1} return {}
+ set buf [redis_readnl $fd $count]
+ return $buf
+}
+
+proc ::redis::redis_multi_bulk_read {id fd} {
+ set count [redis_read_line $fd]
+ if {$count == -1} return {}
+ set l {}
+ set err {}
+ for {set i 0} {$i < $count} {incr i} {
+ if {[catch {
+ lappend l [redis_read_reply $id $fd]
+ } e] && $err eq {}} {
+ set err $e
+ }
+ }
+ if {$err ne {}} {return -code error $err}
+ return $l
+}
+
+proc ::redis::redis_read_line fd {
+ string trim [gets $fd]
+}
+
+proc ::redis::redis_read_reply {id fd} {
+ set type [read $fd 1]
+ switch -exact -- $type {
+ : -
+ + {redis_read_line $fd}
+ - {return -code error [redis_read_line $fd]}
+ $ {redis_bulk_read $fd}
+ * {redis_multi_bulk_read $id $fd}
+ default {
+ if {$type eq {}} {
+ set ::redis::fd($id) {}
+ return -code error "I/O error reading reply"
+ }
+ return -code error "Bad protocol, '$type' as reply type byte"
+ }
+ }
+}
+
+proc ::redis::redis_reset_state id {
+ set ::redis::state($id) [dict create buf {} mbulk -1 bulk -1 reply {}]
+ set ::redis::statestack($id) {}
+}
+
+proc ::redis::redis_call_callback {id type reply} {
+ set cb [lindex $::redis::callback($id) 0]
+ set ::redis::callback($id) [lrange $::redis::callback($id) 1 end]
+ uplevel #0 $cb [list ::redis::redisHandle$id $type $reply]
+ ::redis::redis_reset_state $id
+}
+
+# Read a reply in non-blocking mode.
+proc ::redis::redis_readable {fd id} {
+ if {[eof $fd]} {
+ redis_call_callback $id eof {}
+ ::redis::__method__close $id $fd
+ return
+ }
+ if {[dict get $::redis::state($id) bulk] == -1} {
+ set line [gets $fd]
+ if {$line eq {}} return ;# No complete line available, return
+ switch -exact -- [string index $line 0] {
+ : -
+ + {redis_call_callback $id reply [string range $line 1 end-1]}
+ - {redis_call_callback $id err [string range $line 1 end-1]}
+ $ {
+ dict set ::redis::state($id) bulk \
+ [expr [string range $line 1 end-1]+2]
+ if {[dict get $::redis::state($id) bulk] == 1} {
+ # We got a $-1, hack the state to play well with this.
+ dict set ::redis::state($id) bulk 2
+ dict set ::redis::state($id) buf "\r\n"
+ ::redis::redis_readable $fd $id
+ }
+ }
+ * {
+ dict set ::redis::state($id) mbulk [string range $line 1 end-1]
+ # Handle *-1
+ if {[dict get $::redis::state($id) mbulk] == -1} {
+ redis_call_callback $id reply {}
+ }
+ }
+ default {
+ redis_call_callback $id err \
+ "Bad protocol, $type as reply type byte"
+ }
+ }
+ } else {
+ set totlen [dict get $::redis::state($id) bulk]
+ set buflen [string length [dict get $::redis::state($id) buf]]
+ set toread [expr {$totlen-$buflen}]
+ set data [read $fd $toread]
+ set nread [string length $data]
+ dict append ::redis::state($id) buf $data
+ # Check if we read a complete bulk reply
+ if {[string length [dict get $::redis::state($id) buf]] ==
+ [dict get $::redis::state($id) bulk]} {
+ if {[dict get $::redis::state($id) mbulk] == -1} {
+ redis_call_callback $id reply \
+ [string range [dict get $::redis::state($id) buf] 0 end-2]
+ } else {
+ dict with ::redis::state($id) {
+ lappend reply [string range $buf 0 end-2]
+ incr mbulk -1
+ set bulk -1
+ }
+ if {[dict get $::redis::state($id) mbulk] == 0} {
+ redis_call_callback $id reply \
+ [dict get $::redis::state($id) reply]
+ }
+ }
+ }
+ }
+}
diff --git a/tests/support/server.tcl b/tests/support/server.tcl
new file mode 100644
index 0000000..c36b307
--- /dev/null
+++ b/tests/support/server.tcl
@@ -0,0 +1,329 @@
+set ::global_overrides {}
+set ::tags {}
+set ::valgrind_errors {}
+
+proc start_server_error {config_file error} {
+ set err {}
+ append err "Cant' start the Redis server\n"
+ append err "CONFIGURATION:"
+ append err [exec cat $config_file]
+ append err "\nERROR:"
+ append err [string trim $error]
+ send_data_packet $::test_server_fd err $err
+}
+
+proc check_valgrind_errors stderr {
+ set fd [open $stderr]
+ set buf [read $fd]
+ close $fd
+
+ if {[regexp -- { at 0x} $buf] ||
+ (![regexp -- {definitely lost: 0 bytes} $buf] &&
+ ![regexp -- {no leaks are possible} $buf])} {
+ send_data_packet $::test_server_fd err "Valgrind error: $buf\n"
+ }
+}
+
+proc kill_server config {
+ # nothing to kill when running against external server
+ if {$::external} return
+
+ # nevermind if its already dead
+ if {![is_alive $config]} { return }
+ set pid [dict get $config pid]
+
+ # check for leaks
+ if {![dict exists $config "skipleaks"]} {
+ catch {
+ if {[string match {*Darwin*} [exec uname -a]]} {
+ tags {"leaks"} {
+ test "Check for memory leaks (pid $pid)" {
+ set output {0 leaks}
+ catch {exec leaks $pid} output
+ if {[string match {*process does not exist*} $output] ||
+ [string match {*cannot examine*} $output]} {
+ # In a few tests we kill the server process.
+ set output "0 leaks"
+ }
+ set output
+ } {*0 leaks*}
+ }
+ }
+ }
+ }
+
+ # kill server and wait for the process to be totally exited
+ catch {exec kill $pid}
+ if {$::valgrind} {
+ set max_wait 60000
+ } else {
+ set max_wait 10000
+ }
+ while {[is_alive $config]} {
+ incr wait 10
+
+ if {$wait >= $max_wait} {
+ puts "Forcing process $pid to exit..."
+ catch {exec kill -KILL $pid}
+ } elseif {$wait % 1000 == 0} {
+ puts "Waiting for process $pid to exit..."
+ }
+ after 10
+ }
+
+ # Check valgrind errors if needed
+ if {$::valgrind} {
+ check_valgrind_errors [dict get $config stderr]
+ }
+
+ # Remove this pid from the set of active pids in the test server.
+ send_data_packet $::test_server_fd server-killed $pid
+}
+
+proc is_alive config {
+ set pid [dict get $config pid]
+ if {[catch {exec ps -p $pid} err]} {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+proc ping_server {host port} {
+ set retval 0
+ if {[catch {
+ set fd [socket $host $port]
+ fconfigure $fd -translation binary
+ puts $fd "PING\r\n"
+ flush $fd
+ set reply [gets $fd]
+ if {[string range $reply 0 0] eq {+} ||
+ [string range $reply 0 0] eq {-}} {
+ set retval 1
+ }
+ close $fd
+ } e]} {
+ if {$::verbose} {
+ puts -nonewline "."
+ }
+ } else {
+ if {$::verbose} {
+ puts -nonewline "ok"
+ }
+ }
+ return $retval
+}
+
+# Return 1 if the server at the specified addr is reachable by PING, otherwise
+# returns 0. Performs a try every 50 milliseconds for the specified number
+# of retries.
+proc server_is_up {host port retrynum} {
+ after 10 ;# Use a small delay to make likely a first-try success.
+ set retval 0
+ while {[incr retrynum -1]} {
+ if {[catch {ping_server $host $port} ping]} {
+ set ping 0
+ }
+ if {$ping} {return 1}
+ after 50
+ }
+ return 0
+}
+
+# doesn't really belong here, but highly coupled to code in start_server
+proc tags {tags code} {
+ set ::tags [concat $::tags $tags]
+ uplevel 1 $code
+ set ::tags [lrange $::tags 0 end-[llength $tags]]
+}
+
+proc start_server {options {code undefined}} {
+ # If we are running against an external server, we just push the
+ # host/port pair in the stack the first time
+ if {$::external} {
+ if {[llength $::servers] == 0} {
+ set srv {}
+ dict set srv "host" $::host
+ dict set srv "port" $::port
+ set client [redis $::host $::port]
+ dict set srv "client" $client
+ $client select 9
+
+ # append the server to the stack
+ lappend ::servers $srv
+ }
+ uplevel 1 $code
+ return
+ }
+
+ # setup defaults
+ set baseconfig "default.conf"
+ set overrides {}
+ set tags {}
+
+ # parse options
+ foreach {option value} $options {
+ switch $option {
+ "config" {
+ set baseconfig $value }
+ "overrides" {
+ set overrides $value }
+ "tags" {
+ set tags $value
+ set ::tags [concat $::tags $value] }
+ default {
+ error "Unknown option $option" }
+ }
+ }
+
+ set data [split [exec cat "tests/assets/$baseconfig"] "\n"]
+ set config {}
+ foreach line $data {
+ if {[string length $line] > 0 && [string index $line 0] ne "#"} {
+ set elements [split $line " "]
+ set directive [lrange $elements 0 0]
+ set arguments [lrange $elements 1 end]
+ dict set config $directive $arguments
+ }
+ }
+
+ # use a different directory every time a server is started
+ dict set config dir [tmpdir server]
+
+ # start every server on a different port
+ set ::port [find_available_port [expr {$::port+1}]]
+ dict set config port $::port
+
+ # apply overrides from global space and arguments
+ foreach {directive arguments} [concat $::global_overrides $overrides] {
+ dict set config $directive $arguments
+ }
+
+ # write new configuration to temporary file
+ set config_file [tmpfile redis.conf]
+ set fp [open $config_file w+]
+ foreach directive [dict keys $config] {
+ puts -nonewline $fp "$directive "
+ puts $fp [dict get $config $directive]
+ }
+ close $fp
+
+ set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
+ set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
+
+ if {$::valgrind} {
+ set pid [exec valgrind --track-origins=yes --suppressions=src/valgrind.sup --show-reachable=no --show-possibly-lost=no --leak-check=full src/redis-server $config_file > $stdout 2> $stderr &]
+ } elseif ($::stack_logging) {
+ set pid [exec /usr/bin/env MallocStackLogging=1 MallocLogFile=/tmp/malloc_log.txt src/redis-server $config_file > $stdout 2> $stderr &]
+ } else {
+ set pid [exec src/redis-server $config_file > $stdout 2> $stderr &]
+ }
+
+ # Tell the test server about this new instance.
+ send_data_packet $::test_server_fd server-spawned $pid
+
+ # check that the server actually started
+ # ugly but tries to be as fast as possible...
+ if {$::valgrind} {set retrynum 1000} else {set retrynum 100}
+
+ if {$::verbose} {
+ puts -nonewline "=== ($tags) Starting server ${::host}:${::port} "
+ }
+
+ if {$code ne "undefined"} {
+ set serverisup [server_is_up $::host $::port $retrynum]
+ } else {
+ set serverisup 1
+ }
+
+ if {$::verbose} {
+ puts ""
+ }
+
+ if {!$serverisup} {
+ set err {}
+ append err [exec cat $stdout] "\n" [exec cat $stderr]
+ start_server_error $config_file $err
+ return
+ }
+
+ # Wait for actual startup
+ while {![info exists _pid]} {
+ regexp {PID:\s(\d+)} [exec cat $stdout] _ _pid
+ after 100
+ }
+
+ # setup properties to be able to initialize a client object
+ set host $::host
+ set port $::port
+ if {[dict exists $config bind]} { set host [dict get $config bind] }
+ if {[dict exists $config port]} { set port [dict get $config port] }
+
+ # setup config dict
+ dict set srv "config_file" $config_file
+ dict set srv "config" $config
+ dict set srv "pid" $pid
+ dict set srv "host" $host
+ dict set srv "port" $port
+ dict set srv "stdout" $stdout
+ dict set srv "stderr" $stderr
+
+ # if a block of code is supplied, we wait for the server to become
+ # available, create a client object and kill the server afterwards
+ if {$code ne "undefined"} {
+ set line [exec head -n1 $stdout]
+ if {[string match {*already in use*} $line]} {
+ error_and_quit $config_file $line
+ }
+
+ while 1 {
+ # check that the server actually started and is ready for connections
+ if {[exec grep -i "Ready to accept" | wc -l < $stdout] > 0} {
+ break
+ }
+ after 10
+ }
+
+ # append the server to the stack
+ lappend ::servers $srv
+
+ # connect client (after server dict is put on the stack)
+ reconnect
+
+ # execute provided block
+ set num_tests $::num_tests
+ if {[catch { uplevel 1 $code } error]} {
+ set backtrace $::errorInfo
+
+ # Kill the server without checking for leaks
+ dict set srv "skipleaks" 1
+ kill_server $srv
+
+ # Print warnings from log
+ puts [format "\nLogged warnings (pid %d):" [dict get $srv "pid"]]
+ set warnings [warnings_from_file [dict get $srv "stdout"]]
+ if {[string length $warnings] > 0} {
+ puts "$warnings"
+ } else {
+ puts "(none)"
+ }
+ puts ""
+
+ error $error $backtrace
+ }
+
+ # Don't do the leak check when no tests were run
+ if {$num_tests == $::num_tests} {
+ dict set srv "skipleaks" 1
+ }
+
+ # pop the server object
+ set ::servers [lrange $::servers 0 end-1]
+
+ set ::tags [lrange $::tags 0 end-[llength $tags]]
+ kill_server $srv
+ } else {
+ set ::tags [lrange $::tags 0 end-[llength $tags]]
+ set _ $srv
+ }
+}
diff --git a/tests/support/test.tcl b/tests/support/test.tcl
new file mode 100644
index 0000000..d60eb3c
--- /dev/null
+++ b/tests/support/test.tcl
@@ -0,0 +1,127 @@
+set ::num_tests 0
+set ::num_passed 0
+set ::num_failed 0
+set ::tests_failed {}
+
+proc fail {msg} {
+ error "assertion:$msg"
+}
+
+proc assert {condition} {
+ if {![uplevel 1 [list expr $condition]]} {
+ error "assertion:Expected condition '$condition' to be true ([uplevel 1 [list subst -nocommands $condition]])"
+ }
+}
+
+proc assert_match {pattern value} {
+ if {![string match $pattern $value]} {
+ error "assertion:Expected '$value' to match '$pattern'"
+ }
+}
+
+proc assert_equal {expected value {detail ""}} {
+ if {$expected ne $value} {
+ if {$detail ne ""} {
+ set detail " (detail: $detail)"
+ }
+ error "assertion:Expected '$value' to be equal to '$expected'$detail"
+ }
+}
+
+proc assert_error {pattern code} {
+ if {[catch {uplevel 1 $code} error]} {
+ assert_match $pattern $error
+ } else {
+ error "assertion:Expected an error but nothing was caught"
+ }
+}
+
+proc assert_encoding {enc key} {
+ set dbg [r debug object $key]
+ assert_match "* encoding:$enc *" $dbg
+}
+
+proc assert_type {type key} {
+ assert_equal $type [r type $key]
+}
+
+# Wait for the specified condition to be true, with the specified number of
+# max retries and delay between retries. Otherwise the 'elsescript' is
+# executed.
+proc wait_for_condition {maxtries delay e _else_ elsescript} {
+ while {[incr maxtries -1] >= 0} {
+ set errcode [catch {uplevel 1 [list expr $e]} result]
+ if {$errcode == 0} {
+ if {$result} break
+ } else {
+ return -code $errcode $result
+ }
+ after $delay
+ }
+ if {$maxtries == -1} {
+ set errcode [catch [uplevel 1 $elsescript] result]
+ return -code $errcode $result
+ }
+}
+
+proc test {name code {okpattern undefined}} {
+ # abort if tagged with a tag to deny
+ foreach tag $::denytags {
+ if {[lsearch $::tags $tag] >= 0} {
+ return
+ }
+ }
+
+ # check if tagged with at least 1 tag to allow when there *is* a list
+ # of tags to allow, because default policy is to run everything
+ if {[llength $::allowtags] > 0} {
+ set matched 0
+ foreach tag $::allowtags {
+ if {[lsearch $::tags $tag] >= 0} {
+ incr matched
+ }
+ }
+ if {$matched < 1} {
+ return
+ }
+ }
+
+ incr ::num_tests
+ set details {}
+ lappend details "$name in $::curfile"
+
+ send_data_packet $::test_server_fd testing $name
+
+ if {[catch {set retval [uplevel 1 $code]} error]} {
+ if {[string match "assertion:*" $error]} {
+ set msg [string range $error 10 end]
+ lappend details $msg
+ lappend ::tests_failed $details
+
+ incr ::num_failed
+ send_data_packet $::test_server_fd err [join $details "\n"]
+ } else {
+ # Re-raise, let handler up the stack take care of this.
+ error $error $::errorInfo
+ }
+ } else {
+ if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
+ incr ::num_passed
+ send_data_packet $::test_server_fd ok $name
+ } else {
+ set msg "Expected '$okpattern' to equal or match '$retval'"
+ lappend details $msg
+ lappend ::tests_failed $details
+
+ incr ::num_failed
+ send_data_packet $::test_server_fd err [join $details "\n"]
+ }
+ }
+
+ if {$::traceleaks} {
+ set output [exec leaks redis-server]
+ if {![string match {*0 leaks*} $output]} {
+ send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
+ }
+ }
+}
diff --git a/tests/support/tmpfile.tcl b/tests/support/tmpfile.tcl
new file mode 100644
index 0000000..809f587
--- /dev/null
+++ b/tests/support/tmpfile.tcl
@@ -0,0 +1,15 @@
+set ::tmpcounter 0
+set ::tmproot "./tests/tmp"
+file mkdir $::tmproot
+
+# returns a dirname unique to this process to write to
+proc tmpdir {basename} {
+ set dir [file join $::tmproot $basename.[pid].[incr ::tmpcounter]]
+ file mkdir $dir
+ set _ $dir
+}
+
+# return a filename unique to this process to write to
+proc tmpfile {basename} {
+ file join $::tmproot $basename.[pid].[incr ::tmpcounter]
+}
diff --git a/tests/support/util.tcl b/tests/support/util.tcl
new file mode 100644
index 0000000..64c36b3
--- /dev/null
+++ b/tests/support/util.tcl
@@ -0,0 +1,377 @@
+proc randstring {min max {type binary}} {
+ set len [expr {$min+int(rand()*($max-$min+1))}]
+ set output {}
+ if {$type eq {binary}} {
+ set minval 0
+ set maxval 255
+ } elseif {$type eq {alpha}} {
+ set minval 48
+ set maxval 122
+ } elseif {$type eq {compr}} {
+ set minval 48
+ set maxval 52
+ }
+ while {$len} {
+ append output [format "%c" [expr {$minval+int(rand()*($maxval-$minval+1))}]]
+ incr len -1
+ }
+ return $output
+}
+
+# Useful for some test
+proc zlistAlikeSort {a b} {
+ if {[lindex $a 0] > [lindex $b 0]} {return 1}
+ if {[lindex $a 0] < [lindex $b 0]} {return -1}
+ string compare [lindex $a 1] [lindex $b 1]
+}
+
+# Return all log lines starting with the first line that contains a warning.
+# Generally, this will be an assertion error with a stack trace.
+proc warnings_from_file {filename} {
+ set lines [split [exec cat $filename] "\n"]
+ set matched 0
+ set logall 0
+ set result {}
+ foreach line $lines {
+ if {[string match {*REDIS BUG REPORT START*} $line]} {
+ set logall 1
+ }
+ if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} {
+ set matched 1
+ }
+ if {$logall || $matched} {
+ lappend result $line
+ }
+ }
+ join $result "\n"
+}
+
+# Return value for INFO property
+proc status {r property} {
+ if {[regexp "\r\n$property:(.*?)\r\n" [{*}$r info] _ value]} {
+ set _ $value
+ }
+}
+
+proc waitForBgsave r {
+ while 1 {
+ if {[status r rdb_bgsave_in_progress] eq 1} {
+ if {$::verbose} {
+ puts -nonewline "\nWaiting for background save to finish... "
+ flush stdout
+ }
+ after 1000
+ } else {
+ break
+ }
+ }
+}
+
+proc waitForBgrewriteaof r {
+ while 1 {
+ if {[status r aof_rewrite_in_progress] eq 1} {
+ if {$::verbose} {
+ puts -nonewline "\nWaiting for background AOF rewrite to finish... "
+ flush stdout
+ }
+ after 1000
+ } else {
+ break
+ }
+ }
+}
+
+proc wait_for_sync r {
+ while 1 {
+ if {[status $r master_link_status] eq "down"} {
+ after 10
+ } else {
+ break
+ }
+ }
+}
+
+# Random integer between 0 and max (excluded).
+proc randomInt {max} {
+ expr {int(rand()*$max)}
+}
+
+# Random signed integer between -max and max (both extremes excluded).
+proc randomSignedInt {max} {
+ set i [randomInt $max]
+ if {rand() > 0.5} {
+ set i -$i
+ }
+ return $i
+}
+
+proc randpath args {
+ set path [expr {int(rand()*[llength $args])}]
+ uplevel 1 [lindex $args $path]
+}
+
+proc randomValue {} {
+ randpath {
+ # Small enough to likely collide
+ randomSignedInt 1000
+ } {
+ # 32 bit compressible signed/unsigned
+ randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000}
+ } {
+ # 64 bit
+ randpath {randomSignedInt 1000000000000}
+ } {
+ # Random string
+ randpath {randstring 0 256 alpha} \
+ {randstring 0 256 compr} \
+ {randstring 0 256 binary}
+ }
+}
+
+proc randomKey {} {
+ randpath {
+ # Small enough to likely collide
+ randomInt 1000
+ } {
+ # 32 bit compressible signed/unsigned
+ randpath {randomInt 2000000000} {randomInt 4000000000}
+ } {
+ # 64 bit
+ randpath {randomInt 1000000000000}
+ } {
+ # Random string
+ randpath {randstring 1 256 alpha} \
+ {randstring 1 256 compr}
+ }
+}
+
+proc findKeyWithType {r type} {
+ for {set j 0} {$j < 20} {incr j} {
+ set k [{*}$r randomkey]
+ if {$k eq {}} {
+ return {}
+ }
+ if {[{*}$r type $k] eq $type} {
+ return $k
+ }
+ }
+ return {}
+}
+
+proc createComplexDataset {r ops {opt {}}} {
+ for {set j 0} {$j < $ops} {incr j} {
+ set k [randomKey]
+ set k2 [randomKey]
+ set f [randomValue]
+ set v [randomValue]
+
+ if {[lsearch -exact $opt useexpire] != -1} {
+ if {rand() < 0.1} {
+ {*}$r expire [randomKey] [randomInt 2]
+ }
+ }
+
+ randpath {
+ set d [expr {rand()}]
+ } {
+ set d [expr {rand()}]
+ } {
+ set d [expr {rand()}]
+ } {
+ set d [expr {rand()}]
+ } {
+ set d [expr {rand()}]
+ } {
+ randpath {set d +inf} {set d -inf}
+ }
+ set t [{*}$r type $k]
+
+ if {$t eq {none}} {
+ randpath {
+ {*}$r set $k $v
+ } {
+ {*}$r lpush $k $v
+ } {
+ {*}$r sadd $k $v
+ } {
+ {*}$r zadd $k $d $v
+ } {
+ {*}$r hset $k $f $v
+ } {
+ {*}$r del $k
+ }
+ set t [{*}$r type $k]
+ }
+
+ switch $t {
+ {string} {
+ # Nothing to do
+ }
+ {list} {
+ randpath {{*}$r lpush $k $v} \
+ {{*}$r rpush $k $v} \
+ {{*}$r lrem $k 0 $v} \
+ {{*}$r rpop $k} \
+ {{*}$r lpop $k}
+ }
+ {set} {
+ randpath {{*}$r sadd $k $v} \
+ {{*}$r srem $k $v} \
+ {
+ set otherset [findKeyWithType {*}$r set]
+ if {$otherset ne {}} {
+ randpath {
+ {*}$r sunionstore $k2 $k $otherset
+ } {
+ {*}$r sinterstore $k2 $k $otherset
+ } {
+ {*}$r sdiffstore $k2 $k $otherset
+ }
+ }
+ }
+ }
+ {zset} {
+ randpath {{*}$r zadd $k $d $v} \
+ {{*}$r zrem $k $v} \
+ {
+ set otherzset [findKeyWithType {*}$r zset]
+ if {$otherzset ne {}} {
+ randpath {
+ {*}$r zunionstore $k2 2 $k $otherzset
+ } {
+ {*}$r zinterstore $k2 2 $k $otherzset
+ }
+ }
+ }
+ }
+ {hash} {
+ randpath {{*}$r hset $k $f $v} \
+ {{*}$r hdel $k $f}
+ }
+ }
+ }
+}
+
+proc formatCommand {args} {
+ set cmd "*[llength $args]\r\n"
+ foreach a $args {
+ append cmd "$[string length $a]\r\n$a\r\n"
+ }
+ set _ $cmd
+}
+
+proc csvdump r {
+ set o {}
+ for {set db 0} {$db < 16} {incr db} {
+ {*}$r select $db
+ foreach k [lsort [{*}$r keys *]] {
+ set type [{*}$r type $k]
+ append o [csvstring $db] , [csvstring $k] , [csvstring $type] ,
+ switch $type {
+ string {
+ append o [csvstring [{*}$r get $k]] "\n"
+ }
+ list {
+ foreach e [{*}$r lrange $k 0 -1] {
+ append o [csvstring $e] ,
+ }
+ append o "\n"
+ }
+ set {
+ foreach e [lsort [{*}$r smembers $k]] {
+ append o [csvstring $e] ,
+ }
+ append o "\n"
+ }
+ zset {
+ foreach e [{*}$r zrange $k 0 -1 withscores] {
+ append o [csvstring $e] ,
+ }
+ append o "\n"
+ }
+ hash {
+ set fields [{*}$r hgetall $k]
+ set newfields {}
+ foreach {k v} $fields {
+ lappend newfields [list $k $v]
+ }
+ set fields [lsort -index 0 $newfields]
+ foreach kv $fields {
+ append o [csvstring [lindex $kv 0]] ,
+ append o [csvstring [lindex $kv 1]] ,
+ }
+ append o "\n"
+ }
+ }
+ }
+ }
+ {*}$r select 9
+ return $o
+}
+
+proc csvstring s {
+ return "\"$s\""
+}
+
+proc roundFloat f {
+ format "%.10g" $f
+}
+
+proc find_available_port start {
+ for {set j $start} {$j < $start+1024} {incr j} {
+ if {[catch {set fd1 [socket 127.0.0.1 $j]}] &&
+ [catch {set fd2 [socket 127.0.0.1 [expr $j+10000]]}]} {
+ return $j
+ } else {
+ catch {
+ close $fd1
+ close $fd2
+ }
+ }
+ }
+ if {$j == $start+1024} {
+ error "Can't find a non busy port in the $start-[expr {$start+1023}] range."
+ }
+}
+
+# Test if TERM looks like to support colors
+proc color_term {} {
+ expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
+}
+
+proc colorstr {color str} {
+ if {[color_term]} {
+ set b 0
+ if {[string range $color 0 4] eq {bold-}} {
+ set b 1
+ set color [string range $color 5 end]
+ }
+ switch $color {
+ red {set colorcode {31}}
+ green {set colorcode {32}}
+ yellow {set colorcode {33}}
+ blue {set colorcode {34}}
+ magenta {set colorcode {35}}
+ cyan {set colorcode {36}}
+ white {set colorcode {37}}
+ default {set colorcode {37}}
+ }
+ if {$colorcode ne {}} {
+ return "\033\[$b;${colorcode};49m$str\033\[0m"
+ }
+ } else {
+ return $str
+ }
+}
+
+# Execute a background process writing random data for the specified number
+# of seconds to the specified Redis instance.
+proc start_write_load {host port seconds} {
+ set tclsh [info nameofexecutable]
+ exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds &
+}
+
+# Stop a process generating write load executed with start_write_load.
+proc stop_write_load {handle} {
+ catch {exec /bin/kill -9 $handle}
+}
diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
new file mode 100644
index 0000000..fdfe6a0
--- /dev/null
+++ b/tests/test_helper.tcl
@@ -0,0 +1,563 @@
+# Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo [email protected]
+# This software is released under the BSD License. See the COPYING file for
+# more information.
+
+package require Tcl 8.5
+
+set tcl_precision 17
+source tests/support/redis.tcl
+source tests/support/server.tcl
+source tests/support/tmpfile.tcl
+source tests/support/test.tcl
+source tests/support/util.tcl
+
+set ::all_tests {
+ unit/printver
+ unit/dump
+ unit/auth
+ unit/protocol
+ unit/keyspace
+ unit/scan
+ unit/type/string
+ unit/type/incr
+ unit/type/list
+ unit/type/list-2
+ unit/type/list-3
+ unit/type/set
+ unit/type/zset
+ unit/type/hash
+ unit/sort
+ unit/expire
+ unit/other
+ unit/multi
+ unit/quit
+ unit/aofrw
+ integration/replication
+ integration/replication-2
+ integration/replication-3
+ integration/replication-4
+ integration/replication-psync
+ integration/aof
+ integration/rdb
+ integration/convert-zipmap-hash-on-load
+ integration/logging
+ integration/psync2
+ unit/pubsub
+ unit/slowlog
+ unit/scripting
+ unit/maxmemory
+ unit/introspection
+ unit/introspection-2
+ unit/limits
+ unit/obuf-limits
+ unit/bitops
+ unit/bitfield
+ unit/geo
+ unit/memefficiency
+ unit/hyperloglog
+ unit/lazyfree
+ unit/wait
+}
+# Index to the next test to run in the ::all_tests list.
+set ::next_test 0
+
+set ::host 127.0.0.1
+set ::port 21111
+set ::traceleaks 0
+set ::valgrind 0
+set ::stack_logging 0
+set ::verbose 0
+set ::quiet 0
+set ::denytags {}
+set ::allowtags {}
+set ::external 0; # If "1" this means, we are running against external instance
+set ::file ""; # If set, runs only the tests in this comma separated list
+set ::curfile ""; # Hold the filename of the current suite
+set ::accurate 0; # If true runs fuzz tests with more iterations
+set ::force_failure 0
+set ::timeout 600; # 10 minutes without progresses will quit the test.
+set ::last_progress [clock seconds]
+set ::active_servers {} ; # Pids of active Redis instances.
+
+# Set to 1 when we are running in client mode. The Redis test uses a
+# server-client model to run tests simultaneously. The server instance
+# runs the specified number of client instances that will actually run tests.
+# The server is responsible of showing the result to the user, and exit with
+# the appropriate exit code depending on the test outcome.
+set ::client 0
+set ::numclients 16
+
+proc execute_tests name {
+ set path "tests/$name.tcl"
+ set ::curfile $path
+ source $path
+ send_data_packet $::test_server_fd done "$name"
+}
+
+# Setup a list to hold a stack of server configs. When calls to start_server
+# are nested, use "srv 0 pid" to get the pid of the inner server. To access
+# outer servers, use "srv -1 pid" etcetera.
+set ::servers {}
+proc srv {args} {
+ set level 0
+ if {[string is integer [lindex $args 0]]} {
+ set level [lindex $args 0]
+ set property [lindex $args 1]
+ } else {
+ set property [lindex $args 0]
+ }
+ set srv [lindex $::servers end+$level]
+ dict get $srv $property
+}
+
+# Provide easy access to the client for the inner server. It's possible to
+# prepend the argument list with a negative level to access clients for
+# servers running in outer blocks.
+proc r {args} {
+ set level 0
+ if {[string is integer [lindex $args 0]]} {
+ set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ [srv $level "client"] {*}$args
+}
+
+proc reconnect {args} {
+ set level [lindex $args 0]
+ if {[string length $level] == 0 || ![string is integer $level]} {
+ set level 0
+ }
+
+ set srv [lindex $::servers end+$level]
+ set host [dict get $srv "host"]
+ set port [dict get $srv "port"]
+ set config [dict get $srv "config"]
+ set client [redis $host $port]
+ dict set srv "client" $client
+
+ # select the right db when we don't have to authenticate
+ if {![dict exists $config "requirepass"]} {
+ $client select 9
+ }
+
+ # re-set $srv in the servers list
+ lset ::servers end+$level $srv
+}
+
+proc redis_deferring_client {args} {
+ set level 0
+ if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
+ set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+
+ # create client that defers reading reply
+ set client [redis [srv $level "host"] [srv $level "port"] 1]
+
+ # select the right db and read the response (OK)
+ $client select 9
+ $client read
+ return $client
+}
+
+# Provide easy access to INFO properties. Same semantic as "proc r".
+proc s {args} {
+ set level 0
+ if {[string is integer [lindex $args 0]]} {
+ set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ status [srv $level "client"] [lindex $args 0]
+}
+
+proc cleanup {} {
+ if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "}
+ flush stdout
+ catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
+ catch {exec rm -rf {*}[glob tests/tmp/server.*]}
+ if {!$::quiet} {puts "OK"}
+}
+
+proc test_server_main {} {
+ cleanup
+ set tclsh [info nameofexecutable]
+ # Open a listening socket, trying different ports in order to find a
+ # non busy one.
+ set port [find_available_port 11111]
+ if {!$::quiet} {
+ puts "Starting test server at port $port"
+ }
+ socket -server accept_test_clients -myaddr 127.0.0.1 $port
+
+ # Start the client instances
+ set ::clients_pids {}
+ set start_port [expr {$::port+100}]
+ for {set j 0} {$j < $::numclients} {incr j} {
+ set start_port [find_available_port $start_port]
+ set p [exec $tclsh [info script] {*}$::argv \
+ --client $port --port $start_port &]
+ lappend ::clients_pids $p
+ incr start_port 10
+ }
+
+ # Setup global state for the test server
+ set ::idle_clients {}
+ set ::active_clients {}
+ array set ::active_clients_task {}
+ array set ::clients_start_time {}
+ set ::clients_time_history {}
+ set ::failed_tests {}
+
+ # Enter the event loop to handle clients I/O
+ after 100 test_server_cron
+ vwait forever
+}
+
+# This function gets called 10 times per second.
+proc test_server_cron {} {
+ set elapsed [expr {[clock seconds]-$::last_progress}]
+
+ if {$elapsed > $::timeout} {
+ set err "\[[colorstr red TIMEOUT]\]: clients state report follows."
+ puts $err
+ show_clients_state
+ kill_clients
+ force_kill_all_servers
+ the_end
+ }
+
+ after 100 test_server_cron
+}
+
+proc accept_test_clients {fd addr port} {
+ fconfigure $fd -encoding binary
+ fileevent $fd readable [list read_from_test_client $fd]
+}
+
+# This is the readable handler of our test server. Clients send us messages
+# in the form of a status code such and additional data. Supported
+# status types are:
+#
+# ready: the client is ready to execute the command. Only sent at client
+# startup. The server will queue the client FD in the list of idle
+# clients.
+# testing: just used to signal that a given test started.
+# ok: a test was executed with success.
+# err: a test was executed with an error.
+# exception: there was a runtime exception while executing the test.
+# done: all the specified test file was processed, this test client is
+# ready to accept a new task.
+proc read_from_test_client fd {
+ set bytes [gets $fd]
+ set payload [read $fd $bytes]
+ foreach {status data} $payload break
+ set ::last_progress [clock seconds]
+
+ if {$status eq {ready}} {
+ if {!$::quiet} {
+ puts "\[$status\]: $data"
+ }
+ signal_idle_client $fd
+ } elseif {$status eq {done}} {
+ set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
+ set all_tests_count [llength $::all_tests]
+ set running_tests_count [expr {[llength $::active_clients]-1}]
+ set completed_tests_count [expr {$::next_test-$running_tests_count}]
+ puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)"
+ lappend ::clients_time_history $elapsed $data
+ signal_idle_client $fd
+ set ::active_clients_task($fd) DONE
+ } elseif {$status eq {ok}} {
+ if {!$::quiet} {
+ puts "\[[colorstr green $status]\]: $data"
+ }
+ set ::active_clients_task($fd) "(OK) $data"
+ } elseif {$status eq {err}} {
+ set err "\[[colorstr red $status]\]: $data"
+ puts $err
+ lappend ::failed_tests $err
+ set ::active_clients_task($fd) "(ERR) $data"
+ } elseif {$status eq {exception}} {
+ puts "\[[colorstr red $status]\]: $data"
+ kill_clients
+ force_kill_all_servers
+ exit 1
+ } elseif {$status eq {testing}} {
+ set ::active_clients_task($fd) "(IN PROGRESS) $data"
+ } elseif {$status eq {server-spawned}} {
+ lappend ::active_servers $data
+ } elseif {$status eq {server-killed}} {
+ set ::active_servers [lsearch -all -inline -not -exact $::active_servers $data]
+ } else {
+ if {!$::quiet} {
+ puts "\[$status\]: $data"
+ }
+ }
+}
+
+proc show_clients_state {} {
+ # The following loop is only useful for debugging tests that may
+ # enter an infinite loop. Commented out normally.
+ foreach x $::active_clients {
+ if {[info exist ::active_clients_task($x)]} {
+ puts "$x => $::active_clients_task($x)"
+ } else {
+ puts "$x => ???"
+ }
+ }
+}
+
+proc kill_clients {} {
+ foreach p $::clients_pids {
+ catch {exec kill $p}
+ }
+}
+
+proc force_kill_all_servers {} {
+ foreach p $::active_servers {
+ puts "Killing still running Redis server $p"
+ catch {exec kill -9 $p}
+ }
+}
+
+# A new client is idle. Remove it from the list of active clients and
+# if there are still test units to run, launch them.
+proc signal_idle_client fd {
+ # Remove this fd from the list of active clients.
+ set ::active_clients \
+ [lsearch -all -inline -not -exact $::active_clients $fd]
+
+ if 0 {show_clients_state}
+
+ # New unit to process?
+ if {$::next_test != [llength $::all_tests]} {
+ if {!$::quiet} {
+ puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"]
+ set ::active_clients_task($fd) "ASSIGNED: $fd ([lindex $::all_tests $::next_test])"
+ }
+ set ::clients_start_time($fd) [clock seconds]
+ send_data_packet $fd run [lindex $::all_tests $::next_test]
+ lappend ::active_clients $fd
+ incr ::next_test
+ } else {
+ lappend ::idle_clients $fd
+ if {[llength $::active_clients] == 0} {
+ the_end
+ }
+ }
+}
+
+# The the_end function gets called when all the test units were already
+# executed, so the test finished.
+proc the_end {} {
+ # TODO: print the status, exit with the rigth exit code.
+ puts "\n The End\n"
+ puts "Execution time of different units:"
+ foreach {time name} $::clients_time_history {
+ puts " $time seconds - $name"
+ }
+ if {[llength $::failed_tests]} {
+ puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n"
+ foreach failed $::failed_tests {
+ puts "*** $failed"
+ }
+ cleanup
+ exit 1
+ } else {
+ puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n"
+ cleanup
+ exit 0
+ }
+}
+
+# The client is not even driven (the test server is instead) as we just need
+# to read the command, execute, reply... all this in a loop.
+proc test_client_main server_port {
+ set ::test_server_fd [socket localhost $server_port]
+ fconfigure $::test_server_fd -encoding binary
+ send_data_packet $::test_server_fd ready [pid]
+ while 1 {
+ set bytes [gets $::test_server_fd]
+ set payload [read $::test_server_fd $bytes]
+ foreach {cmd data} $payload break
+ if {$cmd eq {run}} {
+ execute_tests $data
+ } else {
+ error "Unknown test client command: $cmd"
+ }
+ }
+}
+
+proc send_data_packet {fd status data} {
+ set payload [list $status $data]
+ puts $fd [string length $payload]
+ puts -nonewline $fd $payload
+ flush $fd
+}
+
+proc print_help_screen {} {
+ puts [join {
+ "--valgrind Run the test over valgrind."
+ "--stack-logging Enable OSX leaks/malloc stack logging."
+ "--accurate Run slow randomized tests for more iterations."
+ "--quiet Don't show individual tests."
+ "--single <unit> Just execute the specified unit (see next option)."
+ "--list-tests List all the available test units."
+ "--clients <num> Number of test clients (default 16)."
+ "--timeout <sec> Test timeout in seconds (default 10 min)."
+ "--force-failure Force the execution of a test that always fails."
+ "--help Print this help screen."
+ } "\n"]
+}
+
+# parse arguments
+for {set j 0} {$j < [llength $argv]} {incr j} {
+ set opt [lindex $argv $j]
+ set arg [lindex $argv [expr $j+1]]
+ if {$opt eq {--tags}} {
+ foreach tag $arg {
+ if {[string index $tag 0] eq "-"} {
+ lappend ::denytags [string range $tag 1 end]
+ } else {
+ lappend ::allowtags $tag
+ }
+ }
+ incr j
+ } elseif {$opt eq {--valgrind}} {
+ set ::valgrind 1
+ } elseif {$opt eq {--stack-logging}} {
+ if {[string match {*Darwin*} [exec uname -a]]} {
+ set ::stack_logging 1
+ }
+ } elseif {$opt eq {--quiet}} {
+ set ::quiet 1
+ } elseif {$opt eq {--host}} {
+ set ::external 1
+ set ::host $arg
+ incr j
+ } elseif {$opt eq {--port}} {
+ set ::port $arg
+ incr j
+ } elseif {$opt eq {--accurate}} {
+ set ::accurate 1
+ } elseif {$opt eq {--force-failure}} {
+ set ::force_failure 1
+ } elseif {$opt eq {--single}} {
+ set ::all_tests $arg
+ incr j
+ } elseif {$opt eq {--list-tests}} {
+ foreach t $::all_tests {
+ puts $t
+ }
+ exit 0
+ } elseif {$opt eq {--client}} {
+ set ::client 1
+ set ::test_server_port $arg
+ incr j
+ } elseif {$opt eq {--clients}} {
+ set ::numclients $arg
+ incr j
+ } elseif {$opt eq {--timeout}} {
+ set ::timeout $arg
+ incr j
+ } elseif {$opt eq {--help}} {
+ print_help_screen
+ exit 0
+ } else {
+ puts "Wrong argument: $opt"
+ exit 1
+ }
+}
+
+proc attach_to_replication_stream {} {
+ set s [socket [srv 0 "host"] [srv 0 "port"]]
+ fconfigure $s -translation binary
+ puts -nonewline $s "SYNC\r\n"
+ flush $s
+
+ # Get the count
+ while 1 {
+ set count [gets $s]
+ set prefix [string range $count 0 0]
+ if {$prefix ne {}} break; # Newlines are allowed as PINGs.
+ }
+ if {$prefix ne {$}} {
+ error "attach_to_replication_stream error. Received '$count' as count."
+ }
+ set count [string range $count 1 end]
+
+ # Consume the bulk payload
+ while {$count} {
+ set buf [read $s $count]
+ set count [expr {$count-[string length $buf]}]
+ }
+ return $s
+}
+
+proc read_from_replication_stream {s} {
+ fconfigure $s -blocking 0
+ set attempt 0
+ while {[gets $s count] == -1} {
+ if {[incr attempt] == 10} return ""
+ after 100
+ }
+ fconfigure $s -blocking 1
+ set count [string range $count 1 end]
+
+ # Return a list of arguments for the command.
+ set res {}
+ for {set j 0} {$j < $count} {incr j} {
+ read $s 1
+ set arg [::redis::redis_bulk_read $s]
+ if {$j == 0} {set arg [string tolower $arg]}
+ lappend res $arg
+ }
+ return $res
+}
+
+proc assert_replication_stream {s patterns} {
+ for {set j 0} {$j < [llength $patterns]} {incr j} {
+ assert_match [lindex $patterns $j] [read_from_replication_stream $s]
+ }
+}
+
+proc close_replication_stream {s} {
+ close $s
+}
+
+# With the parallel test running multiple Redis instances at the same time
+# we need a fast enough computer, otherwise a lot of tests may generate
+# false positives.
+# If the computer is too slow we revert the sequential test without any
+# parallelism, that is, clients == 1.
+proc is_a_slow_computer {} {
+ set start [clock milliseconds]
+ for {set j 0} {$j < 1000000} {incr j} {}
+ set elapsed [expr [clock milliseconds]-$start]
+ expr {$elapsed > 200}
+}
+
+if {$::client} {
+ if {[catch { test_client_main $::test_server_port } err]} {
+ set estr "Executing test client: $err.\n$::errorInfo"
+ if {[catch {send_data_packet $::test_server_fd exception $estr}]} {
+ puts $estr
+ }
+ exit 1
+ }
+} else {
+ if {[is_a_slow_computer]} {
+ puts "** SLOW COMPUTER ** Using a single client to avoid false positives."
+ set ::numclients 1
+ }
+
+ if {[catch { test_server_main } err]} {
+ if {[string length $err] > 0} {
+ # only display error when not generated by the test suite
+ if {$err ne "exception"} {
+ puts $::errorInfo
+ }
+ exit 1
+ }
+ }
+}
diff --git a/tests/unit/aofrw.tcl b/tests/unit/aofrw.tcl
new file mode 100644
index 0000000..dff7588
--- /dev/null
+++ b/tests/unit/aofrw.tcl
@@ -0,0 +1,213 @@
+start_server {tags {"aofrw"}} {
+ # Enable the AOF
+ r config set appendonly yes
+ r config set auto-aof-rewrite-percentage 0 ; # Disable auto-rewrite.
+ waitForBgrewriteaof r
+
+ foreach rdbpre {yes no} {
+ r config set aof-use-rdb-preamble $rdbpre
+ test "AOF rewrite during write load: RDB preamble=$rdbpre" {
+ # Start a write load for 10 seconds
+ set master [srv 0 client]
+ set master_host [srv 0 host]
+ set master_port [srv 0 port]
+ set load_handle0 [start_write_load $master_host $master_port 10]
+ set load_handle1 [start_write_load $master_host $master_port 10]
+ set load_handle2 [start_write_load $master_host $master_port 10]
+ set load_handle3 [start_write_load $master_host $master_port 10]
+ set load_handle4 [start_write_load $master_host $master_port 10]
+
+ # Make sure the instance is really receiving data
+ wait_for_condition 50 100 {
+ [r dbsize] > 0
+ } else {
+ fail "No write load detected."
+ }
+
+ # After 3 seconds, start a rewrite, while the write load is still
+ # active.
+ after 3000
+ r bgrewriteaof
+ waitForBgrewriteaof r
+
+ # Let it run a bit more so that we'll append some data to the new
+ # AOF.
+ after 1000
+
+ # Stop the processes generating the load if they are still active
+ stop_write_load $load_handle0
+ stop_write_load $load_handle1
+ stop_write_load $load_handle2
+ stop_write_load $load_handle3
+ stop_write_load $load_handle4
+
+ # Make sure that we remain the only connected client.
+ # This step is needed to make sure there are no pending writes
+ # that will be processed between the two "debug digest" calls.
+ wait_for_condition 50 100 {
+ [llength [split [string trim [r client list]] "\n"]] == 1
+ } else {
+ puts [r client list]
+ fail "Clients generating loads are not disconnecting"
+ }
+
+ # Get the data set digest
+ set d1 [r debug digest]
+
+ # Load the AOF
+ r debug loadaof
+ set d2 [r debug digest]
+
+ # Make sure they are the same
+ assert {$d1 eq $d2}
+ }
+ }
+}
+
+start_server {tags {"aofrw"}} {
+ test {Turning off AOF kills the background writing child if any} {
+ r config set appendonly yes
+ waitForBgrewriteaof r
+ r multi
+ r bgrewriteaof
+ r config set appendonly no
+ r exec
+ wait_for_condition 50 100 {
+ [string match {*Killing*AOF*child*} [exec tail -5 < [srv 0 stdout]]]
+ } else {
+ fail "Can't find 'Killing AOF child' into recent logs"
+ }
+ }
+
+ foreach d {string int} {
+ foreach e {quicklist} {
+ test "AOF rewrite of list with $e encoding, $d data" {
+ r flushall
+ set len 1000
+ for {set j 0} {$j < $len} {incr j} {
+ if {$d eq {string}} {
+ set data [randstring 0 16 alpha]
+ } else {
+ set data [randomInt 4000000000]
+ }
+ r lpush key $data
+ }
+ assert_equal [r object encoding key] $e
+ set d1 [r debug digest]
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set d2 [r debug digest]
+ if {$d1 ne $d2} {
+ error "assertion:$d1 is not equal to $d2"
+ }
+ }
+ }
+ }
+
+ foreach d {string int} {
+ foreach e {intset hashtable} {
+ test "AOF rewrite of set with $e encoding, $d data" {
+ r flushall
+ if {$e eq {intset}} {set len 10} else {set len 1000}
+ for {set j 0} {$j < $len} {incr j} {
+ if {$d eq {string}} {
+ set data [randstring 0 16 alpha]
+ } else {
+ set data [randomInt 4000000000]
+ }
+ r sadd key $data
+ }
+ if {$d ne {string}} {
+ assert_equal [r object encoding key] $e
+ }
+ set d1 [r debug digest]
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set d2 [r debug digest]
+ if {$d1 ne $d2} {
+ error "assertion:$d1 is not equal to $d2"
+ }
+ }
+ }
+ }
+
+ foreach d {string int} {
+ foreach e {ziplist hashtable} {
+ test "AOF rewrite of hash with $e encoding, $d data" {
+ r flushall
+ if {$e eq {ziplist}} {set len 10} else {set len 1000}
+ for {set j 0} {$j < $len} {incr j} {
+ if {$d eq {string}} {
+ set data [randstring 0 16 alpha]
+ } else {
+ set data [randomInt 4000000000]
+ }
+ r hset key $data $data
+ }
+ assert_equal [r object encoding key] $e
+ set d1 [r debug digest]
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set d2 [r debug digest]
+ if {$d1 ne $d2} {
+ error "assertion:$d1 is not equal to $d2"
+ }
+ }
+ }
+ }
+
+ foreach d {string int} {
+ foreach e {ziplist skiplist} {
+ test "AOF rewrite of zset with $e encoding, $d data" {
+ r flushall
+ if {$e eq {ziplist}} {set len 10} else {set len 1000}
+ for {set j 0} {$j < $len} {incr j} {
+ if {$d eq {string}} {
+ set data [randstring 0 16 alpha]
+ } else {
+ set data [randomInt 4000000000]
+ }
+ r zadd key [expr rand()] $data
+ }
+ assert_equal [r object encoding key] $e
+ set d1 [r debug digest]
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set d2 [r debug digest]
+ if {$d1 ne $d2} {
+ error "assertion:$d1 is not equal to $d2"
+ }
+ }
+ }
+ }
+
+ test {BGREWRITEAOF is delayed if BGSAVE is in progress} {
+ r multi
+ r bgsave
+ r bgrewriteaof
+ r info persistence
+ set res [r exec]
+ assert_match {*scheduled*} [lindex $res 1]
+ assert_match {*aof_rewrite_scheduled:1*} [lindex $res 2]
+ while {[string match {*aof_rewrite_scheduled:1*} [r info persistence]]} {
+ after 100
+ }
+ }
+
+ test {BGREWRITEAOF is refused if already in progress} {
+ catch {
+ r multi
+ r bgrewriteaof
+ r bgrewriteaof
+ r exec
+ } e
+ assert_match {*ERR*already*} $e
+ while {[string match {*aof_rewrite_scheduled:1*} [r info persistence]]} {
+ after 100
+ }
+ }
+}
diff --git a/tests/unit/auth.tcl b/tests/unit/auth.tcl
new file mode 100644
index 0000000..633cda9
--- /dev/null
+++ b/tests/unit/auth.tcl
@@ -0,0 +1,27 @@
+start_server {tags {"auth"}} {
+ test {AUTH fails if there is no password configured server side} {
+ catch {r auth foo} err
+ set _ $err
+ } {ERR*no password*}
+}
+
+start_server {tags {"auth"} overrides {requirepass foobar}} {
+ test {AUTH fails when a wrong password is given} {
+ catch {r auth wrong!} err
+ set _ $err
+ } {ERR*invalid password}
+
+ test {Arbitrary command gives an error when AUTH is required} {
+ catch {r set foo bar} err
+ set _ $err
+ } {NOAUTH*}
+
+ test {AUTH succeeds when the right password is given} {
+ r auth foobar
+ } {OK}
+
+ test {Once AUTH succeeded we can actually send commands to the server} {
+ r set foo 100
+ r incr foo
+ } {101}
+}
diff --git a/tests/unit/bitfield.tcl b/tests/unit/bitfield.tcl
new file mode 100644
index 0000000..d76452b
--- /dev/null
+++ b/tests/unit/bitfield.tcl
@@ -0,0 +1,201 @@
+start_server {tags {"bitops"}} {
+ test {BITFIELD signed SET and GET basics} {
+ r del bits
+ set results {}
+ lappend results [r bitfield bits set i8 0 -100]
+ lappend results [r bitfield bits set i8 0 101]
+ lappend results [r bitfield bits get i8 0]
+ set results
+ } {0 -100 101}
+
+ test {BITFIELD unsigned SET and GET basics} {
+ r del bits
+ set results {}
+ lappend results [r bitfield bits set u8 0 255]
+ lappend results [r bitfield bits set u8 0 100]
+ lappend results [r bitfield bits get u8 0]
+ set results
+ } {0 255 100}
+
+ test {BITFIELD #<idx> form} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 65
+ r bitfield bits set u8 #1 66
+ r bitfield bits set u8 #2 67
+ r get bits
+ } {ABC}
+
+ test {BITFIELD basic INCRBY form} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 10
+ lappend results [r bitfield bits incrby u8 #0 100]
+ lappend results [r bitfield bits incrby u8 #0 100]
+ set results
+ } {110 210}
+
+ test {BITFIELD chaining of multiple commands} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 10
+ lappend results [r bitfield bits incrby u8 #0 100 incrby u8 #0 100]
+ set results
+ } {{110 210}}
+
+ test {BITFIELD unsigned overflow wrap} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 100
+ lappend results [r bitfield bits overflow wrap incrby u8 #0 257]
+ lappend results [r bitfield bits get u8 #0]
+ lappend results [r bitfield bits overflow wrap incrby u8 #0 255]
+ lappend results [r bitfield bits get u8 #0]
+ } {101 101 100 100}
+
+ test {BITFIELD unsigned overflow sat} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 100
+ lappend results [r bitfield bits overflow sat incrby u8 #0 257]
+ lappend results [r bitfield bits get u8 #0]
+ lappend results [r bitfield bits overflow sat incrby u8 #0 -255]
+ lappend results [r bitfield bits get u8 #0]
+ } {255 255 0 0}
+
+ test {BITFIELD signed overflow wrap} {
+ r del bits
+ set results {}
+ r bitfield bits set i8 #0 100
+ lappend results [r bitfield bits overflow wrap incrby i8 #0 257]
+ lappend results [r bitfield bits get i8 #0]
+ lappend results [r bitfield bits overflow wrap incrby i8 #0 255]
+ lappend results [r bitfield bits get i8 #0]
+ } {101 101 100 100}
+
+ test {BITFIELD signed overflow sat} {
+ r del bits
+ set results {}
+ r bitfield bits set u8 #0 100
+ lappend results [r bitfield bits overflow sat incrby i8 #0 257]
+ lappend results [r bitfield bits get i8 #0]
+ lappend results [r bitfield bits overflow sat incrby i8 #0 -255]
+ lappend results [r bitfield bits get i8 #0]
+ } {127 127 -128 -128}
+
+ test {BITFIELD overflow detection fuzzing} {
+ for {set j 0} {$j < 1000} {incr j} {
+ set bits [expr {[randomInt 64]+1}]
+ set sign [randomInt 2]
+ set range [expr {2**$bits}]
+ if {$bits == 64} {set sign 1} ; # u64 is not supported by BITFIELD.
+ if {$sign} {
+ set min [expr {-($range/2)}]
+ set type "i$bits"
+ } else {
+ set min 0
+ set type "u$bits"
+ }
+ set max [expr {$min+$range-1}]
+
+ # Compare Tcl vs Redis
+ set range2 [expr {$range*2}]
+ set value [expr {($min*2)+[randomInt $range2]}]
+ set increment [expr {($min*2)+[randomInt $range2]}]
+ if {$value > 9223372036854775807} {
+ set value 9223372036854775807
+ }
+ if {$value < -9223372036854775808} {
+ set value -9223372036854775808
+ }
+ if {$increment > 9223372036854775807} {
+ set increment 9223372036854775807
+ }
+ if {$increment < -9223372036854775808} {
+ set increment -9223372036854775808
+ }
+
+ set overflow 0
+ if {$value > $max || $value < $min} {set overflow 1}
+ if {($value + $increment) > $max} {set overflow 1}
+ if {($value + $increment) < $min} {set overflow 1}
+
+ r del bits
+ set res1 [r bitfield bits overflow fail set $type 0 $value]
+ set res2 [r bitfield bits overflow fail incrby $type 0 $increment]
+
+ if {$overflow && [lindex $res1 0] ne {} &&
+ [lindex $res2 0] ne {}} {
+ fail "OW not detected where needed: $type $value+$increment"
+ }
+ if {!$overflow && ([lindex $res1 0] eq {} ||
+ [lindex $res2 0] eq {})} {
+ fail "OW detected where NOT needed: $type $value+$increment"
+ }
+ }
+ }
+
+ test {BITFIELD overflow wrap fuzzing} {
+ for {set j 0} {$j < 1000} {incr j} {
+ set bits [expr {[randomInt 64]+1}]
+ set sign [randomInt 2]
+ set range [expr {2**$bits}]
+ if {$bits == 64} {set sign 1} ; # u64 is not supported by BITFIELD.
+ if {$sign} {
+ set min [expr {-($range/2)}]
+ set type "i$bits"
+ } else {
+ set min 0
+ set type "u$bits"
+ }
+ set max [expr {$min+$range-1}]
+
+ # Compare Tcl vs Redis
+ set range2 [expr {$range*2}]
+ set value [expr {($min*2)+[randomInt $range2]}]
+ set increment [expr {($min*2)+[randomInt $range2]}]
+ if {$value > 9223372036854775807} {
+ set value 9223372036854775807
+ }
+ if {$value < -9223372036854775808} {
+ set value -9223372036854775808
+ }
+ if {$increment > 9223372036854775807} {
+ set increment 9223372036854775807
+ }
+ if {$increment < -9223372036854775808} {
+ set increment -9223372036854775808
+ }
+
+ r del bits
+ r bitfield bits overflow wrap set $type 0 $value
+ r bitfield bits overflow wrap incrby $type 0 $increment
+ set res [lindex [r bitfield bits get $type 0] 0]
+
+ set expected 0
+ if {$sign} {incr expected [expr {$max+1}]}
+ incr expected $value
+ incr expected $increment
+ set expected [expr {$expected % $range}]
+ if {$sign} {incr expected $min}
+
+ if {$res != $expected} {
+ fail "WRAP error: $type $value+$increment = $res, should be $expected"
+ }
+ }
+ }
+
+ test {BITFIELD regression for #3221} {
+ r set bits 1
+ r bitfield bits get u1 0
+ } {0}
+
+ test {BITFIELD regression for #3564} {
+ for {set j 0} {$j < 10} {incr j} {
+ r del mystring
+ set res [r BITFIELD mystring SET i8 0 10 SET i8 64 10 INCRBY i8 10 99900]
+ assert {$res eq {0 0 60}}
+ }
+ r del mystring
+ }
+}
diff --git a/tests/unit/bitops.tcl b/tests/unit/bitops.tcl
new file mode 100644
index 0000000..926f382
--- /dev/null
+++ b/tests/unit/bitops.tcl
@@ -0,0 +1,351 @@
+# Compare Redis commands against Tcl implementations of the same commands.
+proc count_bits s {
+ binary scan $s b* bits
+ string length [regsub -all {0} $bits {}]
+}
+
+proc simulate_bit_op {op args} {
+ set maxlen 0
+ set j 0
+ set count [llength $args]
+ foreach a $args {
+ binary scan $a b* bits
+ set b($j) $bits
+ if {[string length $bits] > $maxlen} {
+ set maxlen [string length $bits]
+ }
+ incr j
+ }
+ for {set j 0} {$j < $count} {incr j} {
+ if {[string length $b($j)] < $maxlen} {
+ append b($j) [string repeat 0 [expr $maxlen-[string length $b($j)]]]
+ }
+ }
+ set out {}
+ for {set x 0} {$x < $maxlen} {incr x} {
+ set bit [string range $b(0) $x $x]
+ if {$op eq {not}} {set bit [expr {!$bit}]}
+ for {set j 1} {$j < $count} {incr j} {
+ set bit2 [string range $b($j) $x $x]
+ switch $op {
+ and {set bit [expr {$bit & $bit2}]}
+ or {set bit [expr {$bit | $bit2}]}
+ xor {set bit [expr {$bit ^ $bit2}]}
+ }
+ }
+ append out $bit
+ }
+ binary format b* $out
+}
+
+start_server {tags {"bitops"}} {
+ test {BITCOUNT returns 0 against non existing key} {
+ r bitcount no-key
+ } 0
+
+ test {BITCOUNT returns 0 with out of range indexes} {
+ r set str "xxxx"
+ r bitcount str 4 10
+ } 0
+
+ test {BITCOUNT returns 0 with negative indexes where start > end} {
+ r set str "xxxx"
+ r bitcount str -6 -7
+ } 0
+
+ catch {unset num}
+ foreach vec [list "" "\xaa" "\x00\x00\xff" "foobar" "123"] {
+ incr num
+ test "BITCOUNT against test vector #$num" {
+ r set str $vec
+ assert {[r bitcount str] == [count_bits $vec]}
+ }
+ }
+
+ test {BITCOUNT fuzzing without start/end} {
+ for {set j 0} {$j < 100} {incr j} {
+ set str [randstring 0 3000]
+ r set str $str
+ assert {[r bitcount str] == [count_bits $str]}
+ }
+ }
+
+ test {BITCOUNT fuzzing with start/end} {
+ for {set j 0} {$j < 100} {incr j} {
+ set str [randstring 0 3000]
+ r set str $str
+ set l [string length $str]
+ set start [randomInt $l]
+ set end [randomInt $l]
+ if {$start > $end} {
+ lassign [list $end $start] start end
+ }
+ assert {[r bitcount str $start $end] == [count_bits [string range $str $start $end]]}
+ }
+ }
+
+ test {BITCOUNT with start, end} {
+ r set s "foobar"
+ assert_equal [r bitcount s 0 -1] [count_bits "foobar"]
+ assert_equal [r bitcount s 1 -2] [count_bits "ooba"]
+ assert_equal [r bitcount s -2 1] [count_bits ""]
+ assert_equal [r bitcount s 0 1000] [count_bits "foobar"]
+ }
+
+ test {BITCOUNT syntax error #1} {
+ catch {r bitcount s 0} e
+ set e
+ } {ERR*syntax*}
+
+ test {BITCOUNT regression test for github issue #582} {
+ r del foo
+ r setbit foo 0 1
+ if {[catch {r bitcount foo 0 4294967296} e]} {
+ assert_match {*ERR*out of range*} $e
+ set _ 1
+ } else {
+ set e
+ }
+ } {1}
+
+ test {BITCOUNT misaligned prefix} {
+ r del str
+ r set str ab
+ r bitcount str 1 -1
+ } {3}
+
+ test {BITCOUNT misaligned prefix + full words + remainder} {
+ r del str
+ r set str __PPxxxxxxxxxxxxxxxxRR__
+ r bitcount str 2 -3
+ } {74}
+
+ test {BITOP NOT (empty string)} {
+ r set s ""
+ r bitop not dest s
+ r get dest
+ } {}
+
+ test {BITOP NOT (known string)} {
+ r set s "\xaa\x00\xff\x55"
+ r bitop not dest s
+ r get dest
+ } "\x55\xff\x00\xaa"
+
+ test {BITOP where dest and target are the same key} {
+ r set s "\xaa\x00\xff\x55"
+ r bitop not s s
+ r get s
+ } "\x55\xff\x00\xaa"
+
+ test {BITOP AND|OR|XOR don't change the string with single input key} {
+ r set a "\x01\x02\xff"
+ r bitop and res1 a
+ r bitop or res2 a
+ r bitop xor res3 a
+ list [r get res1] [r get res2] [r get res3]
+ } [list "\x01\x02\xff" "\x01\x02\xff" "\x01\x02\xff"]
+
+ test {BITOP missing key is considered a stream of zero} {
+ r set a "\x01\x02\xff"
+ r bitop and res1 no-suck-key a
+ r bitop or res2 no-suck-key a no-such-key
+ r bitop xor res3 no-such-key a
+ list [r get res1] [r get res2] [r get res3]
+ } [list "\x00\x00\x00" "\x01\x02\xff" "\x01\x02\xff"]
+
+ test {BITOP shorter keys are zero-padded to the key with max length} {
+ r set a "\x01\x02\xff\xff"
+ r set b "\x01\x02\xff"
+ r bitop and res1 a b
+ r bitop or res2 a b
+ r bitop xor res3 a b
+ list [r get res1] [r get res2] [r get res3]
+ } [list "\x01\x02\xff\x00" "\x01\x02\xff\xff" "\x00\x00\x00\xff"]
+
+ foreach op {and or xor} {
+ test "BITOP $op fuzzing" {
+ for {set i 0} {$i < 10} {incr i} {
+ r flushall
+ set vec {}
+ set veckeys {}
+ set numvec [expr {[randomInt 10]+1}]
+ for {set j 0} {$j < $numvec} {incr j} {
+ set str [randstring 0 1000]
+ lappend vec $str
+ lappend veckeys vector_$j
+ r set vector_$j $str
+ }
+ r bitop $op target {*}$veckeys
+ assert_equal [r get target] [simulate_bit_op $op {*}$vec]
+ }
+ }
+ }
+
+ test {BITOP NOT fuzzing} {
+ for {set i 0} {$i < 10} {incr i} {
+ r flushall
+ set str [randstring 0 1000]
+ r set str $str
+ r bitop not target str
+ assert_equal [r get target] [simulate_bit_op not $str]
+ }
+ }
+
+ test {BITOP with integer encoded source objects} {
+ r set a 1
+ r set b 2
+ r bitop xor dest a b a
+ r get dest
+ } {2}
+
+ test {BITOP with non string source key} {
+ r del c
+ r set a 1
+ r set b 2
+ r lpush c foo
+ catch {r bitop xor dest a b c d} e
+ set e
+ } {WRONGTYPE*}
+
+ test {BITOP with empty string after non empty string (issue #529)} {
+ r flushdb
+ r set a "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"
+ r bitop or x a b
+ } {32}
+
+ test {BITPOS bit=0 with empty key returns 0} {
+ r del str
+ r bitpos str 0
+ } {0}
+
+ test {BITPOS bit=1 with empty key returns -1} {
+ r del str
+ r bitpos str 1
+ } {-1}
+
+ test {BITPOS bit=0 with string less than 1 word works} {
+ r set str "\xff\xf0\x00"
+ r bitpos str 0
+ } {12}
+
+ test {BITPOS bit=1 with string less than 1 word works} {
+ r set str "\x00\x0f\x00"
+ r bitpos str 1
+ } {12}
+
+ test {BITPOS bit=0 starting at unaligned address} {
+ r set str "\xff\xf0\x00"
+ r bitpos str 0 1
+ } {12}
+
+ test {BITPOS bit=1 starting at unaligned address} {
+ r set str "\x00\x0f\xff"
+ r bitpos str 1 1
+ } {12}
+
+ test {BITPOS bit=0 unaligned+full word+reminder} {
+ r del str
+ r set str "\xff\xff\xff" ; # Prefix
+ # Followed by two (or four in 32 bit systems) full words
+ r append str "\xff\xff\xff\xff\xff\xff\xff\xff"
+ r append str "\xff\xff\xff\xff\xff\xff\xff\xff"
+ r append str "\xff\xff\xff\xff\xff\xff\xff\xff"
+ # First zero bit.
+ r append str "\x0f"
+ assert {[r bitpos str 0] == 216}
+ assert {[r bitpos str 0 1] == 216}
+ assert {[r bitpos str 0 2] == 216}
+ assert {[r bitpos str 0 3] == 216}
+ assert {[r bitpos str 0 4] == 216}
+ assert {[r bitpos str 0 5] == 216}
+ assert {[r bitpos str 0 6] == 216}
+ assert {[r bitpos str 0 7] == 216}
+ assert {[r bitpos str 0 8] == 216}
+ }
+
+ test {BITPOS bit=1 unaligned+full word+reminder} {
+ r del str
+ r set str "\x00\x00\x00" ; # Prefix
+ # Followed by two (or four in 32 bit systems) full words
+ r append str "\x00\x00\x00\x00\x00\x00\x00\x00"
+ r append str "\x00\x00\x00\x00\x00\x00\x00\x00"
+ r append str "\x00\x00\x00\x00\x00\x00\x00\x00"
+ # First zero bit.
+ r append str "\xf0"
+ assert {[r bitpos str 1] == 216}
+ assert {[r bitpos str 1 1] == 216}
+ assert {[r bitpos str 1 2] == 216}
+ assert {[r bitpos str 1 3] == 216}
+ assert {[r bitpos str 1 4] == 216}
+ assert {[r bitpos str 1 5] == 216}
+ assert {[r bitpos str 1 6] == 216}
+ assert {[r bitpos str 1 7] == 216}
+ assert {[r bitpos str 1 8] == 216}
+ }
+
+ test {BITPOS bit=1 returns -1 if string is all 0 bits} {
+ r set str ""
+ for {set j 0} {$j < 20} {incr j} {
+ assert {[r bitpos str 1] == -1}
+ r append str "\x00"
+ }
+ }
+
+ test {BITPOS bit=0 works with intervals} {
+ r set str "\x00\xff\x00"
+ assert {[r bitpos str 0 0 -1] == 0}
+ assert {[r bitpos str 0 1 -1] == 16}
+ assert {[r bitpos str 0 2 -1] == 16}
+ assert {[r bitpos str 0 2 200] == 16}
+ assert {[r bitpos str 0 1 1] == -1}
+ }
+
+ test {BITPOS bit=1 works with intervals} {
+ r set str "\x00\xff\x00"
+ assert {[r bitpos str 1 0 -1] == 8}
+ assert {[r bitpos str 1 1 -1] == 8}
+ assert {[r bitpos str 1 2 -1] == -1}
+ assert {[r bitpos str 1 2 200] == -1}
+ assert {[r bitpos str 1 1 1] == 8}
+ }
+
+ test {BITPOS bit=0 changes behavior if end is given} {
+ r set str "\xff\xff\xff"
+ assert {[r bitpos str 0] == 24}
+ assert {[r bitpos str 0 0] == 24}
+ assert {[r bitpos str 0 0 -1] == -1}
+ }
+
+ test {BITPOS bit=1 fuzzy testing using SETBIT} {
+ r del str
+ set max 524288; # 64k
+ set first_one_pos -1
+ for {set j 0} {$j < 1000} {incr j} {
+ assert {[r bitpos str 1] == $first_one_pos}
+ set pos [randomInt $max]
+ r setbit str $pos 1
+ if {$first_one_pos == -1 || $first_one_pos > $pos} {
+ # Update the position of the first 1 bit in the array
+ # if the bit we set is on the left of the previous one.
+ set first_one_pos $pos
+ }
+ }
+ }
+
+ test {BITPOS bit=0 fuzzy testing using SETBIT} {
+ set max 524288; # 64k
+ set first_zero_pos $max
+ r set str [string repeat "\xff" [expr $max/8]]
+ for {set j 0} {$j < 1000} {incr j} {
+ assert {[r bitpos str 0] == $first_zero_pos}
+ set pos [randomInt $max]
+ r setbit str $pos 0
+ if {$first_zero_pos > $pos} {
+ # Update the position of the first 0 bit in the array
+ # if the bit we clear is on the left of the previous one.
+ set first_zero_pos $pos
+ }
+ }
+ }
+}
diff --git a/tests/unit/dump.tcl b/tests/unit/dump.tcl
new file mode 100644
index 0000000..f5a29a0
--- /dev/null
+++ b/tests/unit/dump.tcl
@@ -0,0 +1,311 @@
+start_server {tags {"dump"}} {
+ test {DUMP / RESTORE are able to serialize / unserialize a simple key} {
+ r set foo bar
+ set encoded [r dump foo]
+ r del foo
+ list [r exists foo] [r restore foo 0 $encoded] [r ttl foo] [r get foo]
+ } {0 OK -1 bar}
+
+ test {RESTORE can set an arbitrary expire to the materialized key} {
+ r set foo bar
+ set encoded [r dump foo]
+ r del foo
+ r restore foo 5000 $encoded
+ set ttl [r pttl foo]
+ assert {$ttl >= 3000 && $ttl <= 5000}
+ r get foo
+ } {bar}
+
+ test {RESTORE can set an expire that overflows a 32 bit integer} {
+ r set foo bar
+ set encoded [r dump foo]
+ r del foo
+ r restore foo 2569591501 $encoded
+ set ttl [r pttl foo]
+ assert {$ttl >= (2569591501-3000) && $ttl <= 2569591501}
+ r get foo
+ } {bar}
+
+ test {RESTORE returns an error of the key already exists} {
+ r set foo bar
+ set e {}
+ catch {r restore foo 0 "..."} e
+ set e
+ } {*BUSYKEY*}
+
+ test {RESTORE can overwrite an existing key with REPLACE} {
+ r set foo bar1
+ set encoded1 [r dump foo]
+ r set foo bar2
+ set encoded2 [r dump foo]
+ r del foo
+ r restore foo 0 $encoded1
+ r restore foo 0 $encoded2 replace
+ r get foo
+ } {bar2}
+
+ test {RESTORE can detect a syntax error for unrecongized options} {
+ catch {r restore foo 0 "..." invalid-option} e
+ set e
+ } {*syntax*}
+
+ test {DUMP of non existing key returns nil} {
+ r dump nonexisting_key
+ } {}
+
+ test {MIGRATE is caching connections} {
+ # Note, we run this as first test so that the connection cache
+ # is empty.
+ set first [srv 0 client]
+ r set key "Some Value"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert_match {*migrate_cached_sockets:0*} [r -1 info]
+ r -1 migrate $second_host $second_port key 9 1000
+ assert_match {*migrate_cached_sockets:1*} [r -1 info]
+ }
+ }
+
+ test {MIGRATE cached connections are released after some time} {
+ after 15000
+ assert_match {*migrate_cached_sockets:0*} [r info]
+ }
+
+ test {MIGRATE is able to migrate a key between two instances} {
+ set first [srv 0 client]
+ r set key "Some Value"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key] == 1}
+ assert {[$second exists key] == 0}
+ set ret [r -1 migrate $second_host $second_port key 9 5000]
+ assert {$ret eq {OK}}
+ assert {[$first exists key] == 0}
+ assert {[$second exists key] == 1}
+ assert {[$second get key] eq {Some Value}}
+ assert {[$second ttl key] == -1}
+ }
+ }
+
+ test {MIGRATE is able to copy a key between two instances} {
+ set first [srv 0 client]
+ r del list
+ r lpush list a b c d
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists list] == 1}
+ assert {[$second exists list] == 0}
+ set ret [r -1 migrate $second_host $second_port list 9 5000 copy]
+ assert {$ret eq {OK}}
+ assert {[$first exists list] == 1}
+ assert {[$second exists list] == 1}
+ assert {[$first lrange list 0 -1] eq [$second lrange list 0 -1]}
+ }
+ }
+
+ test {MIGRATE will not overwrite existing keys, unless REPLACE is used} {
+ set first [srv 0 client]
+ r del list
+ r lpush list a b c d
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists list] == 1}
+ assert {[$second exists list] == 0}
+ $second set list somevalue
+ catch {r -1 migrate $second_host $second_port list 9 5000 copy} e
+ assert_match {ERR*} $e
+ set res [r -1 migrate $second_host $second_port list 9 5000 copy replace]
+ assert {$ret eq {OK}}
+ assert {[$first exists list] == 1}
+ assert {[$second exists list] == 1}
+ assert {[$first lrange list 0 -1] eq [$second lrange list 0 -1]}
+ }
+ }
+
+ test {MIGRATE propagates TTL correctly} {
+ set first [srv 0 client]
+ r set key "Some Value"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key] == 1}
+ assert {[$second exists key] == 0}
+ $first expire key 10
+ set ret [r -1 migrate $second_host $second_port key 9 5000]
+ assert {$ret eq {OK}}
+ assert {[$first exists key] == 0}
+ assert {[$second exists key] == 1}
+ assert {[$second get key] eq {Some Value}}
+ assert {[$second ttl key] >= 7 && [$second ttl key] <= 10}
+ }
+ }
+
+ test {MIGRATE can correctly transfer large values} {
+ set first [srv 0 client]
+ r del key
+ for {set j 0} {$j < 40000} {incr j} {
+ r rpush key 1 2 3 4 5 6 7 8 9 10
+ r rpush key "item 1" "item 2" "item 3" "item 4" "item 5" \
+ "item 6" "item 7" "item 8" "item 9" "item 10"
+ }
+ assert {[string length [r dump key]] > (1024*64)}
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key] == 1}
+ assert {[$second exists key] == 0}
+ set ret [r -1 migrate $second_host $second_port key 9 10000]
+ assert {$ret eq {OK}}
+ assert {[$first exists key] == 0}
+ assert {[$second exists key] == 1}
+ assert {[$second ttl key] == -1}
+ assert {[$second llen key] == 40000*20}
+ }
+ }
+
+ test {MIGRATE can correctly transfer hashes} {
+ set first [srv 0 client]
+ r del key
+ r hmset key field1 "item 1" field2 "item 2" field3 "item 3" \
+ field4 "item 4" field5 "item 5" field6 "item 6"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key] == 1}
+ assert {[$second exists key] == 0}
+ set ret [r -1 migrate $second_host $second_port key 9 10000]
+ assert {$ret eq {OK}}
+ assert {[$first exists key] == 0}
+ assert {[$second exists key] == 1}
+ assert {[$second ttl key] == -1}
+ }
+ }
+
+ test {MIGRATE timeout actually works} {
+ set first [srv 0 client]
+ r set key "Some Value"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key] == 1}
+ assert {[$second exists key] == 0}
+
+ set rd [redis_deferring_client]
+ $rd debug sleep 1.0 ; # Make second server unable to reply.
+ set e {}
+ catch {r -1 migrate $second_host $second_port key 9 500} e
+ assert_match {IOERR*} $e
+ }
+ }
+
+ test {MIGRATE can migrate multiple keys at once} {
+ set first [srv 0 client]
+ r set key1 "v1"
+ r set key2 "v2"
+ r set key3 "v3"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ assert {[$first exists key1] == 1}
+ assert {[$second exists key1] == 0}
+ set ret [r -1 migrate $second_host $second_port "" 9 5000 keys key1 key2 key3]
+ assert {$ret eq {OK}}
+ assert {[$first exists key1] == 0}
+ assert {[$first exists key2] == 0}
+ assert {[$first exists key3] == 0}
+ assert {[$second get key1] eq {v1}}
+ assert {[$second get key2] eq {v2}}
+ assert {[$second get key3] eq {v3}}
+ }
+ }
+
+ test {MIGRATE with multiple keys must have empty key arg} {
+ catch {r MIGRATE 127.0.0.1 6379 NotEmpty 9 5000 keys a b c} e
+ set e
+ } {*empty string*}
+
+ test {MIGRATE with mutliple keys migrate just existing ones} {
+ set first [srv 0 client]
+ r set key1 "v1"
+ r set key2 "v2"
+ r set key3 "v3"
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ set ret [r -1 migrate $second_host $second_port "" 9 5000 keys nokey-1 nokey-2 nokey-2]
+ assert {$ret eq {NOKEY}}
+
+ assert {[$first exists key1] == 1}
+ assert {[$second exists key1] == 0}
+ set ret [r -1 migrate $second_host $second_port "" 9 5000 keys nokey-1 key1 nokey-2 key2 nokey-3 key3]
+ assert {$ret eq {OK}}
+ assert {[$first exists key1] == 0}
+ assert {[$first exists key2] == 0}
+ assert {[$first exists key3] == 0}
+ assert {[$second get key1] eq {v1}}
+ assert {[$second get key2] eq {v2}}
+ assert {[$second get key3] eq {v3}}
+ }
+ }
+
+ test {MIGRATE with multiple keys: stress command rewriting} {
+ set first [srv 0 client]
+ r flushdb
+ r mset a 1 b 2 c 3 d 4 c 5 e 6 f 7 g 8 h 9 i 10 l 11 m 12 n 13 o 14 p 15 q 16
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ set ret [r -1 migrate $second_host $second_port "" 9 5000 keys a b c d e f g h i l m n o p q]
+
+ assert {[$first dbsize] == 0}
+ assert {[$second dbsize] == 15}
+ }
+ }
+
+ test {MIGRATE with multiple keys: delete just ack keys} {
+ set first [srv 0 client]
+ r flushdb
+ r mset a 1 b 2 c 3 d 4 c 5 e 6 f 7 g 8 h 9 i 10 l 11 m 12 n 13 o 14 p 15 q 16
+ start_server {tags {"repl"}} {
+ set second [srv 0 client]
+ set second_host [srv 0 host]
+ set second_port [srv 0 port]
+
+ $second mset c _ d _; # Two busy keys and no REPLACE used
+
+ catch {r -1 migrate $second_host $second_port "" 9 5000 keys a b c d e f g h i l m n o p q} e
+
+ assert {[$first dbsize] == 2}
+ assert {[$second dbsize] == 15}
+ assert {[$first exists c] == 1}
+ assert {[$first exists d] == 1}
+ }
+ }
+
+}
diff --git a/tests/unit/expire.tcl b/tests/unit/expire.tcl
new file mode 100644
index 0000000..0a50dd3
--- /dev/null
+++ b/tests/unit/expire.tcl
@@ -0,0 +1,207 @@
+start_server {tags {"expire"}} {
+ test {EXPIRE - set timeouts multiple times} {
+ r set x foobar
+ set v1 [r expire x 5]
+ set v2 [r ttl x]
+ set v3 [r expire x 10]
+ set v4 [r ttl x]
+ r expire x 2
+ list $v1 $v2 $v3 $v4
+ } {1 [45] 1 10}
+
+ test {EXPIRE - It should be still possible to read 'x'} {
+ r get x
+ } {foobar}
+
+ tags {"slow"} {
+ test {EXPIRE - After 2.1 seconds the key should no longer be here} {
+ after 2100
+ list [r get x] [r exists x]
+ } {{} 0}
+ }
+
+ test {EXPIRE - write on expire should work} {
+ r del x
+ r lpush x foo
+ r expire x 1000
+ r lpush x bar
+ r lrange x 0 -1
+ } {bar foo}
+
+ test {EXPIREAT - Check for EXPIRE alike behavior} {
+ r del x
+ r set x foo
+ r expireat x [expr [clock seconds]+15]
+ r ttl x
+ } {1[345]}
+
+ test {SETEX - Set + Expire combo operation. Check for TTL} {
+ r setex x 12 test
+ r ttl x
+ } {1[012]}
+
+ test {SETEX - Check value} {
+ r get x
+ } {test}
+
+ test {SETEX - Overwrite old key} {
+ r setex y 1 foo
+ r get y
+ } {foo}
+
+ tags {"slow"} {
+ test {SETEX - Wait for the key to expire} {
+ after 1100
+ r get y
+ } {}
+ }
+
+ test {SETEX - Wrong time parameter} {
+ catch {r setex z -10 foo} e
+ set _ $e
+ } {*invalid expire*}
+
+ test {PERSIST can undo an EXPIRE} {
+ r set x foo
+ r expire x 50
+ list [r ttl x] [r persist x] [r ttl x] [r get x]
+ } {50 1 -1 foo}
+
+ test {PERSIST returns 0 against non existing or non volatile keys} {
+ r set x foo
+ list [r persist foo] [r persist nokeyatall]
+ } {0 0}
+
+ test {EXPIRE pricision is now the millisecond} {
+ # This test is very likely to do a false positive if the
+ # server is under pressure, so if it does not work give it a few more
+ # chances.
+ for {set j 0} {$j < 3} {incr j} {
+ r del x
+ r setex x 1 somevalue
+ after 900
+ set a [r get x]
+ after 1100
+ set b [r get x]
+ if {$a eq {somevalue} && $b eq {}} break
+ }
+ list $a $b
+ } {somevalue {}}
+
+ test {PEXPIRE/PSETEX/PEXPIREAT can set sub-second expires} {
+ # This test is very likely to do a false positive if the
+ # server is under pressure, so if it does not work give it a few more
+ # chances.
+ for {set j 0} {$j < 3} {incr j} {
+ r del x y z
+ r psetex x 100 somevalue
+ after 80
+ set a [r get x]
+ after 120
+ set b [r get x]
+
+ r set x somevalue
+ r pexpire x 100
+ after 80
+ set c [r get x]
+ after 120
+ set d [r get x]
+
+ r set x somevalue
+ r pexpireat x [expr ([clock seconds]*1000)+100]
+ after 80
+ set e [r get x]
+ after 120
+ set f [r get x]
+
+ if {$a eq {somevalue} && $b eq {} &&
+ $c eq {somevalue} && $d eq {} &&
+ $e eq {somevalue} && $f eq {}} break
+ }
+ list $a $b
+ } {somevalue {}}
+
+ test {TTL returns tiem to live in seconds} {
+ r del x
+ r setex x 10 somevalue
+ set ttl [r ttl x]
+ assert {$ttl > 8 && $ttl <= 10}
+ }
+
+ test {PTTL returns time to live in milliseconds} {
+ r del x
+ r setex x 1 somevalue
+ set ttl [r pttl x]
+ assert {$ttl > 900 && $ttl <= 1000}
+ }
+
+ test {TTL / PTTL return -1 if key has no expire} {
+ r del x
+ r set x hello
+ list [r ttl x] [r pttl x]
+ } {-1 -1}
+
+ test {TTL / PTTL return -2 if key does not exit} {
+ r del x
+ list [r ttl x] [r pttl x]
+ } {-2 -2}
+
+ test {Redis should actively expire keys incrementally} {
+ r flushdb
+ r psetex key1 500 a
+ r psetex key2 500 a
+ r psetex key3 500 a
+ set size1 [r dbsize]
+ # Redis expires random keys ten times every second so we are
+ # fairly sure that all the three keys should be evicted after
+ # one second.
+ after 1000
+ set size2 [r dbsize]
+ list $size1 $size2
+ } {3 0}
+
+ test {Redis should lazy expire keys} {
+ r flushdb
+ r debug set-active-expire 0
+ r psetex key1 500 a
+ r psetex key2 500 a
+ r psetex key3 500 a
+ set size1 [r dbsize]
+ # Redis expires random keys ten times every second so we are
+ # fairly sure that all the three keys should be evicted after
+ # one second.
+ after 1000
+ set size2 [r dbsize]
+ r mget key1 key2 key3
+ set size3 [r dbsize]
+ r debug set-active-expire 1
+ list $size1 $size2 $size3
+ } {3 3 0}
+
+ test {EXPIRE should not resurrect keys (issue #1026)} {
+ r debug set-active-expire 0
+ r set foo bar
+ r pexpire foo 500
+ after 1000
+ r expire foo 10
+ r debug set-active-expire 1
+ r exists foo
+ } {0}
+
+ test {5 keys in, 5 keys out} {
+ r flushdb
+ r set a c
+ r expire a 5
+ r set t c
+ r set e c
+ r set s c
+ r set foo b
+ lsort [r keys *]
+ } {a e foo s t}
+
+ test {EXPIRE with empty string as TTL should report an error} {
+ r set foo bar
+ catch {r expire foo ""} e
+ set e
+ } {*not an integer*}
+}
diff --git a/tests/unit/geo.tcl b/tests/unit/geo.tcl
new file mode 100644
index 0000000..fdbfbf1
--- /dev/null
+++ b/tests/unit/geo.tcl
@@ -0,0 +1,308 @@
+# Helper functions to simulate search-in-radius in the Tcl side in order to
+# verify the Redis implementation with a fuzzy test.
+proc geo_degrad deg {expr {$deg*atan(1)*8/360}}
+
+proc geo_distance {lon1d lat1d lon2d lat2d} {
+ set lon1r [geo_degrad $lon1d]
+ set lat1r [geo_degrad $lat1d]
+ set lon2r [geo_degrad $lon2d]
+ set lat2r [geo_degrad $lat2d]
+ set v [expr {sin(($lon2r - $lon1r) / 2)}]
+ set u [expr {sin(($lat2r - $lat1r) / 2)}]
+ expr {2.0 * 6372797.560856 * \
+ asin(sqrt($u * $u + cos($lat1r) * cos($lat2r) * $v * $v))}
+}
+
+proc geo_random_point {lonvar latvar} {
+ upvar 1 $lonvar lon
+ upvar 1 $latvar lat
+ # Note that the actual latitude limit should be -85 to +85, we restrict
+ # the test to -70 to +70 since in this range the algorithm is more precise
+ # while outside this range occasionally some element may be missing.
+ set lon [expr {-180 + rand()*360}]
+ set lat [expr {-70 + rand()*140}]
+}
+
+# Return elements non common to both the lists.
+# This code is from http://wiki.tcl.tk/15489
+proc compare_lists {List1 List2} {
+ set DiffList {}
+ foreach Item $List1 {
+ if {[lsearch -exact $List2 $Item] == -1} {
+ lappend DiffList $Item
+ }
+ }
+ foreach Item $List2 {
+ if {[lsearch -exact $List1 $Item] == -1} {
+ if {[lsearch -exact $DiffList $Item] == -1} {
+ lappend DiffList $Item
+ }
+ }
+ }
+ return $DiffList
+}
+
+# The following list represents sets of random seed, search position
+# and radius that caused bugs in the past. It is used by the randomized
+# test later as a starting point. When the regression vectors are scanned
+# the code reverts to using random data.
+#
+# The format is: seed km lon lat
+set regression_vectors {
+ {1412 156 149.29737817929004 15.95807862745508}
+ {441574 143 59.235461856813856 66.269555127373678}
+ {160645 187 -101.88575239939883 49.061997951502917}
+ {750269 154 -90.187939661642517 66.615930412251487}
+ {342880 145 163.03472387745728 64.012747720821181}
+ {729955 143 137.86663517256579 63.986745399416776}
+ {939895 151 59.149620271823181 65.204186651485145}
+ {1412 156 149.29737817929004 15.95807862745508}
+ {564862 149 84.062063109158544 -65.685403922426232}
+}
+set rv_idx 0
+
+start_server {tags {"geo"}} {
+ test {GEOADD create} {
+ r geoadd nyc -73.9454966 40.747533 "lic market"
+ } {1}
+
+ test {GEOADD update} {
+ r geoadd nyc -73.9454966 40.747533 "lic market"
+ } {0}
+
+ test {GEOADD invalid coordinates} {
+ catch {
+ r geoadd nyc -73.9454966 40.747533 "lic market" \
+ foo bar "luck market"
+ } err
+ set err
+ } {*valid*}
+
+ test {GEOADD multi add} {
+ r geoadd nyc -73.9733487 40.7648057 "central park n/q/r" -73.9903085 40.7362513 "union square" -74.0131604 40.7126674 "wtc one" -73.7858139 40.6428986 "jfk" -73.9375699 40.7498929 "q4" -73.9564142 40.7480973 4545
+ } {6}
+
+ test {Check geoset values} {
+ r zrange nyc 0 -1 withscores
+ } {{wtc one} 1791873972053020 {union square} 1791875485187452 {central park n/q/r} 1791875761332224 4545 1791875796750882 {lic market} 1791875804419201 q4 1791875830079666 jfk 1791895905559723}
+
+ test {GEORADIUS simple (sorted)} {
+ r georadius nyc -73.9798091 40.7598464 3 km asc
+ } {{central park n/q/r} 4545 {union square}}
+
+ test {GEORADIUS withdist (sorted)} {
+ r georadius nyc -73.9798091 40.7598464 3 km withdist asc
+ } {{{central park n/q/r} 0.7750} {4545 2.3651} {{union square} 2.7697}}
+
+ test {GEORADIUS with COUNT} {
+ r georadius nyc -73.9798091 40.7598464 10 km COUNT 3
+ } {{central park n/q/r} 4545 {union square}}
+
+ test {GEORADIUS with COUNT but missing integer argument} {
+ catch {r georadius nyc -73.9798091 40.7598464 10 km COUNT} e
+ set e
+ } {ERR*syntax*}
+
+ test {GEORADIUS with COUNT DESC} {
+ r georadius nyc -73.9798091 40.7598464 10 km COUNT 2 DESC
+ } {{wtc one} q4}
+
+ test {GEORADIUS HUGE, issue #2767} {
+ r geoadd users -47.271613776683807 -54.534504198047678 user_000000
+ llength [r GEORADIUS users 0 0 50000 km WITHCOORD]
+ } {1}
+
+ test {GEORADIUSBYMEMBER simple (sorted)} {
+ r georadiusbymember nyc "wtc one" 7 km
+ } {{wtc one} {union square} {central park n/q/r} 4545 {lic market}}
+
+ test {GEORADIUSBYMEMBER withdist (sorted)} {
+ r georadiusbymember nyc "wtc one" 7 km withdist
+ } {{{wtc one} 0.0000} {{union square} 3.2544} {{central park n/q/r} 6.7000} {4545 6.1975} {{lic market} 6.8969}}
+
+ test {GEOHASH is able to return geohash strings} {
+ # Example from Wikipedia.
+ r del points
+ r geoadd points -5.6 42.6 test
+ lindex [r geohash points test] 0
+ } {ezs42e44yx0}
+
+ test {GEOPOS simple} {
+ r del points
+ r geoadd points 10 20 a 30 40 b
+ lassign [lindex [r geopos points a b] 0] x1 y1
+ lassign [lindex [r geopos points a b] 1] x2 y2
+ assert {abs($x1 - 10) < 0.001}
+ assert {abs($y1 - 20) < 0.001}
+ assert {abs($x2 - 30) < 0.001}
+ assert {abs($y2 - 40) < 0.001}
+ }
+
+ test {GEOPOS missing element} {
+ r del points
+ r geoadd points 10 20 a 30 40 b
+ lindex [r geopos points a x b] 1
+ } {}
+
+ test {GEODIST simple & unit} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ set m [r geodist points Palermo Catania]
+ assert {$m > 166274 && $m < 166275}
+ set km [r geodist points Palermo Catania km]
+ assert {$km > 166.2 && $km < 166.3}
+ }
+
+ test {GEODIST missing elements} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ set m [r geodist points Palermo Agrigento]
+ assert {$m eq {}}
+ set m [r geodist points Ragusa Agrigento]
+ assert {$m eq {}}
+ set m [r geodist empty_key Palermo Catania]
+ assert {$m eq {}}
+ }
+
+ test {GEORADIUS STORE option: syntax error} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ catch {r georadius points 13.361389 38.115556 50 km store} e
+ set e
+ } {*ERR*syntax*}
+
+ test {GEORANGE STORE option: incompatible options} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ catch {r georadius points 13.361389 38.115556 50 km store points2 withdist} e
+ assert_match {*ERR*} $e
+ catch {r georadius points 13.361389 38.115556 50 km store points2 withhash} e
+ assert_match {*ERR*} $e
+ catch {r georadius points 13.361389 38.115556 50 km store points2 withcoords} e
+ assert_match {*ERR*} $e
+ }
+
+ test {GEORANGE STORE option: plain usage} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ r georadius points 13.361389 38.115556 500 km store points2
+ assert_equal [r zrange points 0 -1] [r zrange points2 0 -1]
+ }
+
+ test {GEORANGE STOREDIST option: plain usage} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ r georadius points 13.361389 38.115556 500 km storedist points2
+ set res [r zrange points2 0 -1 withscores]
+ assert {[lindex $res 1] < 1}
+ assert {[lindex $res 3] > 166}
+ assert {[lindex $res 3] < 167}
+ }
+
+ test {GEORANGE STOREDIST option: COUNT ASC and DESC} {
+ r del points
+ r geoadd points 13.361389 38.115556 "Palermo" \
+ 15.087269 37.502669 "Catania"
+ r georadius points 13.361389 38.115556 500 km storedist points2 asc count 1
+ assert {[r zcard points2] == 1}
+ set res [r zrange points2 0 -1 withscores]
+ assert {[lindex $res 0] eq "Palermo"}
+
+ r georadius points 13.361389 38.115556 500 km storedist points2 desc count 1
+ assert {[r zcard points2] == 1}
+ set res [r zrange points2 0 -1 withscores]
+ assert {[lindex $res 0] eq "Catania"}
+ }
+
+ test {GEOADD + GEORANGE randomized test} {
+ set attempt 30
+ while {[incr attempt -1]} {
+ set rv [lindex $regression_vectors $rv_idx]
+ incr rv_idx
+
+ unset -nocomplain debuginfo
+ set srand_seed [clock milliseconds]
+ if {$rv ne {}} {set srand_seed [lindex $rv 0]}
+ lappend debuginfo "srand_seed is $srand_seed"
+ expr {srand($srand_seed)} ; # If you need a reproducible run
+ r del mypoints
+
+ if {[randomInt 10] == 0} {
+ # From time to time use very big radiuses
+ set radius_km [expr {[randomInt 50000]+10}]
+ } else {
+ # Normally use a few - ~200km radiuses to stress
+ # test the code the most in edge cases.
+ set radius_km [expr {[randomInt 200]+10}]
+ }
+ if {$rv ne {}} {set radius_km [lindex $rv 1]}
+ set radius_m [expr {$radius_km*1000}]
+ geo_random_point search_lon search_lat
+ if {$rv ne {}} {
+ set search_lon [lindex $rv 2]
+ set search_lat [lindex $rv 3]
+ }
+ lappend debuginfo "Search area: $search_lon,$search_lat $radius_km km"
+ set tcl_result {}
+ set argv {}
+ for {set j 0} {$j < 20000} {incr j} {
+ geo_random_point lon lat
+ lappend argv $lon $lat "place:$j"
+ set distance [geo_distance $lon $lat $search_lon $search_lat]
+ if {$distance < $radius_m} {
+ lappend tcl_result "place:$j"
+ }
+ lappend debuginfo "place:$j $lon $lat [expr {$distance/1000}] km"
+ }
+ r geoadd mypoints {*}$argv
+ set res [lsort [r georadius mypoints $search_lon $search_lat $radius_km km]]
+ set res2 [lsort $tcl_result]
+ set test_result OK
+
+ if {$res != $res2} {
+ set rounding_errors 0
+ set diff [compare_lists $res $res2]
+ foreach place $diff {
+ set mydist [geo_distance $lon $lat $search_lon $search_lat]
+ set mydist [expr $mydist/1000]
+ if {($mydist / $radius_km) > 0.999} {incr rounding_errors}
+ }
+ # Make sure this is a real error and not a rounidng issue.
+ if {[llength $diff] == $rounding_errors} {
+ set res $res2; # Error silenced
+ }
+ }
+
+ if {$res != $res2} {
+ set diff [compare_lists $res $res2]
+ puts "*** Possible problem in GEO radius query ***"
+ puts "Redis: $res"
+ puts "Tcl : $res2"
+ puts "Diff : $diff"
+ puts [join $debuginfo "\n"]
+ foreach place $diff {
+ if {[lsearch -exact $res2 $place] != -1} {
+ set where "(only in Tcl)"
+ } else {
+ set where "(only in Redis)"
+ }
+ lassign [lindex [r geopos mypoints $place] 0] lon lat
+ set mydist [geo_distance $lon $lat $search_lon $search_lat]
+ set mydist [expr $mydist/1000]
+ puts "$place -> [r geopos mypoints $place] $mydist $where"
+ if {($mydist / $radius_km) > 0.999} {incr rounding_errors}
+ }
+ set test_result FAIL
+ }
+ unset -nocomplain debuginfo
+ if {$test_result ne {OK}} break
+ }
+ set test_result
+ } {OK}
+}
diff --git a/tests/unit/hyperloglog.tcl b/tests/unit/hyperloglog.tcl
new file mode 100644
index 0000000..7d36b7a
--- /dev/null
+++ b/tests/unit/hyperloglog.tcl
@@ -0,0 +1,185 @@
+start_server {tags {"hll"}} {
+ test {HyperLogLog self test passes} {
+ catch {r pfselftest} e
+ set e
+ } {OK}
+
+ test {PFADD without arguments creates an HLL value} {
+ r pfadd hll
+ r exists hll
+ } {1}
+
+ test {Approximated cardinality after creation is zero} {
+ r pfcount hll
+ } {0}
+
+ test {PFADD returns 1 when at least 1 reg was modified} {
+ r pfadd hll a b c
+ } {1}
+
+ test {PFADD returns 0 when no reg was modified} {
+ r pfadd hll a b c
+ } {0}
+
+ test {PFADD works with empty string (regression)} {
+ r pfadd hll ""
+ }
+
+ # Note that the self test stresses much better the
+ # cardinality estimation error. We are testing just the
+ # command implementation itself here.
+ test {PFCOUNT returns approximated cardinality of set} {
+ r del hll
+ set res {}
+ r pfadd hll 1 2 3 4 5
+ lappend res [r pfcount hll]
+ # Call it again to test cached value invalidation.
+ r pfadd hll 6 7 8 8 9 10
+ lappend res [r pfcount hll]
+ set res
+ } {5 10}
+
+ test {HyperLogLogs are promote from sparse to dense} {
+ r del hll
+ r config set hll-sparse-max-bytes 3000
+ set n 0
+ while {$n < 100000} {
+ set elements {}
+ for {set j 0} {$j < 100} {incr j} {lappend elements [expr rand()]}
+ incr n 100
+ r pfadd hll {*}$elements
+ set card [r pfcount hll]
+ set err [expr {abs($card-$n)}]
+ assert {$err < (double($card)/100)*5}
+ if {$n < 1000} {
+ assert {[r pfdebug encoding hll] eq {sparse}}
+ } elseif {$n > 10000} {
+ assert {[r pfdebug encoding hll] eq {dense}}
+ }
+ }
+ }
+
+ test {HyperLogLog sparse encoding stress test} {
+ for {set x 0} {$x < 1000} {incr x} {
+ r del hll1 hll2
+ set numele [randomInt 100]
+ set elements {}
+ for {set j 0} {$j < $numele} {incr j} {
+ lappend elements [expr rand()]
+ }
+ # Force dense representation of hll2
+ r pfadd hll2
+ r pfdebug todense hll2
+ r pfadd hll1 {*}$elements
+ r pfadd hll2 {*}$elements
+ assert {[r pfdebug encoding hll1] eq {sparse}}
+ assert {[r pfdebug encoding hll2] eq {dense}}
+ # Cardinality estimated should match exactly.
+ assert {[r pfcount hll1] eq [r pfcount hll2]}
+ }
+ }
+
+ test {Corrupted sparse HyperLogLogs are detected: Additionl at tail} {
+ r del hll
+ r pfadd hll a b c
+ r append hll "hello"
+ set e {}
+ catch {r pfcount hll} e
+ set e
+ } {*INVALIDOBJ*}
+
+ test {Corrupted sparse HyperLogLogs are detected: Broken magic} {
+ r del hll
+ r pfadd hll a b c
+ r setrange hll 0 "0123"
+ set e {}
+ catch {r pfcount hll} e
+ set e
+ } {*WRONGTYPE*}
+
+ test {Corrupted sparse HyperLogLogs are detected: Invalid encoding} {
+ r del hll
+ r pfadd hll a b c
+ r setrange hll 4 "x"
+ set e {}
+ catch {r pfcount hll} e
+ set e
+ } {*WRONGTYPE*}
+
+ test {Corrupted dense HyperLogLogs are detected: Wrong length} {
+ r del hll
+ r pfadd hll a b c
+ r setrange hll 4 "\x00"
+ set e {}
+ catch {r pfcount hll} e
+ set e
+ } {*WRONGTYPE*}
+
+ test {PFADD, PFCOUNT, PFMERGE type checking works} {
+ r set foo bar
+ catch {r pfadd foo 1} e
+ assert_match {*WRONGTYPE*} $e
+ catch {r pfcount foo} e
+ assert_match {*WRONGTYPE*} $e
+ catch {r pfmerge bar foo} e
+ assert_match {*WRONGTYPE*} $e
+ catch {r pfmerge foo bar} e
+ assert_match {*WRONGTYPE*} $e
+ }
+
+ test {PFMERGE results on the cardinality of union of sets} {
+ r del hll hll1 hll2 hll3
+ r pfadd hll1 a b c
+ r pfadd hll2 b c d
+ r pfadd hll3 c d e
+ r pfmerge hll hll1 hll2 hll3
+ r pfcount hll
+ } {5}
+
+ test {PFCOUNT multiple-keys merge returns cardinality of union #1} {
+ r del hll1 hll2 hll3
+ for {set x 1} {$x < 10000} {incr x} {
+ r pfadd hll1 "foo-$x"
+ r pfadd hll2 "bar-$x"
+ r pfadd hll3 "zap-$x"
+
+ set card [r pfcount hll1 hll2 hll3]
+ set realcard [expr {$x*3}]
+ set err [expr {abs($card-$realcard)}]
+ assert {$err < (double($card)/100)*5}
+ }
+ }
+
+ test {PFCOUNT multiple-keys merge returns cardinality of union #2} {
+ r del hll1 hll2 hll3
+ set elements {}
+ for {set x 1} {$x < 10000} {incr x} {
+ for {set j 1} {$j <= 3} {incr j} {
+ set rint [randomInt 20000]
+ r pfadd hll$j $rint
+ lappend elements $rint
+ }
+ }
+ set realcard [llength [lsort -unique $elements]]
+ set card [r pfcount hll1 hll2 hll3]
+ set err [expr {abs($card-$realcard)}]
+ assert {$err < (double($card)/100)*5}
+ }
+
+ test {PFDEBUG GETREG returns the HyperLogLog raw registers} {
+ r del hll
+ r pfadd hll 1 2 3
+ llength [r pfdebug getreg hll]
+ } {16384}
+
+ test {PFADD / PFCOUNT cache invalidation works} {
+ r del hll
+ r pfadd hll a b c
+ r pfcount hll
+ assert {[r getrange hll 15 15] eq "\x00"}
+ r pfadd hll a b c
+ assert {[r getrange hll 15 15] eq "\x00"}
+ r pfadd hll 1 2 3
+ assert {[r getrange hll 15 15] eq "\x80"}
+ }
+}
diff --git a/tests/unit/introspection-2.tcl b/tests/unit/introspection-2.tcl
new file mode 100644
index 0000000..350a8a0
--- /dev/null
+++ b/tests/unit/introspection-2.tcl
@@ -0,0 +1,23 @@
+start_server {tags {"introspection"}} {
+ test {TTL and TYPYE do not alter the last access time of a key} {
+ r set foo bar
+ after 3000
+ r ttl foo
+ r type foo
+ assert {[r object idletime foo] >= 2}
+ }
+
+ test {TOUCH alters the last access time of a key} {
+ r set foo bar
+ after 3000
+ r touch foo
+ assert {[r object idletime foo] < 2}
+ }
+
+ test {TOUCH returns the number of existing keys specified} {
+ r flushdb
+ r set key1 1
+ r set key2 2
+ r touch key0 key1 key2 key3
+ } 2
+}
diff --git a/tests/unit/introspection.tcl b/tests/unit/introspection.tcl
new file mode 100644
index 0000000..f6477d9
--- /dev/null
+++ b/tests/unit/introspection.tcl
@@ -0,0 +1,60 @@
+start_server {tags {"introspection"}} {
+ test {CLIENT LIST} {
+ r client list
+ } {*addr=*:* fd=* age=* idle=* flags=N db=9 sub=0 psub=0 multi=-1 qbuf=0 qbuf-free=* obl=0 oll=0 omem=0 events=r cmd=client*}
+
+ test {MONITOR can log executed commands} {
+ set rd [redis_deferring_client]
+ $rd monitor
+ assert_match {*OK*} [$rd read]
+ r set foo bar
+ r get foo
+ list [$rd read] [$rd read]
+ } {*"set" "foo"*"get" "foo"*}
+
+ test {MONITOR can log commands issued by the scripting engine} {
+ set rd [redis_deferring_client]
+ $rd monitor
+ $rd read ;# Discard the OK
+ r eval {redis.call('set',KEYS[1],ARGV[1])} 1 foo bar
+ assert_match {*eval*} [$rd read]
+ assert_match {*lua*"set"*"foo"*"bar"*} [$rd read]
+ }
+
+ test {CLIENT GETNAME should return NIL if name is not assigned} {
+ r client getname
+ } {}
+
+ test {CLIENT LIST shows empty fields for unassigned names} {
+ r client list
+ } {*name= *}
+
+ test {CLIENT SETNAME does not accept spaces} {
+ catch {r client setname "foo bar"} e
+ set e
+ } {ERR*}
+
+ test {CLIENT SETNAME can assign a name to this connection} {
+ assert_equal [r client setname myname] {OK}
+ r client list
+ } {*name=myname*}
+
+ test {CLIENT SETNAME can change the name of an existing connection} {
+ assert_equal [r client setname someothername] {OK}
+ r client list
+ } {*name=someothername*}
+
+ test {After CLIENT SETNAME, connection can still be closed} {
+ set rd [redis_deferring_client]
+ $rd client setname foobar
+ assert_equal [$rd read] "OK"
+ assert_match {*foobar*} [r client list]
+ $rd close
+ # Now the client should no longer be listed
+ wait_for_condition 50 100 {
+ [string match {*foobar*} [r client list]] == 0
+ } else {
+ fail "Client still listed in CLIENT LIST after SETNAME."
+ }
+ }
+}
diff --git a/tests/unit/keyspace.tcl b/tests/unit/keyspace.tcl
new file mode 100644
index 0000000..d4e7bf5
--- /dev/null
+++ b/tests/unit/keyspace.tcl
@@ -0,0 +1,275 @@
+start_server {tags {"keyspace"}} {
+ test {DEL against a single item} {
+ r set x foo
+ assert {[r get x] eq "foo"}
+ r del x
+ r get x
+ } {}
+
+ test {Vararg DEL} {
+ r set foo1 a
+ r set foo2 b
+ r set foo3 c
+ list [r del foo1 foo2 foo3 foo4] [r mget foo1 foo2 foo3]
+ } {3 {{} {} {}}}
+
+ test {KEYS with pattern} {
+ foreach key {key_x key_y key_z foo_a foo_b foo_c} {
+ r set $key hello
+ }
+ lsort [r keys foo*]
+ } {foo_a foo_b foo_c}
+
+ test {KEYS to get all keys} {
+ lsort [r keys *]
+ } {foo_a foo_b foo_c key_x key_y key_z}
+
+ test {DBSIZE} {
+ r dbsize
+ } {6}
+
+ test {DEL all keys} {
+ foreach key [r keys *] {r del $key}
+ r dbsize
+ } {0}
+
+ test "DEL against expired key" {
+ r debug set-active-expire 0
+ r setex keyExpire 1 valExpire
+ after 1100
+ assert_equal 0 [r del keyExpire]
+ r debug set-active-expire 1
+ }
+
+ test {EXISTS} {
+ set res {}
+ r set newkey test
+ append res [r exists newkey]
+ r del newkey
+ append res [r exists newkey]
+ } {10}
+
+ test {Zero length value in key. SET/GET/EXISTS} {
+ r set emptykey {}
+ set res [r get emptykey]
+ append res [r exists emptykey]
+ r del emptykey
+ append res [r exists emptykey]
+ } {10}
+
+ test {Commands pipelining} {
+ set fd [r channel]
+ puts -nonewline $fd "SET k1 xyzk\r\nGET k1\r\nPING\r\n"
+ flush $fd
+ set res {}
+ append res [string match OK* [r read]]
+ append res [r read]
+ append res [string match PONG* [r read]]
+ format $res
+ } {1xyzk1}
+
+ test {Non existing command} {
+ catch {r foobaredcommand} err
+ string match ERR* $err
+ } {1}
+
+ test {RENAME basic usage} {
+ r set mykey hello
+ r rename mykey mykey1
+ r rename mykey1 mykey2
+ r get mykey2
+ } {hello}
+
+ test {RENAME source key should no longer exist} {
+ r exists mykey
+ } {0}
+
+ test {RENAME against already existing key} {
+ r set mykey a
+ r set mykey2 b
+ r rename mykey2 mykey
+ set res [r get mykey]
+ append res [r exists mykey2]
+ } {b0}
+
+ test {RENAMENX basic usage} {
+ r del mykey
+ r del mykey2
+ r set mykey foobar
+ r renamenx mykey mykey2
+ set res [r get mykey2]
+ append res [r exists mykey]
+ } {foobar0}
+
+ test {RENAMENX against already existing key} {
+ r set mykey foo
+ r set mykey2 bar
+ r renamenx mykey mykey2
+ } {0}
+
+ test {RENAMENX against already existing key (2)} {
+ set res [r get mykey]
+ append res [r get mykey2]
+ } {foobar}
+
+ test {RENAME against non existing source key} {
+ catch {r rename nokey foobar} err
+ format $err
+ } {ERR*}
+
+ test {RENAME where source and dest key are the same (existing)} {
+ r set mykey foo
+ r rename mykey mykey
+ } {OK}
+
+ test {RENAMENX where source and dest key are the same (existing)} {
+ r set mykey foo
+ r renamenx mykey mykey
+ } {0}
+
+ test {RENAME where source and dest key are the same (non existing)} {
+ r del mykey
+ catch {r rename mykey mykey} err
+ format $err
+ } {ERR*}
+
+ test {RENAME with volatile key, should move the TTL as well} {
+ r del mykey mykey2
+ r set mykey foo
+ r expire mykey 100
+ assert {[r ttl mykey] > 95 && [r ttl mykey] <= 100}
+ r rename mykey mykey2
+ assert {[r ttl mykey2] > 95 && [r ttl mykey2] <= 100}
+ }
+
+ test {RENAME with volatile key, should not inherit TTL of target key} {
+ r del mykey mykey2
+ r set mykey foo
+ r set mykey2 bar
+ r expire mykey2 100
+ assert {[r ttl mykey] == -1 && [r ttl mykey2] > 0}
+ r rename mykey mykey2
+ r ttl mykey2
+ } {-1}
+
+ test {DEL all keys again (DB 0)} {
+ foreach key [r keys *] {
+ r del $key
+ }
+ r dbsize
+ } {0}
+
+ test {DEL all keys again (DB 1)} {
+ r select 10
+ foreach key [r keys *] {
+ r del $key
+ }
+ set res [r dbsize]
+ r select 9
+ format $res
+ } {0}
+
+ test {MOVE basic usage} {
+ r set mykey foobar
+ r move mykey 10
+ set res {}
+ lappend res [r exists mykey]
+ lappend res [r dbsize]
+ r select 10
+ lappend res [r get mykey]
+ lappend res [r dbsize]
+ r select 9
+ format $res
+ } [list 0 0 foobar 1]
+
+ test {MOVE against key existing in the target DB} {
+ r set mykey hello
+ r move mykey 10
+ } {0}
+
+ test {MOVE against non-integer DB (#1428)} {
+ r set mykey hello
+ catch {r move mykey notanumber} e
+ set e
+ } {*ERR*index out of range}
+
+ test {MOVE can move key expire metadata as well} {
+ r select 10
+ r flushdb
+ r select 9
+ r set mykey foo ex 100
+ r move mykey 10
+ assert {[r ttl mykey] == -2}
+ r select 10
+ assert {[r ttl mykey] > 0 && [r ttl mykey] <= 100}
+ assert {[r get mykey] eq "foo"}
+ r select 9
+ }
+
+ test {MOVE does not create an expire if it does not exist} {
+ r select 10
+ r flushdb
+ r select 9
+ r set mykey foo
+ r move mykey 10
+ assert {[r ttl mykey] == -2}
+ r select 10
+ assert {[r ttl mykey] == -1}
+ assert {[r get mykey] eq "foo"}
+ r select 9
+ }
+
+ test {SET/GET keys in different DBs} {
+ r set a hello
+ r set b world
+ r select 10
+ r set a foo
+ r set b bared
+ r select 9
+ set res {}
+ lappend res [r get a]
+ lappend res [r get b]
+ r select 10
+ lappend res [r get a]
+ lappend res [r get b]
+ r select 9
+ format $res
+ } {hello world foo bared}
+
+ test {RANDOMKEY} {
+ r flushdb
+ r set foo x
+ r set bar y
+ set foo_seen 0
+ set bar_seen 0
+ for {set i 0} {$i < 100} {incr i} {
+ set rkey [r randomkey]
+ if {$rkey eq {foo}} {
+ set foo_seen 1
+ }
+ if {$rkey eq {bar}} {
+ set bar_seen 1
+ }
+ }
+ list $foo_seen $bar_seen
+ } {1 1}
+
+ test {RANDOMKEY against empty DB} {
+ r flushdb
+ r randomkey
+ } {}
+
+ test {RANDOMKEY regression 1} {
+ r flushdb
+ r set x 10
+ r del x
+ r randomkey
+ } {}
+
+ test {KEYS * two times with long key, Github issue #1208} {
+ r flushdb
+ r set dlskeriewrioeuwqoirueioqwrueoqwrueqw test
+ r keys *
+ r keys *
+ } {dlskeriewrioeuwqoirueioqwrueoqwrueqw}
+}
diff --git a/tests/unit/latency-monitor.tcl b/tests/unit/latency-monitor.tcl
new file mode 100644
index 0000000..b736cad
--- /dev/null
+++ b/tests/unit/latency-monitor.tcl
@@ -0,0 +1,50 @@
+start_server {tags {"latency-monitor"}} {
+ # Set a threshold high enough to avoid spurious latency events.
+ r config set latency-monitor-threshold 200
+ r latency reset
+
+ test {Test latency events logging} {
+ r debug sleep 0.3
+ after 1100
+ r debug sleep 0.4
+ after 1100
+ r debug sleep 0.5
+ assert {[r latency history command] >= 3}
+ }
+
+ test {LATENCY HISTORY output is ok} {
+ set min 250
+ set max 450
+ foreach event [r latency history command] {
+ lassign $event time latency
+ assert {$latency >= $min && $latency <= $max}
+ incr min 100
+ incr max 100
+ set last_time $time ; # Used in the next test
+ }
+ }
+
+ test {LATENCY LATEST output is ok} {
+ foreach event [r latency latest] {
+ lassign $event eventname time latency max
+ assert {$eventname eq "command"}
+ assert {$max >= 450 & $max <= 650}
+ assert {$time == $last_time}
+ break
+ }
+ }
+
+ test {LATENCY HISTORY / RESET with wrong event name is fine} {
+ assert {[llength [r latency history blabla]] == 0}
+ assert {[r latency reset blabla] == 0}
+ }
+
+ test {LATENCY DOCTOR produces some output} {
+ assert {[string length [r latency doctor]] > 0}
+ }
+
+ test {LATENCY RESET is able to reset events} {
+ assert {[r latency reset] > 0}
+ assert {[r latency latest] eq {}}
+ }
+}
diff --git a/tests/unit/lazyfree.tcl b/tests/unit/lazyfree.tcl
new file mode 100644
index 0000000..4e99449
--- /dev/null
+++ b/tests/unit/lazyfree.tcl
@@ -0,0 +1,39 @@
+start_server {tags {"lazyfree"}} {
+ test "UNLINK can reclaim memory in background" {
+ set orig_mem [s used_memory]
+ set args {}
+ for {set i 0} {$i < 100000} {incr i} {
+ lappend args $i
+ }
+ r sadd myset {*}$args
+ assert {[r scard myset] == 100000}
+ set peak_mem [s used_memory]
+ assert {[r unlink myset] == 1}
+ assert {$peak_mem > $orig_mem+1000000}
+ wait_for_condition 50 100 {
+ [s used_memory] < $peak_mem &&
+ [s used_memory] < $orig_mem*2
+ } else {
+ fail "Memory is not reclaimed by UNLINK"
+ }
+ }
+
+ test "FLUSHDB ASYNC can reclaim memory in background" {
+ set orig_mem [s used_memory]
+ set args {}
+ for {set i 0} {$i < 100000} {incr i} {
+ lappend args $i
+ }
+ r sadd myset {*}$args
+ assert {[r scard myset] == 100000}
+ set peak_mem [s used_memory]
+ r flushdb async
+ assert {$peak_mem > $orig_mem+1000000}
+ wait_for_condition 50 100 {
+ [s used_memory] < $peak_mem &&
+ [s used_memory] < $orig_mem*2
+ } else {
+ fail "Memory is not reclaimed by FLUSHDB ASYNC"
+ }
+ }
+}
diff --git a/tests/unit/limits.tcl b/tests/unit/limits.tcl
new file mode 100644
index 0000000..b37ea9b
--- /dev/null
+++ b/tests/unit/limits.tcl
@@ -0,0 +1,16 @@
+start_server {tags {"limits"} overrides {maxclients 10}} {
+ test {Check if maxclients works refusing connections} {
+ set c 0
+ catch {
+ while {$c < 50} {
+ incr c
+ set rd [redis_deferring_client]
+ $rd ping
+ $rd read
+ after 100
+ }
+ } e
+ assert {$c > 8 && $c <= 10}
+ set e
+ } {*ERR max*reached*}
+}
diff --git a/tests/unit/maxmemory.tcl b/tests/unit/maxmemory.tcl
new file mode 100644
index 0000000..0c3f6b3
--- /dev/null
+++ b/tests/unit/maxmemory.tcl
@@ -0,0 +1,144 @@
+start_server {tags {"maxmemory"}} {
+ test "Without maxmemory small integers are shared" {
+ r config set maxmemory 0
+ r set a 1
+ assert {[r object refcount a] > 1}
+ }
+
+ test "With maxmemory and non-LRU policy integers are still shared" {
+ r config set maxmemory 1073741824
+ r config set maxmemory-policy allkeys-random
+ r set a 1
+ assert {[r object refcount a] > 1}
+ }
+
+ test "With maxmemory and LRU policy integers are not shared" {
+ r config set maxmemory 1073741824
+ r config set maxmemory-policy allkeys-lru
+ r set a 1
+ r config set maxmemory-policy volatile-lru
+ r set b 1
+ assert {[r object refcount a] == 1}
+ assert {[r object refcount b] == 1}
+ r config set maxmemory 0
+ }
+
+ foreach policy {
+ allkeys-random allkeys-lru allkeys-lfu volatile-lru volatile-lfu volatile-random volatile-ttl
+ } {
+ test "maxmemory - is the memory limit honoured? (policy $policy)" {
+ # make sure to start with a blank instance
+ r flushall
+ # Get the current memory limit and calculate a new limit.
+ # We just add 100k to the current memory size so that it is
+ # fast for us to reach that limit.
+ set used [s used_memory]
+ set limit [expr {$used+100*1024}]
+ r config set maxmemory $limit
+ r config set maxmemory-policy $policy
+ # Now add keys until the limit is almost reached.
+ set numkeys 0
+ while 1 {
+ r setex [randomKey] 10000 x
+ incr numkeys
+ if {[s used_memory]+4096 > $limit} {
+ assert {$numkeys > 10}
+ break
+ }
+ }
+ # If we add the same number of keys already added again, we
+ # should still be under the limit.
+ for {set j 0} {$j < $numkeys} {incr j} {
+ r setex [randomKey] 10000 x
+ }
+ assert {[s used_memory] < ($limit+4096)}
+ }
+ }
+
+ foreach policy {
+ allkeys-random allkeys-lru volatile-lru volatile-random volatile-ttl
+ } {
+ test "maxmemory - only allkeys-* should remove non-volatile keys ($policy)" {
+ # make sure to start with a blank instance
+ r flushall
+ # Get the current memory limit and calculate a new limit.
+ # We just add 100k to the current memory size so that it is
+ # fast for us to reach that limit.
+ set used [s used_memory]
+ set limit [expr {$used+100*1024}]
+ r config set maxmemory $limit
+ r config set maxmemory-policy $policy
+ # Now add keys until the limit is almost reached.
+ set numkeys 0
+ while 1 {
+ r set [randomKey] x
+ incr numkeys
+ if {[s used_memory]+4096 > $limit} {
+ assert {$numkeys > 10}
+ break
+ }
+ }
+ # If we add the same number of keys already added again and
+ # the policy is allkeys-* we should still be under the limit.
+ # Otherwise we should see an error reported by Redis.
+ set err 0
+ for {set j 0} {$j < $numkeys} {incr j} {
+ if {[catch {r set [randomKey] x} e]} {
+ if {[string match {*used memory*} $e]} {
+ set err 1
+ }
+ }
+ }
+ if {[string match allkeys-* $policy]} {
+ assert {[s used_memory] < ($limit+4096)}
+ } else {
+ assert {$err == 1}
+ }
+ }
+ }
+
+ foreach policy {
+ volatile-lru volatile-lfu volatile-random volatile-ttl
+ } {
+ test "maxmemory - policy $policy should only remove volatile keys." {
+ # make sure to start with a blank instance
+ r flushall
+ # Get the current memory limit and calculate a new limit.
+ # We just add 100k to the current memory size so that it is
+ # fast for us to reach that limit.
+ set used [s used_memory]
+ set limit [expr {$used+100*1024}]
+ r config set maxmemory $limit
+ r config set maxmemory-policy $policy
+ # Now add keys until the limit is almost reached.
+ set numkeys 0
+ while 1 {
+ # Odd keys are volatile
+ # Even keys are non volatile
+ if {$numkeys % 2} {
+ r setex "key:$numkeys" 10000 x
+ } else {
+ r set "key:$numkeys" x
+ }
+ if {[s used_memory]+4096 > $limit} {
+ assert {$numkeys > 10}
+ break
+ }
+ incr numkeys
+ }
+ # Now we add the same number of volatile keys already added.
+ # We expect Redis to evict only volatile keys in order to make
+ # space.
+ set err 0
+ for {set j 0} {$j < $numkeys} {incr j} {
+ catch {r setex "foo:$j" 10000 x}
+ }
+ # We should still be under the limit.
+ assert {[s used_memory] < ($limit+4096)}
+ # However all our non volatile keys should be here.
+ for {set j 0} {$j < $numkeys} {incr j 2} {
+ assert {[r exists "key:$j"]}
+ }
+ }
+ }
+}
diff --git a/tests/unit/memefficiency.tcl b/tests/unit/memefficiency.tcl
new file mode 100644
index 0000000..7ca9a70
--- /dev/null
+++ b/tests/unit/memefficiency.tcl
@@ -0,0 +1,37 @@
+proc test_memory_efficiency {range} {
+ r flushall
+ set rd [redis_deferring_client]
+ set base_mem [s used_memory]
+ set written 0
+ for {set j 0} {$j < 10000} {incr j} {
+ set key key:$j
+ set val [string repeat A [expr {int(rand()*$range)}]]
+ $rd set $key $val
+ incr written [string length $key]
+ incr written [string length $val]
+ incr written 2 ;# A separator is the minimum to store key-value data.
+ }
+ for {set j 0} {$j < 10000} {incr j} {
+ $rd read ; # Discard replies
+ }
+
+ set current_mem [s used_memory]
+ set used [expr {$current_mem-$base_mem}]
+ set efficiency [expr {double($written)/$used}]
+ return $efficiency
+}
+
+start_server {tags {"memefficiency"}} {
+ foreach {size_range expected_min_efficiency} {
+ 32 0.15
+ 64 0.25
+ 128 0.35
+ 1024 0.75
+ 16384 0.82
+ } {
+ test "Memory efficiency with values in range $size_range" {
+ set efficiency [test_memory_efficiency $size_range]
+ assert {$efficiency >= $expected_min_efficiency}
+ }
+ }
+}
diff --git a/tests/unit/multi.tcl b/tests/unit/multi.tcl
new file mode 100644
index 0000000..6655bf6
--- /dev/null
+++ b/tests/unit/multi.tcl
@@ -0,0 +1,309 @@
+start_server {tags {"multi"}} {
+ test {MUTLI / EXEC basics} {
+ r del mylist
+ r rpush mylist a
+ r rpush mylist b
+ r rpush mylist c
+ r multi
+ set v1 [r lrange mylist 0 -1]
+ set v2 [r ping]
+ set v3 [r exec]
+ list $v1 $v2 $v3
+ } {QUEUED QUEUED {{a b c} PONG}}
+
+ test {DISCARD} {
+ r del mylist
+ r rpush mylist a
+ r rpush mylist b
+ r rpush mylist c
+ r multi
+ set v1 [r del mylist]
+ set v2 [r discard]
+ set v3 [r lrange mylist 0 -1]
+ list $v1 $v2 $v3
+ } {QUEUED OK {a b c}}
+
+ test {Nested MULTI are not allowed} {
+ set err {}
+ r multi
+ catch {[r multi]} err
+ r exec
+ set _ $err
+ } {*ERR MULTI*}
+
+ test {MULTI where commands alter argc/argv} {
+ r sadd myset a
+ r multi
+ r spop myset
+ list [r exec] [r exists myset]
+ } {a 0}
+
+ test {WATCH inside MULTI is not allowed} {
+ set err {}
+ r multi
+ catch {[r watch x]} err
+ r exec
+ set _ $err
+ } {*ERR WATCH*}
+
+ test {EXEC fails if there are errors while queueing commands #1} {
+ r del foo1 foo2
+ r multi
+ r set foo1 bar1
+ catch {r non-existing-command}
+ r set foo2 bar2
+ catch {r exec} e
+ assert_match {EXECABORT*} $e
+ list [r exists foo1] [r exists foo2]
+ } {0 0}
+
+ test {EXEC fails if there are errors while queueing commands #2} {
+ set rd [redis_deferring_client]
+ r del foo1 foo2
+ r multi
+ r set foo1 bar1
+ $rd config set maxmemory 1
+ assert {[$rd read] eq {OK}}
+ catch {r lpush mylist myvalue}
+ $rd config set maxmemory 0
+ assert {[$rd read] eq {OK}}
+ r set foo2 bar2
+ catch {r exec} e
+ assert_match {EXECABORT*} $e
+ $rd close
+ list [r exists foo1] [r exists foo2]
+ } {0 0}
+
+ test {If EXEC aborts, the client MULTI state is cleared} {
+ r del foo1 foo2
+ r multi
+ r set foo1 bar1
+ catch {r non-existing-command}
+ r set foo2 bar2
+ catch {r exec} e
+ assert_match {EXECABORT*} $e
+ r ping
+ } {PONG}
+
+ test {EXEC works on WATCHed key not modified} {
+ r watch x y z
+ r watch k
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {EXEC fail on WATCHed key modified (1 key of 1 watched)} {
+ r set x 30
+ r watch x
+ r set x 40
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {EXEC fail on WATCHed key modified (1 key of 5 watched)} {
+ r set x 30
+ r watch a b x k z
+ r set x 40
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {EXEC fail on WATCHed key modified by SORT with STORE even if the result is empty} {
+ r flushdb
+ r lpush foo bar
+ r watch foo
+ r sort emptylist store foo
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {After successful EXEC key is no longer watched} {
+ r set x 30
+ r watch x
+ r multi
+ r ping
+ r exec
+ r set x 40
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {After failed EXEC key is no longer watched} {
+ r set x 30
+ r watch x
+ r set x 40
+ r multi
+ r ping
+ r exec
+ r set x 40
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {It is possible to UNWATCH} {
+ r set x 30
+ r watch x
+ r set x 40
+ r unwatch
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {UNWATCH when there is nothing watched works as expected} {
+ r unwatch
+ } {OK}
+
+ test {FLUSHALL is able to touch the watched keys} {
+ r set x 30
+ r watch x
+ r flushall
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {FLUSHALL does not touch non affected keys} {
+ r del x
+ r watch x
+ r flushall
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {FLUSHDB is able to touch the watched keys} {
+ r set x 30
+ r watch x
+ r flushdb
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {FLUSHDB does not touch non affected keys} {
+ r del x
+ r watch x
+ r flushdb
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {WATCH is able to remember the DB a key belongs to} {
+ r select 5
+ r set x 30
+ r watch x
+ r select 1
+ r set x 10
+ r select 5
+ r multi
+ r ping
+ set res [r exec]
+ # Restore original DB
+ r select 9
+ set res
+ } {PONG}
+
+ test {WATCH will consider touched keys target of EXPIRE} {
+ r del x
+ r set x foo
+ r watch x
+ r expire x 10
+ r multi
+ r ping
+ r exec
+ } {}
+
+ test {WATCH will not consider touched expired keys} {
+ r del x
+ r set x foo
+ r expire x 1
+ r watch x
+ after 1100
+ r multi
+ r ping
+ r exec
+ } {PONG}
+
+ test {DISCARD should clear the WATCH dirty flag on the client} {
+ r watch x
+ r set x 10
+ r multi
+ r discard
+ r multi
+ r incr x
+ r exec
+ } {11}
+
+ test {DISCARD should UNWATCH all the keys} {
+ r watch x
+ r set x 10
+ r multi
+ r discard
+ r set x 10
+ r multi
+ r incr x
+ r exec
+ } {11}
+
+ test {MULTI / EXEC is propagated correctly (single write command)} {
+ set repl [attach_to_replication_stream]
+ r multi
+ r set foo bar
+ r exec
+ assert_replication_stream $repl {
+ {select *}
+ {multi}
+ {set foo bar}
+ {exec}
+ }
+ close_replication_stream $repl
+ }
+
+ test {MULTI / EXEC is propagated correctly (empty transaction)} {
+ set repl [attach_to_replication_stream]
+ r multi
+ r exec
+ r set foo bar
+ assert_replication_stream $repl {
+ {select *}
+ {set foo bar}
+ }
+ close_replication_stream $repl
+ }
+
+ test {MULTI / EXEC is propagated correctly (read-only commands)} {
+ r set foo value1
+ set repl [attach_to_replication_stream]
+ r multi
+ r get foo
+ r exec
+ r set foo value2
+ assert_replication_stream $repl {
+ {select *}
+ {set foo value2}
+ }
+ close_replication_stream $repl
+ }
+
+ test {MULTI / EXEC is propagated correctly (write command, no effect)} {
+ r del bar foo bar
+ set repl [attach_to_replication_stream]
+ r multi
+ r del foo
+ r exec
+ assert_replication_stream $repl {
+ {select *}
+ {multi}
+ {exec}
+ }
+ close_replication_stream $repl
+ }
+}
diff --git a/tests/unit/obuf-limits.tcl b/tests/unit/obuf-limits.tcl
new file mode 100644
index 0000000..5d625cf
--- /dev/null
+++ b/tests/unit/obuf-limits.tcl
@@ -0,0 +1,73 @@
+start_server {tags {"obuf-limits"}} {
+ test {Client output buffer hard limit is enforced} {
+ r config set client-output-buffer-limit {pubsub 100000 0 0}
+ set rd1 [redis_deferring_client]
+
+ $rd1 subscribe foo
+ set reply [$rd1 read]
+ assert {$reply eq "subscribe foo 1"}
+
+ set omem 0
+ while 1 {
+ r publish foo bar
+ set clients [split [r client list] "\r\n"]
+ set c [split [lindex $clients 1] " "]
+ if {![regexp {omem=([0-9]+)} $c - omem]} break
+ if {$omem > 200000} break
+ }
+ assert {$omem >= 90000 && $omem < 200000}
+ $rd1 close
+ }
+
+ test {Client output buffer soft limit is not enforced if time is not overreached} {
+ r config set client-output-buffer-limit {pubsub 0 100000 10}
+ set rd1 [redis_deferring_client]
+
+ $rd1 subscribe foo
+ set reply [$rd1 read]
+ assert {$reply eq "subscribe foo 1"}
+
+ set omem 0
+ set start_time 0
+ set time_elapsed 0
+ while 1 {
+ r publish foo bar
+ set clients [split [r client list] "\r\n"]
+ set c [split [lindex $clients 1] " "]
+ if {![regexp {omem=([0-9]+)} $c - omem]} break
+ if {$omem > 100000} {
+ if {$start_time == 0} {set start_time [clock seconds]}
+ set time_elapsed [expr {[clock seconds]-$start_time}]
+ if {$time_elapsed >= 5} break
+ }
+ }
+ assert {$omem >= 100000 && $time_elapsed >= 5 && $time_elapsed <= 10}
+ $rd1 close
+ }
+
+ test {Client output buffer soft limit is enforced if time is overreached} {
+ r config set client-output-buffer-limit {pubsub 0 100000 3}
+ set rd1 [redis_deferring_client]
+
+ $rd1 subscribe foo
+ set reply [$rd1 read]
+ assert {$reply eq "subscribe foo 1"}
+
+ set omem 0
+ set start_time 0
+ set time_elapsed 0
+ while 1 {
+ r publish foo bar
+ set clients [split [r client list] "\r\n"]
+ set c [split [lindex $clients 1] " "]
+ if {![regexp {omem=([0-9]+)} $c - omem]} break
+ if {$omem > 100000} {
+ if {$start_time == 0} {set start_time [clock seconds]}
+ set time_elapsed [expr {[clock seconds]-$start_time}]
+ if {$time_elapsed >= 10} break
+ }
+ }
+ assert {$omem >= 100000 && $time_elapsed < 6}
+ $rd1 close
+ }
+}
diff --git a/tests/unit/other.tcl b/tests/unit/other.tcl
new file mode 100644
index 0000000..1d21b56
--- /dev/null
+++ b/tests/unit/other.tcl
@@ -0,0 +1,246 @@
+start_server {tags {"other"}} {
+ if {$::force_failure} {
+ # This is used just for test suite development purposes.
+ test {Failing test} {
+ format err
+ } {ok}
+ }
+
+ test {SAVE - make sure there are all the types as values} {
+ # Wait for a background saving in progress to terminate
+ waitForBgsave r
+ r lpush mysavelist hello
+ r lpush mysavelist world
+ r set myemptykey {}
+ r set mynormalkey {blablablba}
+ r zadd mytestzset 10 a
+ r zadd mytestzset 20 b
+ r zadd mytestzset 30 c
+ r save
+ } {OK}
+
+ tags {slow} {
+ if {$::accurate} {set iterations 10000} else {set iterations 1000}
+ foreach fuzztype {binary alpha compr} {
+ test "FUZZ stresser with data model $fuzztype" {
+ set err 0
+ for {set i 0} {$i < $iterations} {incr i} {
+ set fuzz [randstring 0 512 $fuzztype]
+ r set foo $fuzz
+ set got [r get foo]
+ if {$got ne $fuzz} {
+ set err [list $fuzz $got]
+ break
+ }
+ }
+ set _ $err
+ } {0}
+ }
+ }
+
+ test {BGSAVE} {
+ waitForBgsave r
+ r flushdb
+ r save
+ r set x 10
+ r bgsave
+ waitForBgsave r
+ r debug reload
+ r get x
+ } {10}
+
+ test {SELECT an out of range DB} {
+ catch {r select 1000000} err
+ set _ $err
+ } {*index is out of range*}
+
+ tags {consistency} {
+ if {![catch {package require sha1}]} {
+ if {$::accurate} {set numops 10000} else {set numops 1000}
+ test {Check consistency of different data types after a reload} {
+ r flushdb
+ createComplexDataset r $numops
+ set dump [csvdump r]
+ set sha1 [r debug digest]
+ r debug reload
+ set sha1_after [r debug digest]
+ if {$sha1 eq $sha1_after} {
+ set _ 1
+ } else {
+ set newdump [csvdump r]
+ puts "Consistency test failed!"
+ puts "You can inspect the two dumps in /tmp/repldump*.txt"
+
+ set fd [open /tmp/repldump1.txt w]
+ puts $fd $dump
+ close $fd
+ set fd [open /tmp/repldump2.txt w]
+ puts $fd $newdump
+ close $fd
+
+ set _ 0
+ }
+ } {1}
+
+ test {Same dataset digest if saving/reloading as AOF?} {
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set sha1_after [r debug digest]
+ if {$sha1 eq $sha1_after} {
+ set _ 1
+ } else {
+ set newdump [csvdump r]
+ puts "Consistency test failed!"
+ puts "You can inspect the two dumps in /tmp/aofdump*.txt"
+
+ set fd [open /tmp/aofdump1.txt w]
+ puts $fd $dump
+ close $fd
+ set fd [open /tmp/aofdump2.txt w]
+ puts $fd $newdump
+ close $fd
+
+ set _ 0
+ }
+ } {1}
+ }
+ }
+
+ test {EXPIRES after a reload (snapshot + append only file rewrite)} {
+ r flushdb
+ r set x 10
+ r expire x 1000
+ r save
+ r debug reload
+ set ttl [r ttl x]
+ set e1 [expr {$ttl > 900 && $ttl <= 1000}]
+ r bgrewriteaof
+ waitForBgrewriteaof r
+ r debug loadaof
+ set ttl [r ttl x]
+ set e2 [expr {$ttl > 900 && $ttl <= 1000}]
+ list $e1 $e2
+ } {1 1}
+
+ test {EXPIRES after AOF reload (without rewrite)} {
+ r flushdb
+ r config set appendonly yes
+ r set x somevalue
+ r expire x 1000
+ r setex y 2000 somevalue
+ r set z somevalue
+ r expireat z [expr {[clock seconds]+3000}]
+
+ # Milliseconds variants
+ r set px somevalue
+ r pexpire px 1000000
+ r psetex py 2000000 somevalue
+ r set pz somevalue
+ r pexpireat pz [expr {([clock seconds]+3000)*1000}]
+
+ # Reload and check
+ waitForBgrewriteaof r
+ # We need to wait two seconds to avoid false positives here, otherwise
+ # the DEBUG LOADAOF command may read a partial file.
+ # Another solution would be to set the fsync policy to no, since this
+ # prevents write() to be delayed by the completion of fsync().
+ after 2000
+ r debug loadaof
+ set ttl [r ttl x]
+ assert {$ttl > 900 && $ttl <= 1000}
+ set ttl [r ttl y]
+ assert {$ttl > 1900 && $ttl <= 2000}
+ set ttl [r ttl z]
+ assert {$ttl > 2900 && $ttl <= 3000}
+ set ttl [r ttl px]
+ assert {$ttl > 900 && $ttl <= 1000}
+ set ttl [r ttl py]
+ assert {$ttl > 1900 && $ttl <= 2000}
+ set ttl [r ttl pz]
+ assert {$ttl > 2900 && $ttl <= 3000}
+ r config set appendonly no
+ }
+
+ tags {protocol} {
+ test {PIPELINING stresser (also a regression for the old epoll bug)} {
+ set fd2 [socket $::host $::port]
+ fconfigure $fd2 -encoding binary -translation binary
+ puts -nonewline $fd2 "SELECT 9\r\n"
+ flush $fd2
+ gets $fd2
+
+ for {set i 0} {$i < 100000} {incr i} {
+ set q {}
+ set val "0000${i}0000"
+ append q "SET key:$i $val\r\n"
+ puts -nonewline $fd2 $q
+ set q {}
+ append q "GET key:$i\r\n"
+ puts -nonewline $fd2 $q
+ }
+ flush $fd2
+
+ for {set i 0} {$i < 100000} {incr i} {
+ gets $fd2 line
+ gets $fd2 count
+ set count [string range $count 1 end]
+ set val [read $fd2 $count]
+ read $fd2 2
+ }
+ close $fd2
+ set _ 1
+ } {1}
+ }
+
+ test {APPEND basics} {
+ r del foo
+ list [r append foo bar] [r get foo] \
+ [r append foo 100] [r get foo]
+ } {3 bar 6 bar100}
+
+ test {APPEND basics, integer encoded values} {
+ set res {}
+ r del foo
+ r append foo 1
+ r append foo 2
+ lappend res [r get foo]
+ r set foo 1
+ r append foo 2
+ lappend res [r get foo]
+ } {12 12}
+
+ test {APPEND fuzzing} {
+ set err {}
+ foreach type {binary alpha compr} {
+ set buf {}
+ r del x
+ for {set i 0} {$i < 1000} {incr i} {
+ set bin [randstring 0 10 $type]
+ append buf $bin
+ r append x $bin
+ }
+ if {$buf != [r get x]} {
+ set err "Expected '$buf' found '[r get x]'"
+ break
+ }
+ }
+ set _ $err
+ } {}
+
+ # Leave the user with a clean DB before to exit
+ test {FLUSHDB} {
+ set aux {}
+ r select 9
+ r flushdb
+ lappend aux [r dbsize]
+ r select 10
+ r flushdb
+ lappend aux [r dbsize]
+ } {0 0}
+
+ test {Perform a final SAVE to leave a clean DB on disk} {
+ waitForBgsave r
+ r save
+ } {OK}
+}
diff --git a/tests/unit/printver.tcl b/tests/unit/printver.tcl
new file mode 100644
index 0000000..c80f451
--- /dev/null
+++ b/tests/unit/printver.tcl
@@ -0,0 +1,6 @@
+start_server {} {
+ set i [r info]
+ regexp {redis_version:(.*?)\r\n} $i - version
+ regexp {redis_git_sha1:(.*?)\r\n} $i - sha1
+ puts "Testing Redis version $version ($sha1)"
+}
diff --git a/tests/unit/protocol.tcl b/tests/unit/protocol.tcl
new file mode 100644
index 0000000..ac99c3a
--- /dev/null
+++ b/tests/unit/protocol.tcl
@@ -0,0 +1,117 @@
+start_server {tags {"protocol"}} {
+ test "Handle an empty query" {
+ reconnect
+ r write "\r\n"
+ r flush
+ assert_equal "PONG" [r ping]
+ }
+
+ test "Negative multibulk length" {
+ reconnect
+ r write "*-10\r\n"
+ r flush
+ assert_equal PONG [r ping]
+ }
+
+ test "Out of range multibulk length" {
+ reconnect
+ r write "*20000000\r\n"
+ r flush
+ assert_error "*invalid multibulk length*" {r read}
+ }
+
+ test "Wrong multibulk payload header" {
+ reconnect
+ r write "*3\r\n\$3\r\nSET\r\n\$1\r\nx\r\nfooz\r\n"
+ r flush
+ assert_error "*expected '$', got 'f'*" {r read}
+ }
+
+ test "Negative multibulk payload length" {
+ reconnect
+ r write "*3\r\n\$3\r\nSET\r\n\$1\r\nx\r\n\$-10\r\n"
+ r flush
+ assert_error "*invalid bulk length*" {r read}
+ }
+
+ test "Out of range multibulk payload length" {
+ reconnect
+ r write "*3\r\n\$3\r\nSET\r\n\$1\r\nx\r\n\$2000000000\r\n"
+ r flush
+ assert_error "*invalid bulk length*" {r read}
+ }
+
+ test "Non-number multibulk payload length" {
+ reconnect
+ r write "*3\r\n\$3\r\nSET\r\n\$1\r\nx\r\n\$blabla\r\n"
+ r flush
+ assert_error "*invalid bulk length*" {r read}
+ }
+
+ test "Multi bulk request not followed by bulk arguments" {
+ reconnect
+ r write "*1\r\nfoo\r\n"
+ r flush
+ assert_error "*expected '$', got 'f'*" {r read}
+ }
+
+ test "Generic wrong number of args" {
+ reconnect
+ assert_error "*wrong*arguments*ping*" {r ping x y z}
+ }
+
+ test "Unbalanced number of quotes" {
+ reconnect
+ r write "set \"\"\"test-key\"\"\" test-value\r\n"
+ r write "ping\r\n"
+ r flush
+ assert_error "*unbalanced*" {r read}
+ }
+
+ set c 0
+ foreach seq [list "\x00" "*\x00" "$\x00"] {
+ incr c
+ test "Protocol desync regression test #$c" {
+ set s [socket [srv 0 host] [srv 0 port]]
+ puts -nonewline $s $seq
+ set payload [string repeat A 1024]"\n"
+ set test_start [clock seconds]
+ set test_time_limit 30
+ while 1 {
+ if {[catch {
+ puts -nonewline $s payload
+ flush $s
+ incr payload_size [string length $payload]
+ }]} {
+ set retval [gets $s]
+ close $s
+ break
+ } else {
+ set elapsed [expr {[clock seconds]-$test_start}]
+ if {$elapsed > $test_time_limit} {
+ close $s
+ error "assertion:Redis did not closed connection after protocol desync"
+ }
+ }
+ }
+ set retval
+ } {*Protocol error*}
+ }
+ unset c
+}
+
+start_server {tags {"regression"}} {
+ test "Regression for a crash with blocking ops and pipelining" {
+ set rd [redis_deferring_client]
+ set fd [r channel]
+ set proto "*3\r\n\$5\r\nBLPOP\r\n\$6\r\nnolist\r\n\$1\r\n0\r\n"
+ puts -nonewline $fd $proto$proto
+ flush $fd
+ set res {}
+
+ $rd rpush nolist a
+ $rd read
+ $rd rpush nolist a
+ $rd read
+ }
+}
diff --git a/tests/unit/pubsub.tcl b/tests/unit/pubsub.tcl
new file mode 100644
index 0000000..9c7a43b
--- /dev/null
+++ b/tests/unit/pubsub.tcl
@@ -0,0 +1,390 @@
+start_server {tags {"pubsub"}} {
+ proc __consume_subscribe_messages {client type channels} {
+ set numsub -1
+ set counts {}
+
+ for {set i [llength $channels]} {$i > 0} {incr i -1} {
+ set msg [$client read]
+ assert_equal $type [lindex $msg 0]
+
+ # when receiving subscribe messages the channels names
+ # are ordered. when receiving unsubscribe messages
+ # they are unordered
+ set idx [lsearch -exact $channels [lindex $msg 1]]
+ if {[string match "*unsubscribe" $type]} {
+ assert {$idx >= 0}
+ } else {
+ assert {$idx == 0}
+ }
+ set channels [lreplace $channels $idx $idx]
+
+ # aggregate the subscription count to return to the caller
+ lappend counts [lindex $msg 2]
+ }
+
+ # we should have received messages for channels
+ assert {[llength $channels] == 0}
+ return $counts
+ }
+
+ proc subscribe {client channels} {
+ $client subscribe {*}$channels
+ __consume_subscribe_messages $client subscribe $channels
+ }
+
+ proc unsubscribe {client {channels {}}} {
+ $client unsubscribe {*}$channels
+ __consume_subscribe_messages $client unsubscribe $channels
+ }
+
+ proc psubscribe {client channels} {
+ $client psubscribe {*}$channels
+ __consume_subscribe_messages $client psubscribe $channels
+ }
+
+ proc punsubscribe {client {channels {}}} {
+ $client punsubscribe {*}$channels
+ __consume_subscribe_messages $client punsubscribe $channels
+ }
+
+ test "Pub/Sub PING" {
+ set rd1 [redis_deferring_client]
+ subscribe $rd1 somechannel
+ # While subscribed to non-zero channels PING works in Pub/Sub mode.
+ $rd1 ping
+ $rd1 ping "foo"
+ set reply1 [$rd1 read]
+ set reply2 [$rd1 read]
+ unsubscribe $rd1 somechannel
+ # Now we are unsubscribed, PING should just return PONG.
+ $rd1 ping
+ set reply3 [$rd1 read]
+ $rd1 close
+ list $reply1 $reply2 $reply3
+ } {{pong {}} {pong foo} PONG}
+
+ test "PUBLISH/SUBSCRIBE basics" {
+ set rd1 [redis_deferring_client]
+
+ # subscribe to two channels
+ assert_equal {1 2} [subscribe $rd1 {chan1 chan2}]
+ assert_equal 1 [r publish chan1 hello]
+ assert_equal 1 [r publish chan2 world]
+ assert_equal {message chan1 hello} [$rd1 read]
+ assert_equal {message chan2 world} [$rd1 read]
+
+ # unsubscribe from one of the channels
+ unsubscribe $rd1 {chan1}
+ assert_equal 0 [r publish chan1 hello]
+ assert_equal 1 [r publish chan2 world]
+ assert_equal {message chan2 world} [$rd1 read]
+
+ # unsubscribe from the remaining channel
+ unsubscribe $rd1 {chan2}
+ assert_equal 0 [r publish chan1 hello]
+ assert_equal 0 [r publish chan2 world]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "PUBLISH/SUBSCRIBE with two clients" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+
+ assert_equal {1} [subscribe $rd1 {chan1}]
+ assert_equal {1} [subscribe $rd2 {chan1}]
+ assert_equal 2 [r publish chan1 hello]
+ assert_equal {message chan1 hello} [$rd1 read]
+ assert_equal {message chan1 hello} [$rd2 read]
+
+ # clean up clients
+ $rd1 close
+ $rd2 close
+ }
+
+ test "PUBLISH/SUBSCRIBE after UNSUBSCRIBE without arguments" {
+ set rd1 [redis_deferring_client]
+ assert_equal {1 2 3} [subscribe $rd1 {chan1 chan2 chan3}]
+ unsubscribe $rd1
+ assert_equal 0 [r publish chan1 hello]
+ assert_equal 0 [r publish chan2 hello]
+ assert_equal 0 [r publish chan3 hello]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "SUBSCRIBE to one channel more than once" {
+ set rd1 [redis_deferring_client]
+ assert_equal {1 1 1} [subscribe $rd1 {chan1 chan1 chan1}]
+ assert_equal 1 [r publish chan1 hello]
+ assert_equal {message chan1 hello} [$rd1 read]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "UNSUBSCRIBE from non-subscribed channels" {
+ set rd1 [redis_deferring_client]
+ assert_equal {0 0 0} [unsubscribe $rd1 {foo bar quux}]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "PUBLISH/PSUBSCRIBE basics" {
+ set rd1 [redis_deferring_client]
+
+ # subscribe to two patterns
+ assert_equal {1 2} [psubscribe $rd1 {foo.* bar.*}]
+ assert_equal 1 [r publish foo.1 hello]
+ assert_equal 1 [r publish bar.1 hello]
+ assert_equal 0 [r publish foo1 hello]
+ assert_equal 0 [r publish barfoo.1 hello]
+ assert_equal 0 [r publish qux.1 hello]
+ assert_equal {pmessage foo.* foo.1 hello} [$rd1 read]
+ assert_equal {pmessage bar.* bar.1 hello} [$rd1 read]
+
+ # unsubscribe from one of the patterns
+ assert_equal {1} [punsubscribe $rd1 {foo.*}]
+ assert_equal 0 [r publish foo.1 hello]
+ assert_equal 1 [r publish bar.1 hello]
+ assert_equal {pmessage bar.* bar.1 hello} [$rd1 read]
+
+ # unsubscribe from the remaining pattern
+ assert_equal {0} [punsubscribe $rd1 {bar.*}]
+ assert_equal 0 [r publish foo.1 hello]
+ assert_equal 0 [r publish bar.1 hello]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "PUBLISH/PSUBSCRIBE with two clients" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+
+ assert_equal {1} [psubscribe $rd1 {chan.*}]
+ assert_equal {1} [psubscribe $rd2 {chan.*}]
+ assert_equal 2 [r publish chan.foo hello]
+ assert_equal {pmessage chan.* chan.foo hello} [$rd1 read]
+ assert_equal {pmessage chan.* chan.foo hello} [$rd2 read]
+
+ # clean up clients
+ $rd1 close
+ $rd2 close
+ }
+
+ test "PUBLISH/PSUBSCRIBE after PUNSUBSCRIBE without arguments" {
+ set rd1 [redis_deferring_client]
+ assert_equal {1 2 3} [psubscribe $rd1 {chan1.* chan2.* chan3.*}]
+ punsubscribe $rd1
+ assert_equal 0 [r publish chan1.hi hello]
+ assert_equal 0 [r publish chan2.hi hello]
+ assert_equal 0 [r publish chan3.hi hello]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "PUNSUBSCRIBE from non-subscribed channels" {
+ set rd1 [redis_deferring_client]
+ assert_equal {0 0 0} [punsubscribe $rd1 {foo.* bar.* quux.*}]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "NUMSUB returns numbers, not strings (#1561)" {
+ r pubsub numsub abc def
+ } {abc 0 def 0}
+
+ test "Mix SUBSCRIBE and PSUBSCRIBE" {
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [subscribe $rd1 {foo.bar}]
+ assert_equal {2} [psubscribe $rd1 {foo.*}]
+
+ assert_equal 2 [r publish foo.bar hello]
+ assert_equal {message foo.bar hello} [$rd1 read]
+ assert_equal {pmessage foo.* foo.bar hello} [$rd1 read]
+
+ # clean up clients
+ $rd1 close
+ }
+
+ test "PUNSUBSCRIBE and UNSUBSCRIBE should always reply" {
+ # Make sure we are not subscribed to any channel at all.
+ r punsubscribe
+ r unsubscribe
+ # Now check if the commands still reply correctly.
+ set reply1 [r punsubscribe]
+ set reply2 [r unsubscribe]
+ concat $reply1 $reply2
+ } {punsubscribe {} 0 unsubscribe {} 0}
+
+ ### Keyspace events notification tests
+
+ test "Keyspace notifications: we receive keyspace notifications" {
+ r config set notify-keyspace-events KA
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ assert_equal {pmessage * __keyspace@9__:foo set} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: we receive keyevent notifications" {
+ r config set notify-keyspace-events EA
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ assert_equal {pmessage * __keyevent@9__:set foo} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: we can receive both kind of events" {
+ r config set notify-keyspace-events KEA
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ assert_equal {pmessage * __keyspace@9__:foo set} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:set foo} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: we are able to mask events" {
+ r config set notify-keyspace-events KEl
+ r del mylist
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ r lpush mylist a
+ # No notification for set, because only list commands are enabled.
+ assert_equal {pmessage * __keyspace@9__:mylist lpush} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:lpush mylist} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: general events test" {
+ r config set notify-keyspace-events KEg
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ r expire foo 1
+ r del foo
+ assert_equal {pmessage * __keyspace@9__:foo expire} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:expire foo} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:foo del} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:del foo} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: list events test" {
+ r config set notify-keyspace-events KEl
+ r del mylist
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r lpush mylist a
+ r rpush mylist a
+ r rpop mylist
+ assert_equal {pmessage * __keyspace@9__:mylist lpush} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:lpush mylist} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:mylist rpush} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:rpush mylist} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:mylist rpop} [$rd1 read]
+ assert_equal {pmessage * __keyevent@9__:rpop mylist} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: set events test" {
+ r config set notify-keyspace-events Ks
+ r del myset
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r sadd myset a b c d
+ r srem myset x
+ r sadd myset x y z
+ r srem myset x
+ assert_equal {pmessage * __keyspace@9__:myset sadd} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:myset sadd} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:myset srem} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: zset events test" {
+ r config set notify-keyspace-events Kz
+ r del myzset
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r zadd myzset 1 a 2 b
+ r zrem myzset x
+ r zadd myzset 3 x 4 y 5 z
+ r zrem myzset x
+ assert_equal {pmessage * __keyspace@9__:myzset zadd} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:myzset zadd} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:myzset zrem} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: hash events test" {
+ r config set notify-keyspace-events Kh
+ r del myhash
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r hmset myhash yes 1 no 0
+ r hincrby myhash yes 10
+ assert_equal {pmessage * __keyspace@9__:myhash hset} [$rd1 read]
+ assert_equal {pmessage * __keyspace@9__:myhash hincrby} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: expired events (triggered expire)" {
+ r config set notify-keyspace-events Ex
+ r del foo
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r psetex foo 100 1
+ wait_for_condition 50 100 {
+ [r exists foo] == 0
+ } else {
+ fail "Key does not expire?!"
+ }
+ assert_equal {pmessage * __keyevent@9__:expired foo} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: expired events (background expire)" {
+ r config set notify-keyspace-events Ex
+ r del foo
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r psetex foo 100 1
+ assert_equal {pmessage * __keyevent@9__:expired foo} [$rd1 read]
+ $rd1 close
+ }
+
+ test "Keyspace notifications: evicted events" {
+ r config set notify-keyspace-events Ee
+ r config set maxmemory-policy allkeys-lru
+ r flushdb
+ set rd1 [redis_deferring_client]
+ assert_equal {1} [psubscribe $rd1 *]
+ r set foo bar
+ r config set maxmemory 1
+ assert_equal {pmessage * __keyevent@9__:evicted foo} [$rd1 read]
+ r config set maxmemory 0
+ $rd1 close
+ }
+
+ test "Keyspace notifications: test CONFIG GET/SET of event flags" {
+ r config set notify-keyspace-events gKE
+ assert_equal {gKE} [lindex [r config get notify-keyspace-events] 1]
+ r config set notify-keyspace-events {$lshzxeKE}
+ assert_equal {$lshzxeKE} [lindex [r config get notify-keyspace-events] 1]
+ r config set notify-keyspace-events KA
+ assert_equal {AK} [lindex [r config get notify-keyspace-events] 1]
+ r config set notify-keyspace-events EA
+ assert_equal {AE} [lindex [r config get notify-keyspace-events] 1]
+ }
+}
diff --git a/tests/unit/quit.tcl b/tests/unit/quit.tcl
new file mode 100644
index 0000000..4cf440a
--- /dev/null
+++ b/tests/unit/quit.tcl
@@ -0,0 +1,40 @@
+start_server {tags {"quit"}} {
+ proc format_command {args} {
+ set cmd "*[llength $args]\r\n"
+ foreach a $args {
+ append cmd "$[string length $a]\r\n$a\r\n"
+ }
+ set _ $cmd
+ }
+
+ test "QUIT returns OK" {
+ reconnect
+ assert_equal OK [r quit]
+ assert_error * {r ping}
+ }
+
+ test "Pipelined commands after QUIT must not be executed" {
+ reconnect
+ r write [format_command quit]
+ r write [format_command set foo bar]
+ r flush
+ assert_equal OK [r read]
+ assert_error * {r read}
+
+ reconnect
+ assert_equal {} [r get foo]
+ }
+
+ test "Pipelined commands after QUIT that exceed read buffer size" {
+ reconnect
+ r write [format_command quit]
+ r write [format_command set foo [string repeat "x" 1024]]
+ r flush
+ assert_equal OK [r read]
+ assert_error * {r read}
+
+ reconnect
+ assert_equal {} [r get foo]
+
+ }
+}
diff --git a/tests/unit/scan.tcl b/tests/unit/scan.tcl
new file mode 100644
index 0000000..1d84f12
--- /dev/null
+++ b/tests/unit/scan.tcl
@@ -0,0 +1,239 @@
+start_server {tags {"scan"}} {
+ test "SCAN basic" {
+ r flushdb
+ r debug populate 1000
+
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r scan $cur]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys [lsort -unique $keys]
+ assert_equal 1000 [llength $keys]
+ }
+
+ test "SCAN COUNT" {
+ r flushdb
+ r debug populate 1000
+
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r scan $cur count 5]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys [lsort -unique $keys]
+ assert_equal 1000 [llength $keys]
+ }
+
+ test "SCAN MATCH" {
+ r flushdb
+ r debug populate 1000
+
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r scan $cur match "key:1??"]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys [lsort -unique $keys]
+ assert_equal 100 [llength $keys]
+ }
+
+ foreach enc {intset hashtable} {
+ test "SSCAN with encoding $enc" {
+ # Create the Set
+ r del set
+ if {$enc eq {intset}} {
+ set prefix ""
+ } else {
+ set prefix "ele:"
+ }
+ set elements {}
+ for {set j 0} {$j < 100} {incr j} {
+ lappend elements ${prefix}${j}
+ }
+ r sadd set {*}$elements
+
+ # Verify that the encoding matches.
+ assert {[r object encoding set] eq $enc}
+
+ # Test SSCAN
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r sscan set $cur]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys [lsort -unique $keys]
+ assert_equal 100 [llength $keys]
+ }
+ }
+
+ foreach enc {ziplist hashtable} {
+ test "HSCAN with encoding $enc" {
+ # Create the Hash
+ r del hash
+ if {$enc eq {ziplist}} {
+ set count 30
+ } else {
+ set count 1000
+ }
+ set elements {}
+ for {set j 0} {$j < $count} {incr j} {
+ lappend elements key:$j $j
+ }
+ r hmset hash {*}$elements
+
+ # Verify that the encoding matches.
+ assert {[r object encoding hash] eq $enc}
+
+ # Test HSCAN
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r hscan hash $cur]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys2 {}
+ foreach {k v} $keys {
+ assert {$k eq "key:$v"}
+ lappend keys2 $k
+ }
+
+ set keys2 [lsort -unique $keys2]
+ assert_equal $count [llength $keys2]
+ }
+ }
+
+ foreach enc {ziplist skiplist} {
+ test "ZSCAN with encoding $enc" {
+ # Create the Sorted Set
+ r del zset
+ if {$enc eq {ziplist}} {
+ set count 30
+ } else {
+ set count 1000
+ }
+ set elements {}
+ for {set j 0} {$j < $count} {incr j} {
+ lappend elements $j key:$j
+ }
+ r zadd zset {*}$elements
+
+ # Verify that the encoding matches.
+ assert {[r object encoding zset] eq $enc}
+
+ # Test ZSCAN
+ set cur 0
+ set keys {}
+ while 1 {
+ set res [r zscan zset $cur]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ }
+
+ set keys2 {}
+ foreach {k v} $keys {
+ assert {$k eq "key:$v"}
+ lappend keys2 $k
+ }
+
+ set keys2 [lsort -unique $keys2]
+ assert_equal $count [llength $keys2]
+ }
+ }
+
+ test "SCAN guarantees check under write load" {
+ r flushdb
+ r debug populate 100
+
+ # We start scanning here, so keys from 0 to 99 should all be
+ # reported at the end of the iteration.
+ set keys {}
+ while 1 {
+ set res [r scan $cur]
+ set cur [lindex $res 0]
+ set k [lindex $res 1]
+ lappend keys {*}$k
+ if {$cur == 0} break
+ # Write 10 random keys at every SCAN iteration.
+ for {set j 0} {$j < 10} {incr j} {
+ r set addedkey:[randomInt 1000] foo
+ }
+ }
+
+ set keys2 {}
+ foreach k $keys {
+ if {[string length $k] > 6} continue
+ lappend keys2 $k
+ }
+
+ set keys2 [lsort -unique $keys2]
+ assert_equal 100 [llength $keys2]
+ }
+
+ test "SSCAN with integer encoded object (issue #1345)" {
+ set objects {1 a}
+ r del set
+ r sadd set {*}$objects
+ set res [r sscan set 0 MATCH *a* COUNT 100]
+ assert_equal [lsort -unique [lindex $res 1]] {a}
+ set res [r sscan set 0 MATCH *1* COUNT 100]
+ assert_equal [lsort -unique [lindex $res 1]] {1}
+ }
+
+ test "SSCAN with PATTERN" {
+ r del mykey
+ r sadd mykey foo fab fiz foobar 1 2 3 4
+ set res [r sscan mykey 0 MATCH foo* COUNT 10000]
+ lsort -unique [lindex $res 1]
+ } {foo foobar}
+
+ test "HSCAN with PATTERN" {
+ r del mykey
+ r hmset mykey foo 1 fab 2 fiz 3 foobar 10 1 a 2 b 3 c 4 d
+ set res [r hscan mykey 0 MATCH foo* COUNT 10000]
+ lsort -unique [lindex $res 1]
+ } {1 10 foo foobar}
+
+ test "ZSCAN with PATTERN" {
+ r del mykey
+ r zadd mykey 1 foo 2 fab 3 fiz 10 foobar
+ set res [r zscan mykey 0 MATCH foo* COUNT 10000]
+ lsort -unique [lindex $res 1]
+ }
+
+ test "ZSCAN scores: regression test for issue #2175" {
+ r del mykey
+ for {set j 0} {$j < 500} {incr j} {
+ r zadd mykey 9.8813129168249309e-323 $j
+ }
+ set res [lindex [r zscan mykey 0] 1]
+ set first_score [lindex $res 1]
+ assert {$first_score != 0}
+ }
+}
diff --git a/tests/unit/scripting.tcl b/tests/unit/scripting.tcl
new file mode 100644
index 0000000..be82e15
--- /dev/null
+++ b/tests/unit/scripting.tcl
@@ -0,0 +1,735 @@
+start_server {tags {"scripting"}} {
+ test {EVAL - Does Lua interpreter replies to our requests?} {
+ r eval {return 'hello'} 0
+ } {hello}
+
+ test {EVAL - Lua integer -> Redis protocol type conversion} {
+ r eval {return 100.5} 0
+ } {100}
+
+ test {EVAL - Lua string -> Redis protocol type conversion} {
+ r eval {return 'hello world'} 0
+ } {hello world}
+
+ test {EVAL - Lua true boolean -> Redis protocol type conversion} {
+ r eval {return true} 0
+ } {1}
+
+ test {EVAL - Lua false boolean -> Redis protocol type conversion} {
+ r eval {return false} 0
+ } {}
+
+ test {EVAL - Lua status code reply -> Redis protocol type conversion} {
+ r eval {return {ok='fine'}} 0
+ } {fine}
+
+ test {EVAL - Lua error reply -> Redis protocol type conversion} {
+ catch {
+ r eval {return {err='this is an error'}} 0
+ } e
+ set _ $e
+ } {this is an error}
+
+ test {EVAL - Lua table -> Redis protocol type conversion} {
+ r eval {return {1,2,3,'ciao',{1,2}}} 0
+ } {1 2 3 ciao {1 2}}
+
+ test {EVAL - Are the KEYS and ARGV arrays populated correctly?} {
+ r eval {return {KEYS[1],KEYS[2],ARGV[1],ARGV[2]}} 2 a b c d
+ } {a b c d}
+
+ test {EVAL - is Lua able to call Redis API?} {
+ r set mykey myval
+ r eval {return redis.call('get',KEYS[1])} 1 mykey
+ } {myval}
+
+ test {EVALSHA - Can we call a SHA1 if already defined?} {
+ r evalsha fd758d1589d044dd850a6f05d52f2eefd27f033f 1 mykey
+ } {myval}
+
+ test {EVALSHA - Can we call a SHA1 in uppercase?} {
+ r evalsha FD758D1589D044DD850A6F05D52F2EEFD27F033F 1 mykey
+ } {myval}
+
+ test {EVALSHA - Do we get an error on invalid SHA1?} {
+ catch {r evalsha NotValidShaSUM 0} e
+ set _ $e
+ } {NOSCRIPT*}
+
+ test {EVALSHA - Do we get an error on non defined SHA1?} {
+ catch {r evalsha ffd632c7d33e571e9f24556ebed26c3479a87130 0} e
+ set _ $e
+ } {NOSCRIPT*}
+
+ test {EVAL - Redis integer -> Lua type conversion} {
+ r set x 0
+ r eval {
+ local foo = redis.pcall('incr',KEYS[1])
+ return {type(foo),foo}
+ } 1 x
+ } {number 1}
+
+ test {EVAL - Redis bulk -> Lua type conversion} {
+ r set mykey myval
+ r eval {
+ local foo = redis.pcall('get',KEYS[1])
+ return {type(foo),foo}
+ } 1 mykey
+ } {string myval}
+
+ test {EVAL - Redis multi bulk -> Lua type conversion} {
+ r del mylist
+ r rpush mylist a
+ r rpush mylist b
+ r rpush mylist c
+ r eval {
+ local foo = redis.pcall('lrange',KEYS[1],0,-1)
+ return {type(foo),foo[1],foo[2],foo[3],# foo}
+ } 1 mylist
+ } {table a b c 3}
+
+ test {EVAL - Redis status reply -> Lua type conversion} {
+ r eval {
+ local foo = redis.pcall('set',KEYS[1],'myval')
+ return {type(foo),foo['ok']}
+ } 1 mykey
+ } {table OK}
+
+ test {EVAL - Redis error reply -> Lua type conversion} {
+ r set mykey myval
+ r eval {
+ local foo = redis.pcall('incr',KEYS[1])
+ return {type(foo),foo['err']}
+ } 1 mykey
+ } {table {ERR value is not an integer or out of range}}
+
+ test {EVAL - Redis nil bulk reply -> Lua type conversion} {
+ r del mykey
+ r eval {
+ local foo = redis.pcall('get',KEYS[1])
+ return {type(foo),foo == false}
+ } 1 mykey
+ } {boolean 1}
+
+ test {EVAL - Is the Lua client using the currently selected DB?} {
+ r set mykey "this is DB 9"
+ r select 10
+ r set mykey "this is DB 10"
+ r eval {return redis.pcall('get',KEYS[1])} 1 mykey
+ } {this is DB 10}
+
+ test {EVAL - SELECT inside Lua should not affect the caller} {
+ # here we DB 10 is selected
+ r set mykey "original value"
+ r eval {return redis.pcall('select','9')} 0
+ set res [r get mykey]
+ r select 9
+ set res
+ } {original value}
+
+ if 0 {
+ test {EVAL - Script can't run more than configured time limit} {
+ r config set lua-time-limit 1
+ catch {
+ r eval {
+ local i = 0
+ while true do i=i+1 end
+ } 0
+ } e
+ set _ $e
+ } {*execution time*}
+ }
+
+ test {EVAL - Scripts can't run certain commands} {
+ set e {}
+ catch {r eval {return redis.pcall('blpop','x',0)} 0} e
+ set e
+ } {*not allowed*}
+
+ test {EVAL - Scripts can't run certain commands} {
+ set e {}
+ catch {
+ r eval "redis.pcall('randomkey'); return redis.pcall('set','x','ciao')" 0
+ } e
+ set e
+ } {*not allowed after*}
+
+ test {EVAL - No arguments to redis.call/pcall is considered an error} {
+ set e {}
+ catch {r eval {return redis.call()} 0} e
+ set e
+ } {*one argument*}
+
+ test {EVAL - redis.call variant raises a Lua error on Redis cmd error (1)} {
+ set e {}
+ catch {
+ r eval "redis.call('nosuchcommand')" 0
+ } e
+ set e
+ } {*Unknown Redis*}
+
+ test {EVAL - redis.call variant raises a Lua error on Redis cmd error (1)} {
+ set e {}
+ catch {
+ r eval "redis.call('get','a','b','c')" 0
+ } e
+ set e
+ } {*number of args*}
+
+ test {EVAL - redis.call variant raises a Lua error on Redis cmd error (1)} {
+ set e {}
+ r set foo bar
+ catch {
+ r eval {redis.call('lpush',KEYS[1],'val')} 1 foo
+ } e
+ set e
+ } {*against a key*}
+
+ test {EVAL - JSON numeric decoding} {
+ # We must return the table as a string because otherwise
+ # Redis converts floats to ints and we get 0 and 1023 instead
+ # of 0.0003 and 1023.2 as the parsed output.
+ r eval {return
+ table.concat(
+ cjson.decode(
+ "[0.0, -5e3, -1, 0.3e-3, 1023.2, 0e10]"), " ")
+ } 0
+ } {0 -5000 -1 0.0003 1023.2 0}
+
+ test {EVAL - JSON string decoding} {
+ r eval {local decoded = cjson.decode('{"keya": "a", "keyb": "b"}')
+ return {decoded.keya, decoded.keyb}
+ } 0
+ } {a b}
+
+ test {EVAL - cmsgpack can pack double?} {
+ r eval {local encoded = cmsgpack.pack(0.1)
+ local h = ""
+ for i = 1, #encoded do
+ h = h .. string.format("%02x",string.byte(encoded,i))
+ end
+ return h
+ } 0
+ } {cb3fb999999999999a}
+
+ test {EVAL - cmsgpack can pack negative int64?} {
+ r eval {local encoded = cmsgpack.pack(-1099511627776)
+ local h = ""
+ for i = 1, #encoded do
+ h = h .. string.format("%02x",string.byte(encoded,i))
+ end
+ return h
+ } 0
+ } {d3ffffff0000000000}
+
+ test {EVAL - cmsgpack can pack and unpack circular references?} {
+ r eval {local a = {x=nil,y=5}
+ local b = {x=a}
+ a['x'] = b
+ local encoded = cmsgpack.pack(a)
+ local h = ""
+ -- cmsgpack encodes to a depth of 16, but can't encode
+ -- references, so the encoded object has a deep copy recusive
+ -- depth of 16.
+ for i = 1, #encoded do
+ h = h .. string.format("%02x",string.byte(encoded,i))
+ end
+ -- when unpacked, re.x.x != re because the unpack creates
+ -- individual tables down to a depth of 16.
+ -- (that's why the encoded output is so large)
+ local re = cmsgpack.unpack(encoded)
+ assert(re)
+ assert(re.x)
+ assert(re.x.x.y == re.y)
+ assert(re.x.x.x.x.y == re.y)
+ assert(re.x.x.x.x.x.x.y == re.y)
+ assert(re.x.x.x.x.x.x.x.x.x.x.y == re.y)
+ -- maximum working depth:
+ assert(re.x.x.x.x.x.x.x.x.x.x.x.x.x.x.y == re.y)
+ -- now the last x would be b above and has no y
+ assert(re.x.x.x.x.x.x.x.x.x.x.x.x.x.x.x)
+ -- so, the final x.x is at the depth limit and was assigned nil
+ assert(re.x.x.x.x.x.x.x.x.x.x.x.x.x.x.x.x == nil)
+ return {h, re.x.x.x.x.x.x.x.x.y == re.y, re.y == 5}
+ } 0
+ } {82a17905a17881a17882a17905a17881a17882a17905a17881a17882a17905a17881a17882a17905a17881a17882a17905a17881a17882a17905a17881a17882a17905a17881a178c0 1 1}
+
+ test {EVAL - Numerical sanity check from bitop} {
+ r eval {assert(0x7fffffff == 2147483647, "broken hex literals");
+ assert(0xffffffff == -1 or 0xffffffff == 2^32-1,
+ "broken hex literals");
+ assert(tostring(-1) == "-1", "broken tostring()");
+ assert(tostring(0xffffffff) == "-1" or
+ tostring(0xffffffff) == "4294967295",
+ "broken tostring()")
+ } 0
+ } {}
+
+ test {EVAL - Verify minimal bitop functionality} {
+ r eval {assert(bit.tobit(1) == 1);
+ assert(bit.band(1) == 1);
+ assert(bit.bxor(1,2) == 3);
+ assert(bit.bor(1,2,4,8,16,32,64,128) == 255)
+ } 0
+ } {}
+
+ test {EVAL - Able to parse trailing comments} {
+ r eval {return 'hello' --trailing comment} 0
+ } {hello}
+
+ test {SCRIPTING FLUSH - is able to clear the scripts cache?} {
+ r set mykey myval
+ set v [r evalsha fd758d1589d044dd850a6f05d52f2eefd27f033f 1 mykey]
+ assert_equal $v myval
+ set e ""
+ r script flush
+ catch {r evalsha fd758d1589d044dd850a6f05d52f2eefd27f033f 1 mykey} e
+ set e
+ } {NOSCRIPT*}
+
+ test {SCRIPT EXISTS - can detect already defined scripts?} {
+ r eval "return 1+1" 0
+ r script exists a27e7e8a43702b7046d4f6a7ccf5b60cef6b9bd9 a27e7e8a43702b7046d4f6a7ccf5b60cef6b9bda
+ } {1 0}
+
+ test {SCRIPT LOAD - is able to register scripts in the scripting cache} {
+ list \
+ [r script load "return 'loaded'"] \
+ [r evalsha b534286061d4b9e4026607613b95c06c06015ae8 0]
+ } {b534286061d4b9e4026607613b95c06c06015ae8 loaded}
+
+ test "In the context of Lua the output of random commands gets ordered" {
+ r del myset
+ r sadd myset a b c d e f g h i l m n o p q r s t u v z aa aaa azz
+ r eval {return redis.call('smembers',KEYS[1])} 1 myset
+ } {a aa aaa azz b c d e f g h i l m n o p q r s t u v z}
+
+ test "SORT is normally not alpha re-ordered for the scripting engine" {
+ r del myset
+ r sadd myset 1 2 3 4 10
+ r eval {return redis.call('sort',KEYS[1],'desc')} 1 myset
+ } {10 4 3 2 1}
+
+ test "SORT BY <constant> output gets ordered for scripting" {
+ r del myset
+ r sadd myset a b c d e f g h i l m n o p q r s t u v z aa aaa azz
+ r eval {return redis.call('sort',KEYS[1],'by','_')} 1 myset
+ } {a aa aaa azz b c d e f g h i l m n o p q r s t u v z}
+
+ test "SORT BY <constant> with GET gets ordered for scripting" {
+ r del myset
+ r sadd myset a b c
+ r eval {return redis.call('sort',KEYS[1],'by','_','get','#','get','_:*')} 1 myset
+ } {a {} b {} c {}}
+
+ test "redis.sha1hex() implementation" {
+ list [r eval {return redis.sha1hex('')} 0] \
+ [r eval {return redis.sha1hex('Pizza & Mandolino')} 0]
+ } {da39a3ee5e6b4b0d3255bfef95601890afd80709 74822d82031af7493c20eefa13bd07ec4fada82f}
+
+ test {Globals protection reading an undeclared global variable} {
+ catch {r eval {return a} 0} e
+ set e
+ } {*ERR*attempted to access * global*}
+
+ test {Globals protection setting an undeclared global*} {
+ catch {r eval {a=10} 0} e
+ set e
+ } {*ERR*attempted to create global*}
+
+ test {Test an example script DECR_IF_GT} {
+ set decr_if_gt {
+ local current
+
+ current = redis.call('get',KEYS[1])
+ if not current then return nil end
+ if current > ARGV[1] then
+ return redis.call('decr',KEYS[1])
+ else
+ return redis.call('get',KEYS[1])
+ end
+ }
+ r set foo 5
+ set res {}
+ lappend res [r eval $decr_if_gt 1 foo 2]
+ lappend res [r eval $decr_if_gt 1 foo 2]
+ lappend res [r eval $decr_if_gt 1 foo 2]
+ lappend res [r eval $decr_if_gt 1 foo 2]
+ lappend res [r eval $decr_if_gt 1 foo 2]
+ set res
+ } {4 3 2 2 2}
+
+ test {Scripting engine resets PRNG at every script execution} {
+ set rand1 [r eval {return tostring(math.random())} 0]
+ set rand2 [r eval {return tostring(math.random())} 0]
+ assert_equal $rand1 $rand2
+ }
+
+ test {Scripting engine PRNG can be seeded correctly} {
+ set rand1 [r eval {
+ math.randomseed(ARGV[1]); return tostring(math.random())
+ } 0 10]
+ set rand2 [r eval {
+ math.randomseed(ARGV[1]); return tostring(math.random())
+ } 0 10]
+ set rand3 [r eval {
+ math.randomseed(ARGV[1]); return tostring(math.random())
+ } 0 20]
+ assert_equal $rand1 $rand2
+ assert {$rand2 ne $rand3}
+ }
+
+ test {EVAL does not leak in the Lua stack} {
+ r set x 0
+ # Use a non blocking client to speedup the loop.
+ set rd [redis_deferring_client]
+ for {set j 0} {$j < 10000} {incr j} {
+ $rd eval {return redis.call("incr",KEYS[1])} 1 x
+ }
+ for {set j 0} {$j < 10000} {incr j} {
+ $rd read
+ }
+ assert {[s used_memory_lua] < 1024*100}
+ $rd close
+ r get x
+ } {10000}
+
+ test {EVAL processes writes from AOF in read-only slaves} {
+ r flushall
+ r config set appendonly yes
+ r eval {redis.call("set",KEYS[1],"100")} 1 foo
+ r eval {redis.call("incr",KEYS[1])} 1 foo
+ r eval {redis.call("incr",KEYS[1])} 1 foo
+ wait_for_condition 50 100 {
+ [s aof_rewrite_in_progress] == 0
+ } else {
+ fail "AOF rewrite can't complete after CONFIG SET appendonly yes."
+ }
+ r config set slave-read-only yes
+ r slaveof 127.0.0.1 0
+ r debug loadaof
+ set res [r get foo]
+ r slaveof no one
+ set res
+ } {102}
+
+ test {We can call scripts rewriting client->argv from Lua} {
+ r del myset
+ r sadd myset a b c
+ r mset a 1 b 2 c 3 d 4
+ assert {[r spop myset] ne {}}
+ assert {[r spop myset 1] ne {}}
+ assert {[r spop myset] ne {}}
+ assert {[r mget a b c d] eq {1 2 3 4}}
+ assert {[r spop myset] eq {}}
+ }
+
+ test {Call Redis command with many args from Lua (issue #1764)} {
+ r eval {
+ local i
+ local x={}
+ redis.call('del','mylist')
+ for i=1,100 do
+ table.insert(x,i)
+ end
+ redis.call('rpush','mylist',unpack(x))
+ return redis.call('lrange','mylist',0,-1)
+ } 0
+ } {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100}
+
+ test {Number conversion precision test (issue #1118)} {
+ r eval {
+ local value = 9007199254740991
+ redis.call("set","foo",value)
+ return redis.call("get","foo")
+ } 0
+ } {9007199254740991}
+
+ test {String containing number precision test (regression of issue #1118)} {
+ r eval {
+ redis.call("set", "key", "12039611435714932082")
+ return redis.call("get", "key")
+ } 0
+ } {12039611435714932082}
+
+ test {Verify negative arg count is error instead of crash (issue #1842)} {
+ catch { r eval { return "hello" } -12 } e
+ set e
+ } {ERR Number of keys can't be negative}
+
+ test {Correct handling of reused argv (issue #1939)} {
+ r eval {
+ for i = 0, 10 do
+ redis.call('SET', 'a', '1')
+ redis.call('MGET', 'a', 'b', 'c')
+ redis.call('EXPIRE', 'a', 0)
+ redis.call('GET', 'a')
+ redis.call('MGET', 'a', 'b', 'c')
+ end
+ } 0
+ }
+
+ test {Functions in the Redis namespace are able to report errors} {
+ catch {
+ r eval {
+ redis.sha1hex()
+ } 0
+ } e
+ set e
+ } {*wrong number*}
+}
+
+# Start a new server since the last test in this stanza will kill the
+# instance at all.
+start_server {tags {"scripting"}} {
+ test {Timedout read-only scripts can be killed by SCRIPT KILL} {
+ set rd [redis_deferring_client]
+ r config set lua-time-limit 10
+ $rd eval {while true do end} 0
+ after 200
+ catch {r ping} e
+ assert_match {BUSY*} $e
+ r script kill
+ after 200 ; # Give some time to Lua to call the hook again...
+ assert_equal [r ping] "PONG"
+ }
+
+ test {Timedout script link is still usable after Lua returns} {
+ r config set lua-time-limit 10
+ r eval {for i=1,100000 do redis.call('ping') end return 'ok'} 0
+ r ping
+ } {PONG}
+
+ test {Timedout scripts that modified data can't be killed by SCRIPT KILL} {
+ set rd [redis_deferring_client]
+ r config set lua-time-limit 10
+ $rd eval {redis.call('set',KEYS[1],'y'); while true do end} 1 x
+ after 200
+ catch {r ping} e
+ assert_match {BUSY*} $e
+ catch {r script kill} e
+ assert_match {UNKILLABLE*} $e
+ catch {r ping} e
+ assert_match {BUSY*} $e
+ }
+
+ # Note: keep this test at the end of this server stanza because it
+ # kills the server.
+ test {SHUTDOWN NOSAVE can kill a timedout script anyway} {
+ # The server sould be still unresponding to normal commands.
+ catch {r ping} e
+ assert_match {BUSY*} $e
+ catch {r shutdown nosave}
+ # Make sure the server was killed
+ catch {set rd [redis_deferring_client]} e
+ assert_match {*connection refused*} $e
+ }
+}
+
+foreach cmdrepl {0 1} {
+ start_server {tags {"scripting repl"}} {
+ start_server {} {
+ if {$cmdrepl == 1} {
+ set rt "(commmands replication)"
+ } else {
+ set rt "(scripts replication)"
+ r debug lua-always-replicate-commands 1
+ }
+
+ test "Before the slave connects we issue two EVAL commands $rt" {
+ # One with an error, but still executing a command.
+ # SHA is: 67164fc43fa971f76fd1aaeeaf60c1c178d25876
+ catch {
+ r eval {redis.call('incr',KEYS[1]); redis.call('nonexisting')} 1 x
+ }
+ # One command is correct:
+ # SHA is: 6f5ade10a69975e903c6d07b10ea44c6382381a5
+ r eval {return redis.call('incr',KEYS[1])} 1 x
+ } {2}
+
+ test "Connect a slave to the master instance $rt" {
+ r -1 slaveof [srv 0 host] [srv 0 port]
+ wait_for_condition 50 100 {
+ [s -1 role] eq {slave} &&
+ [string match {*master_link_status:up*} [r -1 info replication]]
+ } else {
+ fail "Can't turn the instance into a slave"
+ }
+ }
+
+ test "Now use EVALSHA against the master, with both SHAs $rt" {
+ # The server should replicate successful and unsuccessful
+ # commands as EVAL instead of EVALSHA.
+ catch {
+ r evalsha 67164fc43fa971f76fd1aaeeaf60c1c178d25876 1 x
+ }
+ r evalsha 6f5ade10a69975e903c6d07b10ea44c6382381a5 1 x
+ } {4}
+
+ test "If EVALSHA was replicated as EVAL, 'x' should be '4' $rt" {
+ wait_for_condition 50 100 {
+ [r -1 get x] eq {4}
+ } else {
+ fail "Expected 4 in x, but value is '[r -1 get x]'"
+ }
+ }
+
+ test "Replication of script multiple pushes to list with BLPOP $rt" {
+ set rd [redis_deferring_client]
+ $rd brpop a 0
+ r eval {
+ redis.call("lpush",KEYS[1],"1");
+ redis.call("lpush",KEYS[1],"2");
+ } 1 a
+ set res [$rd read]
+ $rd close
+ wait_for_condition 50 100 {
+ [r -1 lrange a 0 -1] eq [r lrange a 0 -1]
+ } else {
+ fail "Expected list 'a' in slave and master to be the same, but they are respectively '[r -1 lrange a 0 -1]' and '[r lrange a 0 -1]'"
+ }
+ set res
+ } {a 1}
+
+ test "EVALSHA replication when first call is readonly $rt" {
+ r del x
+ r eval {if tonumber(ARGV[1]) > 0 then redis.call('incr', KEYS[1]) end} 1 x 0
+ r evalsha 6e0e2745aa546d0b50b801a20983b70710aef3ce 1 x 0
+ r evalsha 6e0e2745aa546d0b50b801a20983b70710aef3ce 1 x 1
+ wait_for_condition 50 100 {
+ [r -1 get x] eq {1}
+ } else {
+ fail "Expected 1 in x, but value is '[r -1 get x]'"
+ }
+ }
+
+ test "Lua scripts using SELECT are replicated correctly $rt" {
+ r eval {
+ redis.call("set","foo1","bar1")
+ redis.call("select","10")
+ redis.call("incr","x")
+ redis.call("select","11")
+ redis.call("incr","z")
+ } 0
+ r eval {
+ redis.call("set","foo1","bar1")
+ redis.call("select","10")
+ redis.call("incr","x")
+ redis.call("select","11")
+ redis.call("incr","z")
+ } 0
+ wait_for_condition 50 100 {
+ [r -1 debug digest] eq [r debug digest]
+ } else {
+ fail "Master-Slave desync after Lua script using SELECT."
+ }
+ }
+ }
+ }
+}
+
+start_server {tags {"scripting repl"}} {
+ start_server {overrides {appendonly yes}} {
+ test "Connect a slave to the master instance" {
+ r -1 slaveof [srv 0 host] [srv 0 port]
+ wait_for_condition 50 100 {
+ [s -1 role] eq {slave} &&
+ [string match {*master_link_status:up*} [r -1 info replication]]
+ } else {
+ fail "Can't turn the instance into a slave"
+ }
+ }
+
+ test "Redis.replicate_commands() must be issued before any write" {
+ r eval {
+ redis.call('set','foo','bar');
+ return redis.replicate_commands();
+ } 0
+ } {}
+
+ test "Redis.replicate_commands() must be issued before any write (2)" {
+ r eval {
+ return redis.replicate_commands();
+ } 0
+ } {1}
+
+ test "Redis.set_repl() must be issued after replicate_commands()" {
+ catch {
+ r eval {
+ redis.set_repl(redis.REPL_ALL);
+ } 0
+ } e
+ set e
+ } {*only after turning on*}
+
+ test "Redis.set_repl() don't accept invalid values" {
+ catch {
+ r eval {
+ redis.replicate_commands();
+ redis.set_repl(12345);
+ } 0
+ } e
+ set e
+ } {*Invalid*flags*}
+
+ test "Test selective replication of certain Redis commands from Lua" {
+ r del a b c d
+ r eval {
+ redis.replicate_commands();
+ redis.call('set','a','1');
+ redis.set_repl(redis.REPL_NONE);
+ redis.call('set','b','2');
+ redis.set_repl(redis.REPL_AOF);
+ redis.call('set','c','3');
+ redis.set_repl(redis.REPL_ALL);
+ redis.call('set','d','4');
+ } 0
+
+ wait_for_condition 50 100 {
+ [r -1 mget a b c d] eq {1 {} {} 4}
+ } else {
+ fail "Only a and c should be replicated to slave"
+ }
+
+ # Master should have everything right now
+ assert {[r mget a b c d] eq {1 2 3 4}}
+
+ # After an AOF reload only a, c and d should exist
+ r debug loadaof
+
+ assert {[r mget a b c d] eq {1 {} 3 4}}
+ }
+
+ test "PRNG is seeded randomly for command replication" {
+ set a [
+ r eval {
+ redis.replicate_commands();
+ return math.random()*100000;
+ } 0
+ ]
+ set b [
+ r eval {
+ redis.replicate_commands();
+ return math.random()*100000;
+ } 0
+ ]
+ assert {$a ne $b}
+ }
+
+ test "Using side effects is not a problem with command replication" {
+ r eval {
+ redis.replicate_commands();
+ redis.call('set','time',redis.call('time')[1])
+ } 0
+
+ assert {[r get time] ne {}}
+
+ wait_for_condition 50 100 {
+ [r get time] eq [r -1 get time]
+ } else {
+ fail "Time key does not match between master and slave"
+ }
+ }
+ }
+}
+
diff --git a/tests/unit/slowlog.tcl b/tests/unit/slowlog.tcl
new file mode 100644
index 0000000..b25b91e
--- /dev/null
+++ b/tests/unit/slowlog.tcl
@@ -0,0 +1,70 @@
+start_server {tags {"slowlog"} overrides {slowlog-log-slower-than 1000000}} {
+ test {SLOWLOG - check that it starts with an empty log} {
+ r slowlog len
+ } {0}
+
+ test {SLOWLOG - only logs commands taking more time than specified} {
+ r config set slowlog-log-slower-than 100000
+ r ping
+ assert_equal [r slowlog len] 0
+ r debug sleep 0.2
+ assert_equal [r slowlog len] 1
+ }
+
+ test {SLOWLOG - max entries is correctly handled} {
+ r config set slowlog-log-slower-than 0
+ r config set slowlog-max-len 10
+ for {set i 0} {$i < 100} {incr i} {
+ r ping
+ }
+ r slowlog len
+ } {10}
+
+ test {SLOWLOG - GET optional argument to limit output len works} {
+ llength [r slowlog get 5]
+ } {5}
+
+ test {SLOWLOG - RESET subcommand works} {
+ r config set slowlog-log-slower-than 100000
+ r slowlog reset
+ r slowlog len
+ } {0}
+
+ test {SLOWLOG - logged entry sanity check} {
+ r debug sleep 0.2
+ set e [lindex [r slowlog get] 0]
+ assert_equal [llength $e] 4
+ assert_equal [lindex $e 0] 105
+ assert_equal [expr {[lindex $e 2] > 100000}] 1
+ assert_equal [lindex $e 3] {debug sleep 0.2}
+ }
+
+ test {SLOWLOG - commands with too many arguments are trimmed} {
+ r config set slowlog-log-slower-than 0
+ r slowlog reset
+ r sadd set 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
+ set e [lindex [r slowlog get] 0]
+ lindex $e 3
+ } {sadd set 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 {... (2 more arguments)}}
+
+ test {SLOWLOG - too long arguments are trimmed} {
+ r config set slowlog-log-slower-than 0
+ r slowlog reset
+ set arg [string repeat A 129]
+ r sadd set foo $arg
+ set e [lindex [r slowlog get] 0]
+ lindex $e 3
+ } {sadd set foo {AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA... (1 more bytes)}}
+
+ test {SLOWLOG - EXEC is not logged, just executed commands} {
+ r config set slowlog-log-slower-than 100000
+ r slowlog reset
+ assert_equal [r slowlog len] 0
+ r multi
+ r debug sleep 0.2
+ r exec
+ assert_equal [r slowlog len] 1
+ set e [lindex [r slowlog get] 0]
+ assert_equal [lindex $e 3] {debug sleep 0.2}
+ }
+}
diff --git a/tests/unit/sort.tcl b/tests/unit/sort.tcl
new file mode 100644
index 0000000..083c454
--- /dev/null
+++ b/tests/unit/sort.tcl
@@ -0,0 +1,318 @@
+start_server {
+ tags {"sort"}
+ overrides {
+ "list-max-ziplist-size" 32
+ "set-max-intset-entries" 32
+ }
+} {
+ proc create_random_dataset {num cmd} {
+ set tosort {}
+ set result {}
+ array set seenrand {}
+ r del tosort
+ for {set i 0} {$i < $num} {incr i} {
+ # Make sure all the weights are different because
+ # Redis does not use a stable sort but Tcl does.
+ while 1 {
+ randpath {
+ set rint [expr int(rand()*1000000)]
+ } {
+ set rint [expr rand()]
+ }
+ if {![info exists seenrand($rint)]} break
+ }
+ set seenrand($rint) x
+ r $cmd tosort $i
+ r set weight_$i $rint
+ r hset wobj_$i weight $rint
+ lappend tosort [list $i $rint]
+ }
+ set sorted [lsort -index 1 -real $tosort]
+ for {set i 0} {$i < $num} {incr i} {
+ lappend result [lindex $sorted $i 0]
+ }
+ set _ $result
+ }
+
+ foreach {num cmd enc title} {
+ 16 lpush quicklist "Old Ziplist"
+ 1000 lpush quicklist "Old Linked list"
+ 10000 lpush quicklist "Old Big Linked list"
+ 16 sadd intset "Intset"
+ 1000 sadd hashtable "Hash table"
+ 10000 sadd hashtable "Big Hash table"
+ } {
+ set result [create_random_dataset $num $cmd]
+ assert_encoding $enc tosort
+
+ test "$title: SORT BY key" {
+ assert_equal $result [r sort tosort BY weight_*]
+ }
+
+ test "$title: SORT BY key with limit" {
+ assert_equal [lrange $result 5 9] [r sort tosort BY weight_* LIMIT 5 5]
+ }
+
+ test "$title: SORT BY hash field" {
+ assert_equal $result [r sort tosort BY wobj_*->weight]
+ }
+ }
+
+ set result [create_random_dataset 16 lpush]
+ test "SORT GET #" {
+ assert_equal [lsort -integer $result] [r sort tosort GET #]
+ }
+
+ test "SORT GET <const>" {
+ r del foo
+ set res [r sort tosort GET foo]
+ assert_equal 16 [llength $res]
+ foreach item $res { assert_equal {} $item }
+ }
+
+ test "SORT GET (key and hash) with sanity check" {
+ set l1 [r sort tosort GET # GET weight_*]
+ set l2 [r sort tosort GET # GET wobj_*->weight]
+ foreach {id1 w1} $l1 {id2 w2} $l2 {
+ assert_equal $id1 $id2
+ assert_equal $w1 [r get weight_$id1]
+ assert_equal $w2 [r get weight_$id1]
+ }
+ }
+
+ test "SORT BY key STORE" {
+ r sort tosort BY weight_* store sort-res
+ assert_equal $result [r lrange sort-res 0 -1]
+ assert_equal 16 [r llen sort-res]
+ assert_encoding quicklist sort-res
+ }
+
+ test "SORT BY hash field STORE" {
+ r sort tosort BY wobj_*->weight store sort-res
+ assert_equal $result [r lrange sort-res 0 -1]
+ assert_equal 16 [r llen sort-res]
+ assert_encoding quicklist sort-res
+ }
+
+ test "SORT extracts STORE correctly" {
+ r command getkeys sort abc store def
+ } {abc def}
+
+ test "SORT extracts multiple STORE correctly" {
+ r command getkeys sort abc store invalid store stillbad store def
+ } {abc def}
+
+ test "SORT DESC" {
+ assert_equal [lsort -decreasing -integer $result] [r sort tosort DESC]
+ }
+
+ test "SORT ALPHA against integer encoded strings" {
+ r del mylist
+ r lpush mylist 2
+ r lpush mylist 1
+ r lpush mylist 3
+ r lpush mylist 10
+ r sort mylist alpha
+ } {1 10 2 3}
+
+ test "SORT sorted set" {
+ r del zset
+ r zadd zset 1 a
+ r zadd zset 5 b
+ r zadd zset 2 c
+ r zadd zset 10 d
+ r zadd zset 3 e
+ r sort zset alpha desc
+ } {e d c b a}
+
+ test "SORT sorted set BY nosort should retain ordering" {
+ r del zset
+ r zadd zset 1 a
+ r zadd zset 5 b
+ r zadd zset 2 c
+ r zadd zset 10 d
+ r zadd zset 3 e
+ r multi
+ r sort zset by nosort asc
+ r sort zset by nosort desc
+ r exec
+ } {{a c e b d} {d b e c a}}
+
+ test "SORT sorted set BY nosort + LIMIT" {
+ r del zset
+ r zadd zset 1 a
+ r zadd zset 5 b
+ r zadd zset 2 c
+ r zadd zset 10 d
+ r zadd zset 3 e
+ assert_equal [r sort zset by nosort asc limit 0 1] {a}
+ assert_equal [r sort zset by nosort desc limit 0 1] {d}
+ assert_equal [r sort zset by nosort asc limit 0 2] {a c}
+ assert_equal [r sort zset by nosort desc limit 0 2] {d b}
+ assert_equal [r sort zset by nosort limit 5 10] {}
+ assert_equal [r sort zset by nosort limit -10 100] {a c e b d}
+ }
+
+ test "SORT sorted set BY nosort works as expected from scripts" {
+ r del zset
+ r zadd zset 1 a
+ r zadd zset 5 b
+ r zadd zset 2 c
+ r zadd zset 10 d
+ r zadd zset 3 e
+ r eval {
+ return {redis.call('sort',KEYS[1],'by','nosort','asc'),
+ redis.call('sort',KEYS[1],'by','nosort','desc')}
+ } 1 zset
+ } {{a c e b d} {d b e c a}}
+
+ test "SORT sorted set: +inf and -inf handling" {
+ r del zset
+ r zadd zset -100 a
+ r zadd zset 200 b
+ r zadd zset -300 c
+ r zadd zset 1000000 d
+ r zadd zset +inf max
+ r zadd zset -inf min
+ r zrange zset 0 -1
+ } {min c a b d max}
+
+ test "SORT regression for issue #19, sorting floats" {
+ r flushdb
+ set floats {1.1 5.10 3.10 7.44 2.1 5.75 6.12 0.25 1.15}
+ foreach x $floats {
+ r lpush mylist $x
+ }
+ assert_equal [lsort -real $floats] [r sort mylist]
+ }
+
+ test "SORT with STORE returns zero if result is empty (github issue 224)" {
+ r flushdb
+ r sort foo store bar
+ } {0}
+
+ test "SORT with STORE does not create empty lists (github issue 224)" {
+ r flushdb
+ r lpush foo bar
+ r sort foo alpha limit 10 10 store zap
+ r exists zap
+ } {0}
+
+ test "SORT with STORE removes key if result is empty (github issue 227)" {
+ r flushdb
+ r lpush foo bar
+ r sort emptylist store foo
+ r exists foo
+ } {0}
+
+ test "SORT with BY <constant> and STORE should still order output" {
+ r del myset mylist
+ r sadd myset a b c d e f g h i l m n o p q r s t u v z aa aaa azz
+ r sort myset alpha by _ store mylist
+ r lrange mylist 0 -1
+ } {a aa aaa azz b c d e f g h i l m n o p q r s t u v z}
+
+ test "SORT will complain with numerical sorting and bad doubles (1)" {
+ r del myset
+ r sadd myset 1 2 3 4 not-a-double
+ set e {}
+ catch {r sort myset} e
+ set e
+ } {*ERR*double*}
+
+ test "SORT will complain with numerical sorting and bad doubles (2)" {
+ r del myset
+ r sadd myset 1 2 3 4
+ r mset score:1 10 score:2 20 score:3 30 score:4 not-a-double
+ set e {}
+ catch {r sort myset by score:*} e
+ set e
+ } {*ERR*double*}
+
+ test "SORT BY sub-sorts lexicographically if score is the same" {
+ r del myset
+ r sadd myset a b c d e f g h i l m n o p q r s t u v z aa aaa azz
+ foreach ele {a aa aaa azz b c d e f g h i l m n o p q r s t u v z} {
+ set score:$ele 100
+ }
+ r sort myset by score:*
+ } {a aa aaa azz b c d e f g h i l m n o p q r s t u v z}
+
+ test "SORT GET with pattern ending with just -> does not get hash field" {
+ r del mylist
+ r lpush mylist a
+ r set x:a-> 100
+ r sort mylist by num get x:*->
+ } {100}
+
+ test "SORT by nosort retains native order for lists" {
+ r del testa
+ r lpush testa 2 1 4 3 5
+ r sort testa by nosort
+ } {5 3 4 1 2}
+
+ test "SORT by nosort plus store retains native order for lists" {
+ r del testa
+ r lpush testa 2 1 4 3 5
+ r sort testa by nosort store testb
+ r lrange testb 0 -1
+ } {5 3 4 1 2}
+
+ test "SORT by nosort with limit returns based on original list order" {
+ r sort testa by nosort limit 0 3 store testb
+ r lrange testb 0 -1
+ } {5 3 4}
+
+ tags {"slow"} {
+ set num 100
+ set res [create_random_dataset $num lpush]
+
+ test "SORT speed, $num element list BY key, 100 times" {
+ set start [clock clicks -milliseconds]
+ for {set i 0} {$i < 100} {incr i} {
+ set sorted [r sort tosort BY weight_* LIMIT 0 10]
+ }
+ set elapsed [expr [clock clicks -milliseconds]-$start]
+ if {$::verbose} {
+ puts -nonewline "\n Average time to sort: [expr double($elapsed)/100] milliseconds "
+ flush stdout
+ }
+ }
+
+ test "SORT speed, $num element list BY hash field, 100 times" {
+ set start [clock clicks -milliseconds]
+ for {set i 0} {$i < 100} {incr i} {
+ set sorted [r sort tosort BY wobj_*->weight LIMIT 0 10]
+ }
+ set elapsed [expr [clock clicks -milliseconds]-$start]
+ if {$::verbose} {
+ puts -nonewline "\n Average time to sort: [expr double($elapsed)/100] milliseconds "
+ flush stdout
+ }
+ }
+
+ test "SORT speed, $num element list directly, 100 times" {
+ set start [clock clicks -milliseconds]
+ for {set i 0} {$i < 100} {incr i} {
+ set sorted [r sort tosort LIMIT 0 10]
+ }
+ set elapsed [expr [clock clicks -milliseconds]-$start]
+ if {$::verbose} {
+ puts -nonewline "\n Average time to sort: [expr double($elapsed)/100] milliseconds "
+ flush stdout
+ }
+ }
+
+ test "SORT speed, $num element list BY <const>, 100 times" {
+ set start [clock clicks -milliseconds]
+ for {set i 0} {$i < 100} {incr i} {
+ set sorted [r sort tosort BY nokey LIMIT 0 10]
+ }
+ set elapsed [expr [clock clicks -milliseconds]-$start]
+ if {$::verbose} {
+ puts -nonewline "\n Average time to sort: [expr double($elapsed)/100] milliseconds "
+ flush stdout
+ }
+ }
+ }
+}
diff --git a/tests/unit/type/hash.tcl b/tests/unit/type/hash.tcl
new file mode 100644
index 0000000..d2c679d
--- /dev/null
+++ b/tests/unit/type/hash.tcl
@@ -0,0 +1,536 @@
+start_server {tags {"hash"}} {
+ test {HSET/HLEN - Small hash creation} {
+ array set smallhash {}
+ for {set i 0} {$i < 8} {incr i} {
+ set key __avoid_collisions__[randstring 0 8 alpha]
+ set val __avoid_collisions__[randstring 0 8 alpha]
+ if {[info exists smallhash($key)]} {
+ incr i -1
+ continue
+ }
+ r hset smallhash $key $val
+ set smallhash($key) $val
+ }
+ list [r hlen smallhash]
+ } {8}
+
+ test {Is the small hash encoded with a ziplist?} {
+ assert_encoding ziplist smallhash
+ }
+
+ test {HSET/HLEN - Big hash creation} {
+ array set bighash {}
+ for {set i 0} {$i < 1024} {incr i} {
+ set key __avoid_collisions__[randstring 0 8 alpha]
+ set val __avoid_collisions__[randstring 0 8 alpha]
+ if {[info exists bighash($key)]} {
+ incr i -1
+ continue
+ }
+ r hset bighash $key $val
+ set bighash($key) $val
+ }
+ list [r hlen bighash]
+ } {1024}
+
+ test {Is the big hash encoded with an hash table?} {
+ assert_encoding hashtable bighash
+ }
+
+ test {HGET against the small hash} {
+ set err {}
+ foreach k [array names smallhash *] {
+ if {$smallhash($k) ne [r hget smallhash $k]} {
+ set err "$smallhash($k) != [r hget smallhash $k]"
+ break
+ }
+ }
+ set _ $err
+ } {}
+
+ test {HGET against the big hash} {
+ set err {}
+ foreach k [array names bighash *] {
+ if {$bighash($k) ne [r hget bighash $k]} {
+ set err "$bighash($k) != [r hget bighash $k]"
+ break
+ }
+ }
+ set _ $err
+ } {}
+
+ test {HGET against non existing key} {
+ set rv {}
+ lappend rv [r hget smallhash __123123123__]
+ lappend rv [r hget bighash __123123123__]
+ set _ $rv
+ } {{} {}}
+
+ test {HSET in update and insert mode} {
+ set rv {}
+ set k [lindex [array names smallhash *] 0]
+ lappend rv [r hset smallhash $k newval1]
+ set smallhash($k) newval1
+ lappend rv [r hget smallhash $k]
+ lappend rv [r hset smallhash __foobar123__ newval]
+ set k [lindex [array names bighash *] 0]
+ lappend rv [r hset bighash $k newval2]
+ set bighash($k) newval2
+ lappend rv [r hget bighash $k]
+ lappend rv [r hset bighash __foobar123__ newval]
+ lappend rv [r hdel smallhash __foobar123__]
+ lappend rv [r hdel bighash __foobar123__]
+ set _ $rv
+ } {0 newval1 1 0 newval2 1 1 1}
+
+ test {HSETNX target key missing - small hash} {
+ r hsetnx smallhash __123123123__ foo
+ r hget smallhash __123123123__
+ } {foo}
+
+ test {HSETNX target key exists - small hash} {
+ r hsetnx smallhash __123123123__ bar
+ set result [r hget smallhash __123123123__]
+ r hdel smallhash __123123123__
+ set _ $result
+ } {foo}
+
+ test {HSETNX target key missing - big hash} {
+ r hsetnx bighash __123123123__ foo
+ r hget bighash __123123123__
+ } {foo}
+
+ test {HSETNX target key exists - big hash} {
+ r hsetnx bighash __123123123__ bar
+ set result [r hget bighash __123123123__]
+ r hdel bighash __123123123__
+ set _ $result
+ } {foo}
+
+ test {HMSET wrong number of args} {
+ catch {r hmset smallhash key1 val1 key2} err
+ format $err
+ } {*wrong number*}
+
+ test {HMSET - small hash} {
+ set args {}
+ foreach {k v} [array get smallhash] {
+ set newval [randstring 0 8 alpha]
+ set smallhash($k) $newval
+ lappend args $k $newval
+ }
+ r hmset smallhash {*}$args
+ } {OK}
+
+ test {HMSET - big hash} {
+ set args {}
+ foreach {k v} [array get bighash] {
+ set newval [randstring 0 8 alpha]
+ set bighash($k) $newval
+ lappend args $k $newval
+ }
+ r hmset bighash {*}$args
+ } {OK}
+
+ test {HMGET against non existing key and fields} {
+ set rv {}
+ lappend rv [r hmget doesntexist __123123123__ __456456456__]
+ lappend rv [r hmget smallhash __123123123__ __456456456__]
+ lappend rv [r hmget bighash __123123123__ __456456456__]
+ set _ $rv
+ } {{{} {}} {{} {}} {{} {}}}
+
+ test {HMGET against wrong type} {
+ r set wrongtype somevalue
+ assert_error "*wrong*" {r hmget wrongtype field1 field2}
+ }
+
+ test {HMGET - small hash} {
+ set keys {}
+ set vals {}
+ foreach {k v} [array get smallhash] {
+ lappend keys $k
+ lappend vals $v
+ }
+ set err {}
+ set result [r hmget smallhash {*}$keys]
+ if {$vals ne $result} {
+ set err "$vals != $result"
+ break
+ }
+ set _ $err
+ } {}
+
+ test {HMGET - big hash} {
+ set keys {}
+ set vals {}
+ foreach {k v} [array get bighash] {
+ lappend keys $k
+ lappend vals $v
+ }
+ set err {}
+ set result [r hmget bighash {*}$keys]
+ if {$vals ne $result} {
+ set err "$vals != $result"
+ break
+ }
+ set _ $err
+ } {}
+
+ test {HKEYS - small hash} {
+ lsort [r hkeys smallhash]
+ } [lsort [array names smallhash *]]
+
+ test {HKEYS - big hash} {
+ lsort [r hkeys bighash]
+ } [lsort [array names bighash *]]
+
+ test {HVALS - small hash} {
+ set vals {}
+ foreach {k v} [array get smallhash] {
+ lappend vals $v
+ }
+ set _ [lsort $vals]
+ } [lsort [r hvals smallhash]]
+
+ test {HVALS - big hash} {
+ set vals {}
+ foreach {k v} [array get bighash] {
+ lappend vals $v
+ }
+ set _ [lsort $vals]
+ } [lsort [r hvals bighash]]
+
+ test {HGETALL - small hash} {
+ lsort [r hgetall smallhash]
+ } [lsort [array get smallhash]]
+
+ test {HGETALL - big hash} {
+ lsort [r hgetall bighash]
+ } [lsort [array get bighash]]
+
+ test {HDEL and return value} {
+ set rv {}
+ lappend rv [r hdel smallhash nokey]
+ lappend rv [r hdel bighash nokey]
+ set k [lindex [array names smallhash *] 0]
+ lappend rv [r hdel smallhash $k]
+ lappend rv [r hdel smallhash $k]
+ lappend rv [r hget smallhash $k]
+ unset smallhash($k)
+ set k [lindex [array names bighash *] 0]
+ lappend rv [r hdel bighash $k]
+ lappend rv [r hdel bighash $k]
+ lappend rv [r hget bighash $k]
+ unset bighash($k)
+ set _ $rv
+ } {0 0 1 0 {} 1 0 {}}
+
+ test {HDEL - more than a single value} {
+ set rv {}
+ r del myhash
+ r hmset myhash a 1 b 2 c 3
+ assert_equal 0 [r hdel myhash x y]
+ assert_equal 2 [r hdel myhash a c f]
+ r hgetall myhash
+ } {b 2}
+
+ test {HDEL - hash becomes empty before deleting all specified fields} {
+ r del myhash
+ r hmset myhash a 1 b 2 c 3
+ assert_equal 3 [r hdel myhash a b c d e]
+ assert_equal 0 [r exists myhash]
+ }
+
+ test {HEXISTS} {
+ set rv {}
+ set k [lindex [array names smallhash *] 0]
+ lappend rv [r hexists smallhash $k]
+ lappend rv [r hexists smallhash nokey]
+ set k [lindex [array names bighash *] 0]
+ lappend rv [r hexists bighash $k]
+ lappend rv [r hexists bighash nokey]
+ } {1 0 1 0}
+
+ test {Is a ziplist encoded Hash promoted on big payload?} {
+ r hset smallhash foo [string repeat a 1024]
+ r debug object smallhash
+ } {*hashtable*}
+
+ test {HINCRBY against non existing database key} {
+ r del htest
+ list [r hincrby htest foo 2]
+ } {2}
+
+ test {HINCRBY against non existing hash key} {
+ set rv {}
+ r hdel smallhash tmp
+ r hdel bighash tmp
+ lappend rv [r hincrby smallhash tmp 2]
+ lappend rv [r hget smallhash tmp]
+ lappend rv [r hincrby bighash tmp 2]
+ lappend rv [r hget bighash tmp]
+ } {2 2 2 2}
+
+ test {HINCRBY against hash key created by hincrby itself} {
+ set rv {}
+ lappend rv [r hincrby smallhash tmp 3]
+ lappend rv [r hget smallhash tmp]
+ lappend rv [r hincrby bighash tmp 3]
+ lappend rv [r hget bighash tmp]
+ } {5 5 5 5}
+
+ test {HINCRBY against hash key originally set with HSET} {
+ r hset smallhash tmp 100
+ r hset bighash tmp 100
+ list [r hincrby smallhash tmp 2] [r hincrby bighash tmp 2]
+ } {102 102}
+
+ test {HINCRBY over 32bit value} {
+ r hset smallhash tmp 17179869184
+ r hset bighash tmp 17179869184
+ list [r hincrby smallhash tmp 1] [r hincrby bighash tmp 1]
+ } {17179869185 17179869185}
+
+ test {HINCRBY over 32bit value with over 32bit increment} {
+ r hset smallhash tmp 17179869184
+ r hset bighash tmp 17179869184
+ list [r hincrby smallhash tmp 17179869184] [r hincrby bighash tmp 17179869184]
+ } {34359738368 34359738368}
+
+ test {HINCRBY fails against hash value with spaces (left)} {
+ r hset smallhash str " 11"
+ r hset bighash str " 11"
+ catch {r hincrby smallhash str 1} smallerr
+ catch {r hincrby smallhash str 1} bigerr
+ set rv {}
+ lappend rv [string match "ERR*not an integer*" $smallerr]
+ lappend rv [string match "ERR*not an integer*" $bigerr]
+ } {1 1}
+
+ test {HINCRBY fails against hash value with spaces (right)} {
+ r hset smallhash str "11 "
+ r hset bighash str "11 "
+ catch {r hincrby smallhash str 1} smallerr
+ catch {r hincrby smallhash str 1} bigerr
+ set rv {}
+ lappend rv [string match "ERR*not an integer*" $smallerr]
+ lappend rv [string match "ERR*not an integer*" $bigerr]
+ } {1 1}
+
+ test {HINCRBY can detect overflows} {
+ set e {}
+ r hset hash n -9223372036854775484
+ assert {[r hincrby hash n -1] == -9223372036854775485}
+ catch {r hincrby hash n -10000} e
+ set e
+ } {*overflow*}
+
+ test {HINCRBYFLOAT against non existing database key} {
+ r del htest
+ list [r hincrbyfloat htest foo 2.5]
+ } {2.5}
+
+ test {HINCRBYFLOAT against non existing hash key} {
+ set rv {}
+ r hdel smallhash tmp
+ r hdel bighash tmp
+ lappend rv [roundFloat [r hincrbyfloat smallhash tmp 2.5]]
+ lappend rv [roundFloat [r hget smallhash tmp]]
+ lappend rv [roundFloat [r hincrbyfloat bighash tmp 2.5]]
+ lappend rv [roundFloat [r hget bighash tmp]]
+ } {2.5 2.5 2.5 2.5}
+
+ test {HINCRBYFLOAT against hash key created by hincrby itself} {
+ set rv {}
+ lappend rv [roundFloat [r hincrbyfloat smallhash tmp 3.5]]
+ lappend rv [roundFloat [r hget smallhash tmp]]
+ lappend rv [roundFloat [r hincrbyfloat bighash tmp 3.5]]
+ lappend rv [roundFloat [r hget bighash tmp]]
+ } {6 6 6 6}
+
+ test {HINCRBYFLOAT against hash key originally set with HSET} {
+ r hset smallhash tmp 100
+ r hset bighash tmp 100
+ list [roundFloat [r hincrbyfloat smallhash tmp 2.5]] \
+ [roundFloat [r hincrbyfloat bighash tmp 2.5]]
+ } {102.5 102.5}
+
+ test {HINCRBYFLOAT over 32bit value} {
+ r hset smallhash tmp 17179869184
+ r hset bighash tmp 17179869184
+ list [r hincrbyfloat smallhash tmp 1] \
+ [r hincrbyfloat bighash tmp 1]
+ } {17179869185 17179869185}
+
+ test {HINCRBYFLOAT over 32bit value with over 32bit increment} {
+ r hset smallhash tmp 17179869184
+ r hset bighash tmp 17179869184
+ list [r hincrbyfloat smallhash tmp 17179869184] \
+ [r hincrbyfloat bighash tmp 17179869184]
+ } {34359738368 34359738368}
+
+ test {HINCRBYFLOAT fails against hash value with spaces (left)} {
+ r hset smallhash str " 11"
+ r hset bighash str " 11"
+ catch {r hincrbyfloat smallhash str 1} smallerr
+ catch {r hincrbyfloat smallhash str 1} bigerr
+ set rv {}
+ lappend rv [string match "ERR*not*float*" $smallerr]
+ lappend rv [string match "ERR*not*float*" $bigerr]
+ } {1 1}
+
+ test {HINCRBYFLOAT fails against hash value with spaces (right)} {
+ r hset smallhash str "11 "
+ r hset bighash str "11 "
+ catch {r hincrbyfloat smallhash str 1} smallerr
+ catch {r hincrbyfloat smallhash str 1} bigerr
+ set rv {}
+ lappend rv [string match "ERR*not*float*" $smallerr]
+ lappend rv [string match "ERR*not*float*" $bigerr]
+ } {1 1}
+
+ test {HSTRLEN against the small hash} {
+ set err {}
+ foreach k [array names smallhash *] {
+ if {[string length $smallhash($k)] ne [r hstrlen smallhash $k]} {
+ set err "[string length $smallhash($k)] != [r hstrlen smallhash $k]"
+ break
+ }
+ }
+ set _ $err
+ } {}
+
+ test {HSTRLEN against the big hash} {
+ set err {}
+ foreach k [array names bighash *] {
+ if {[string length $bighash($k)] ne [r hstrlen bighash $k]} {
+ set err "[string length $bighash($k)] != [r hstrlen bighash $k]"
+ puts "HSTRLEN and logical length mismatch:"
+ puts "key: $k"
+ puts "Logical content: $bighash($k)"
+ puts "Server content: [r hget bighash $k]"
+ }
+ }
+ set _ $err
+ } {}
+
+ test {HSTRLEN against non existing field} {
+ set rv {}
+ lappend rv [r hstrlen smallhash __123123123__]
+ lappend rv [r hstrlen bighash __123123123__]
+ set _ $rv
+ } {0 0}
+
+ test {HSTRLEN corner cases} {
+ set vals {
+ -9223372036854775808 9223372036854775807 9223372036854775808
+ {} 0 -1 x
+ }
+ foreach v $vals {
+ r hmset smallhash field $v
+ r hmset bighash field $v
+ set len1 [string length $v]
+ set len2 [r hstrlen smallhash field]
+ set len3 [r hstrlen bighash field]
+ assert {$len1 == $len2}
+ assert {$len2 == $len3}
+ }
+ }
+
+ test {Hash ziplist regression test for large keys} {
+ r hset hash kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk a
+ r hset hash kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk b
+ r hget hash kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk
+ } {b}
+
+ foreach size {10 512} {
+ test "Hash fuzzing #1 - $size fields" {
+ for {set times 0} {$times < 10} {incr times} {
+ catch {unset hash}
+ array set hash {}
+ r del hash
+
+ # Create
+ for {set j 0} {$j < $size} {incr j} {
+ set field [randomValue]
+ set value [randomValue]
+ r hset hash $field $value
+ set hash($field) $value
+ }
+
+ # Verify
+ foreach {k v} [array get hash] {
+ assert_equal $v [r hget hash $k]
+ }
+ assert_equal [array size hash] [r hlen hash]
+ }
+ }
+
+ test "Hash fuzzing #2 - $size fields" {
+ for {set times 0} {$times < 10} {incr times} {
+ catch {unset hash}
+ array set hash {}
+ r del hash
+
+ # Create
+ for {set j 0} {$j < $size} {incr j} {
+ randpath {
+ set field [randomValue]
+ set value [randomValue]
+ r hset hash $field $value
+ set hash($field) $value
+ } {
+ set field [randomSignedInt 512]
+ set value [randomSignedInt 512]
+ r hset hash $field $value
+ set hash($field) $value
+ } {
+ randpath {
+ set field [randomValue]
+ } {
+ set field [randomSignedInt 512]
+ }
+ r hdel hash $field
+ unset -nocomplain hash($field)
+ }
+ }
+
+ # Verify
+ foreach {k v} [array get hash] {
+ assert_equal $v [r hget hash $k]
+ }
+ assert_equal [array size hash] [r hlen hash]
+ }
+ }
+ }
+
+ test {Stress test the hash ziplist -> hashtable encoding conversion} {
+ r config set hash-max-ziplist-entries 32
+ for {set j 0} {$j < 100} {incr j} {
+ r del myhash
+ for {set i 0} {$i < 64} {incr i} {
+ r hset myhash [randomValue] [randomValue]
+ }
+ assert {[r object encoding myhash] eq {hashtable}}
+ }
+ }
+
+ # The following test can only be executed if we don't use Valgrind, and if
+ # we are using x86_64 architecture, because:
+ #
+ # 1) Valgrind has floating point limitations, no support for 80 bits math.
+ # 2) Other archs may have the same limits.
+ #
+ # 1.23 cannot be represented correctly with 64 bit doubles, so we skip
+ # the test, since we are only testing pretty printing here and is not
+ # a bug if the program outputs things like 1.299999...
+ if {!$::valgrind && [string match *x86_64* [exec uname -a]]} {
+ test {Test HINCRBYFLOAT for correct float representation (issue #2846)} {
+ r del myhash
+ assert {[r hincrbyfloat myhash float 1.23] eq {1.23}}
+ assert {[r hincrbyfloat myhash float 0.77] eq {2}}
+ assert {[r hincrbyfloat myhash float -0.1] eq {1.9}}
+ }
+ }
+}
diff --git a/tests/unit/type/incr.tcl b/tests/unit/type/incr.tcl
new file mode 100644
index 0000000..2287aaa
--- /dev/null
+++ b/tests/unit/type/incr.tcl
@@ -0,0 +1,147 @@
+start_server {tags {"incr"}} {
+ test {INCR against non existing key} {
+ set res {}
+ append res [r incr novar]
+ append res [r get novar]
+ } {11}
+
+ test {INCR against key created by incr itself} {
+ r incr novar
+ } {2}
+
+ test {INCR against key originally set with SET} {
+ r set novar 100
+ r incr novar
+ } {101}
+
+ test {INCR over 32bit value} {
+ r set novar 17179869184
+ r incr novar
+ } {17179869185}
+
+ test {INCRBY over 32bit value with over 32bit increment} {
+ r set novar 17179869184
+ r incrby novar 17179869184
+ } {34359738368}
+
+ test {INCR fails against key with spaces (left)} {
+ r set novar " 11"
+ catch {r incr novar} err
+ format $err
+ } {ERR*}
+
+ test {INCR fails against key with spaces (right)} {
+ r set novar "11 "
+ catch {r incr novar} err
+ format $err
+ } {ERR*}
+
+ test {INCR fails against key with spaces (both)} {
+ r set novar " 11 "
+ catch {r incr novar} err
+ format $err
+ } {ERR*}
+
+ test {INCR fails against a key holding a list} {
+ r rpush mylist 1
+ catch {r incr mylist} err
+ r rpop mylist
+ format $err
+ } {WRONGTYPE*}
+
+ test {DECRBY over 32bit value with over 32bit increment, negative res} {
+ r set novar 17179869184
+ r decrby novar 17179869185
+ } {-1}
+
+ test {INCR uses shared objects in the 0-9999 range} {
+ r set foo -1
+ r incr foo
+ assert {[r object refcount foo] > 1}
+ r set foo 9998
+ r incr foo
+ assert {[r object refcount foo] > 1}
+ r incr foo
+ assert {[r object refcount foo] == 1}
+ }
+
+ test {INCR can modify objects in-place} {
+ r set foo 20000
+ r incr foo
+ assert {[r object refcount foo] == 1}
+ set old [lindex [split [r debug object foo]] 1]
+ r incr foo
+ set new [lindex [split [r debug object foo]] 1]
+ assert {[string range $old 0 2] eq "at:"}
+ assert {[string range $new 0 2] eq "at:"}
+ assert {$old eq $new}
+ }
+
+ test {INCRBYFLOAT against non existing key} {
+ r del novar
+ list [roundFloat [r incrbyfloat novar 1]] \
+ [roundFloat [r get novar]] \
+ [roundFloat [r incrbyfloat novar 0.25]] \
+ [roundFloat [r get novar]]
+ } {1 1 1.25 1.25}
+
+ test {INCRBYFLOAT against key originally set with SET} {
+ r set novar 1.5
+ roundFloat [r incrbyfloat novar 1.5]
+ } {3}
+
+ test {INCRBYFLOAT over 32bit value} {
+ r set novar 17179869184
+ r incrbyfloat novar 1.5
+ } {17179869185.5}
+
+ test {INCRBYFLOAT over 32bit value with over 32bit increment} {
+ r set novar 17179869184
+ r incrbyfloat novar 17179869184
+ } {34359738368}
+
+ test {INCRBYFLOAT fails against key with spaces (left)} {
+ set err {}
+ r set novar " 11"
+ catch {r incrbyfloat novar 1.0} err
+ format $err
+ } {ERR*valid*}
+
+ test {INCRBYFLOAT fails against key with spaces (right)} {
+ set err {}
+ r set novar "11 "
+ catch {r incrbyfloat novar 1.0} err
+ format $err
+ } {ERR*valid*}
+
+ test {INCRBYFLOAT fails against key with spaces (both)} {
+ set err {}
+ r set novar " 11 "
+ catch {r incrbyfloat novar 1.0} err
+ format $err
+ } {ERR*valid*}
+
+ test {INCRBYFLOAT fails against a key holding a list} {
+ r del mylist
+ set err {}
+ r rpush mylist 1
+ catch {r incrbyfloat mylist 1.0} err
+ r del mylist
+ format $err
+ } {WRONGTYPE*}
+
+ test {INCRBYFLOAT does not allow NaN or Infinity} {
+ r set foo 0
+ set err {}
+ catch {r incrbyfloat foo +inf} err
+ set err
+ # p.s. no way I can force NaN to test it from the API because
+ # there is no way to increment / decrement by infinity nor to
+ # perform divisions.
+ } {ERR*would produce*}
+
+ test {INCRBYFLOAT decrement} {
+ r set foo 1
+ roundFloat [r incrbyfloat foo -1.1]
+ } {-0.1}
+}
diff --git a/tests/unit/type/list-2.tcl b/tests/unit/type/list-2.tcl
new file mode 100644
index 0000000..4c7d6d9
--- /dev/null
+++ b/tests/unit/type/list-2.tcl
@@ -0,0 +1,47 @@
+start_server {
+ tags {"list"}
+ overrides {
+ "list-max-ziplist-size" 4
+ }
+} {
+ source "tests/unit/type/list-common.tcl"
+
+ foreach {type large} [array get largevalue] {
+ tags {"slow"} {
+ test "LTRIM stress testing - $type" {
+ set mylist {}
+ set startlen 32
+ r del mylist
+
+ # Start with the large value to ensure the
+ # right encoding is used.
+ r rpush mylist $large
+ lappend mylist $large
+
+ for {set i 0} {$i < $startlen} {incr i} {
+ set str [randomInt 9223372036854775807]
+ r rpush mylist $str
+ lappend mylist $str
+ }
+
+ for {set i 0} {$i < 1000} {incr i} {
+ set min [expr {int(rand()*$startlen)}]
+ set max [expr {$min+int(rand()*$startlen)}]
+ set before_len [llength $mylist]
+ set before_len_r [r llen mylist]
+ set mylist [lrange $mylist $min $max]
+ r ltrim mylist $min $max
+ assert_equal $mylist [r lrange mylist 0 -1] "failed trim"
+
+ set starting [r llen mylist]
+ for {set j [r llen mylist]} {$j < $startlen} {incr j} {
+ set str [randomInt 9223372036854775807]
+ r rpush mylist $str
+ lappend mylist $str
+ assert_equal $mylist [r lrange mylist 0 -1] "failed append match"
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/tests/unit/type/list-3.tcl b/tests/unit/type/list-3.tcl
new file mode 100644
index 0000000..b5bd48c
--- /dev/null
+++ b/tests/unit/type/list-3.tcl
@@ -0,0 +1,122 @@
+start_server {
+ tags {list ziplist}
+ overrides {
+ "list-max-ziplist-size" 16
+ }
+} {
+ test {Explicit regression for a list bug} {
+ set mylist {49376042582 {BkG2o\pIC]4YYJa9cJ4GWZalG[4tin;1D2whSkCOW`mX;SFXGyS8sedcff3fQI^tgPCC@^Nu1J6o]meM@Lko]t_jRyo<xSJ1oObDYd`ppZuW6P@fS278YaOx=s6lvdFlMbP0[SbkI^Kr\HBXtuFaA^mDx:yzS4a[skiiPWhT<nNfAf=aQVfclcuwDrfe;iVuKdNvB9kbfq>tK?tH[\EvWqS]b`o2OCtjg:?nUTwdjpcUm]y:pg5q24q7LlCOwQE^}}
+ r del l
+ r rpush l [lindex $mylist 0]
+ r rpush l [lindex $mylist 1]
+ assert_equal [r lindex l 0] [lindex $mylist 0]
+ assert_equal [r lindex l 1] [lindex $mylist 1]
+ }
+
+ test {Regression for quicklist #3343 bug} {
+ r del mylist
+ r lpush mylist 401
+ r lpush mylist 392
+ r rpush mylist [string repeat x 5105]"799"
+ r lset mylist -1 [string repeat x 1014]"702"
+ r lpop mylist
+ r lset mylist -1 [string repeat x 4149]"852"
+ r linsert mylist before 401 [string repeat x 9927]"12"
+ r lrange mylist 0 -1
+ r ping ; # It's enough if the server is still alive
+ } {PONG}
+
+ test {Stress tester for #3343-alike bugs} {
+ r del key
+ for {set j 0} {$j < 10000} {incr j} {
+ set op [randomInt 6]
+ set small_signed_count [expr 5-[randomInt 10]]
+ if {[randomInt 2] == 0} {
+ set ele [randomInt 1000]
+ } else {
+ set ele [string repeat x [randomInt 10000]][randomInt 1000]
+ }
+ switch $op {
+ 0 {r lpush key $ele}
+ 1 {r rpush key $ele}
+ 2 {r lpop key}
+ 3 {r rpop key}
+ 4 {
+ catch {r lset key $small_signed_count $ele}
+ }
+ 5 {
+ set otherele [randomInt 1000]
+ if {[randomInt 2] == 0} {
+ set where before
+ } else {
+ set where after
+ }
+ r linsert key $where $otherele $ele
+ }
+ }
+ }
+ }
+
+ tags {slow} {
+ test {ziplist implementation: value encoding and backlink} {
+ if {$::accurate} {set iterations 100} else {set iterations 10}
+ for {set j 0} {$j < $iterations} {incr j} {
+ r del l
+ set l {}
+ for {set i 0} {$i < 200} {incr i} {
+ randpath {
+ set data [string repeat x [randomInt 100000]]
+ } {
+ set data [randomInt 65536]
+ } {
+ set data [randomInt 4294967296]
+ } {
+ set data [randomInt 18446744073709551616]
+ } {
+ set data -[randomInt 65536]
+ if {$data eq {-0}} {set data 0}
+ } {
+ set data -[randomInt 4294967296]
+ if {$data eq {-0}} {set data 0}
+ } {
+ set data -[randomInt 18446744073709551616]
+ if {$data eq {-0}} {set data 0}
+ }
+ lappend l $data
+ r rpush l $data
+ }
+ assert_equal [llength $l] [r llen l]
+ # Traverse backward
+ for {set i 199} {$i >= 0} {incr i -1} {
+ if {[lindex $l $i] ne [r lindex l $i]} {
+ assert_equal [lindex $l $i] [r lindex l $i]
+ }
+ }
+ }
+ }
+
+ test {ziplist implementation: encoding stress testing} {
+ for {set j 0} {$j < 200} {incr j} {
+ r del l
+ set l {}
+ set len [randomInt 400]
+ for {set i 0} {$i < $len} {incr i} {
+ set rv [randomValue]
+ randpath {
+ lappend l $rv
+ r rpush l $rv
+ } {
+ set l [concat [list $rv] $l]
+ r lpush l $rv
+ }
+ }
+ assert_equal [llength $l] [r llen l]
+ for {set i 0} {$i < $len} {incr i} {
+ if {[lindex $l $i] ne [r lindex l $i]} {
+ assert_equal [lindex $l $i] [r lindex l $i]
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/tests/unit/type/list-common.tcl b/tests/unit/type/list-common.tcl
new file mode 100644
index 0000000..ab45f0b
--- /dev/null
+++ b/tests/unit/type/list-common.tcl
@@ -0,0 +1,5 @@
+# We need a value larger than list-max-ziplist-value to make sure
+# the list has the right encoding when it is swapped in again.
+array set largevalue {}
+set largevalue(ziplist) "hello"
+set largevalue(linkedlist) [string repeat "hello" 4]
diff --git a/tests/unit/type/list.tcl b/tests/unit/type/list.tcl
new file mode 100644
index 0000000..1557082
--- /dev/null
+++ b/tests/unit/type/list.tcl
@@ -0,0 +1,837 @@
+start_server {
+ tags {"list"}
+ overrides {
+ "list-max-ziplist-size" 5
+ }
+} {
+ source "tests/unit/type/list-common.tcl"
+
+ test {LPUSH, RPUSH, LLENGTH, LINDEX, LPOP - ziplist} {
+ # first lpush then rpush
+ assert_equal 1 [r lpush myziplist1 aa]
+ assert_equal 2 [r rpush myziplist1 bb]
+ assert_equal 3 [r rpush myziplist1 cc]
+ assert_equal 3 [r llen myziplist1]
+ assert_equal aa [r lindex myziplist1 0]
+ assert_equal bb [r lindex myziplist1 1]
+ assert_equal cc [r lindex myziplist1 2]
+ assert_equal {} [r lindex myziplist2 3]
+ assert_equal cc [r rpop myziplist1]
+ assert_equal aa [r lpop myziplist1]
+ assert_encoding quicklist myziplist1
+
+ # first rpush then lpush
+ assert_equal 1 [r rpush myziplist2 a]
+ assert_equal 2 [r lpush myziplist2 b]
+ assert_equal 3 [r lpush myziplist2 c]
+ assert_equal 3 [r llen myziplist2]
+ assert_equal c [r lindex myziplist2 0]
+ assert_equal b [r lindex myziplist2 1]
+ assert_equal a [r lindex myziplist2 2]
+ assert_equal {} [r lindex myziplist2 3]
+ assert_equal a [r rpop myziplist2]
+ assert_equal c [r lpop myziplist2]
+ assert_encoding quicklist myziplist2
+ }
+
+ test {LPUSH, RPUSH, LLENGTH, LINDEX, LPOP - regular list} {
+ # first lpush then rpush
+ assert_equal 1 [r lpush mylist1 $largevalue(linkedlist)]
+ assert_encoding quicklist mylist1
+ assert_equal 2 [r rpush mylist1 b]
+ assert_equal 3 [r rpush mylist1 c]
+ assert_equal 3 [r llen mylist1]
+ assert_equal $largevalue(linkedlist) [r lindex mylist1 0]
+ assert_equal b [r lindex mylist1 1]
+ assert_equal c [r lindex mylist1 2]
+ assert_equal {} [r lindex mylist1 3]
+ assert_equal c [r rpop mylist1]
+ assert_equal $largevalue(linkedlist) [r lpop mylist1]
+
+ # first rpush then lpush
+ assert_equal 1 [r rpush mylist2 $largevalue(linkedlist)]
+ assert_encoding quicklist mylist2
+ assert_equal 2 [r lpush mylist2 b]
+ assert_equal 3 [r lpush mylist2 c]
+ assert_equal 3 [r llen mylist2]
+ assert_equal c [r lindex mylist2 0]
+ assert_equal b [r lindex mylist2 1]
+ assert_equal $largevalue(linkedlist) [r lindex mylist2 2]
+ assert_equal {} [r lindex mylist2 3]
+ assert_equal $largevalue(linkedlist) [r rpop mylist2]
+ assert_equal c [r lpop mylist2]
+ }
+
+ test {R/LPOP against empty list} {
+ r lpop non-existing-list
+ } {}
+
+ test {Variadic RPUSH/LPUSH} {
+ r del mylist
+ assert_equal 4 [r lpush mylist a b c d]
+ assert_equal 8 [r rpush mylist 0 1 2 3]
+ assert_equal {d c b a 0 1 2 3} [r lrange mylist 0 -1]
+ }
+
+ test {DEL a list} {
+ assert_equal 1 [r del mylist2]
+ assert_equal 0 [r exists mylist2]
+ assert_equal 0 [r llen mylist2]
+ }
+
+ proc create_list {key entries} {
+ r del $key
+ foreach entry $entries { r rpush $key $entry }
+ assert_encoding quicklist $key
+ }
+
+ foreach {type large} [array get largevalue] {
+ test "BLPOP, BRPOP: single existing list - $type" {
+ set rd [redis_deferring_client]
+ create_list blist "a b $large c d"
+
+ $rd blpop blist 1
+ assert_equal {blist a} [$rd read]
+ $rd brpop blist 1
+ assert_equal {blist d} [$rd read]
+
+ $rd blpop blist 1
+ assert_equal {blist b} [$rd read]
+ $rd brpop blist 1
+ assert_equal {blist c} [$rd read]
+ }
+
+ test "BLPOP, BRPOP: multiple existing lists - $type" {
+ set rd [redis_deferring_client]
+ create_list blist1 "a $large c"
+ create_list blist2 "d $large f"
+
+ $rd blpop blist1 blist2 1
+ assert_equal {blist1 a} [$rd read]
+ $rd brpop blist1 blist2 1
+ assert_equal {blist1 c} [$rd read]
+ assert_equal 1 [r llen blist1]
+ assert_equal 3 [r llen blist2]
+
+ $rd blpop blist2 blist1 1
+ assert_equal {blist2 d} [$rd read]
+ $rd brpop blist2 blist1 1
+ assert_equal {blist2 f} [$rd read]
+ assert_equal 1 [r llen blist1]
+ assert_equal 1 [r llen blist2]
+ }
+
+ test "BLPOP, BRPOP: second list has an entry - $type" {
+ set rd [redis_deferring_client]
+ r del blist1
+ create_list blist2 "d $large f"
+
+ $rd blpop blist1 blist2 1
+ assert_equal {blist2 d} [$rd read]
+ $rd brpop blist1 blist2 1
+ assert_equal {blist2 f} [$rd read]
+ assert_equal 0 [r llen blist1]
+ assert_equal 1 [r llen blist2]
+ }
+
+ test "BRPOPLPUSH - $type" {
+ r del target
+
+ set rd [redis_deferring_client]
+ create_list blist "a b $large c d"
+
+ $rd brpoplpush blist target 1
+ assert_equal d [$rd read]
+
+ assert_equal d [r rpop target]
+ assert_equal "a b $large c" [r lrange blist 0 -1]
+ }
+ }
+
+ test "BLPOP, LPUSH + DEL should not awake blocked client" {
+ set rd [redis_deferring_client]
+ r del list
+
+ $rd blpop list 0
+ r multi
+ r lpush list a
+ r del list
+ r exec
+ r del list
+ r lpush list b
+ $rd read
+ } {list b}
+
+ test "BLPOP, LPUSH + DEL + SET should not awake blocked client" {
+ set rd [redis_deferring_client]
+ r del list
+
+ $rd blpop list 0
+ r multi
+ r lpush list a
+ r del list
+ r set list foo
+ r exec
+ r del list
+ r lpush list b
+ $rd read
+ } {list b}
+
+ test "BLPOP with same key multiple times should work (issue #801)" {
+ set rd [redis_deferring_client]
+ r del list1 list2
+
+ # Data arriving after the BLPOP.
+ $rd blpop list1 list2 list2 list1 0
+ r lpush list1 a
+ assert_equal [$rd read] {list1 a}
+ $rd blpop list1 list2 list2 list1 0
+ r lpush list2 b
+ assert_equal [$rd read] {list2 b}
+
+ # Data already there.
+ r lpush list1 a
+ r lpush list2 b
+ $rd blpop list1 list2 list2 list1 0
+ assert_equal [$rd read] {list1 a}
+ $rd blpop list1 list2 list2 list1 0
+ assert_equal [$rd read] {list2 b}
+ }
+
+ test "MULTI/EXEC is isolated from the point of view of BLPOP" {
+ set rd [redis_deferring_client]
+ r del list
+ $rd blpop list 0
+ r multi
+ r lpush list a
+ r lpush list b
+ r lpush list c
+ r exec
+ $rd read
+ } {list c}
+
+ test "BLPOP with variadic LPUSH" {
+ set rd [redis_deferring_client]
+ r del blist target
+ if {$::valgrind} {after 100}
+ $rd blpop blist 0
+ if {$::valgrind} {after 100}
+ assert_equal 2 [r lpush blist foo bar]
+ if {$::valgrind} {after 100}
+ assert_equal {blist bar} [$rd read]
+ assert_equal foo [lindex [r lrange blist 0 -1] 0]
+ }
+
+ test "BRPOPLPUSH with zero timeout should block indefinitely" {
+ set rd [redis_deferring_client]
+ r del blist target
+ $rd brpoplpush blist target 0
+ after 1000
+ r rpush blist foo
+ assert_equal foo [$rd read]
+ assert_equal {foo} [r lrange target 0 -1]
+ }
+
+ test "BRPOPLPUSH with a client BLPOPing the target list" {
+ set rd [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+ r del blist target
+ $rd2 blpop target 0
+ $rd brpoplpush blist target 0
+ after 1000
+ r rpush blist foo
+ assert_equal foo [$rd read]
+ assert_equal {target foo} [$rd2 read]
+ assert_equal 0 [r exists target]
+ }
+
+ test "BRPOPLPUSH with wrong source type" {
+ set rd [redis_deferring_client]
+ r del blist target
+ r set blist nolist
+ $rd brpoplpush blist target 1
+ assert_error "WRONGTYPE*" {$rd read}
+ }
+
+ test "BRPOPLPUSH with wrong destination type" {
+ set rd [redis_deferring_client]
+ r del blist target
+ r set target nolist
+ r lpush blist foo
+ $rd brpoplpush blist target 1
+ assert_error "WRONGTYPE*" {$rd read}
+
+ set rd [redis_deferring_client]
+ r del blist target
+ r set target nolist
+ $rd brpoplpush blist target 0
+ after 1000
+ r rpush blist foo
+ assert_error "WRONGTYPE*" {$rd read}
+ assert_equal {foo} [r lrange blist 0 -1]
+ }
+
+ test "BRPOPLPUSH maintains order of elements after failure" {
+ set rd [redis_deferring_client]
+ r del blist target
+ r set target nolist
+ $rd brpoplpush blist target 0
+ r rpush blist a b c
+ assert_error "WRONGTYPE*" {$rd read}
+ r lrange blist 0 -1
+ } {a b c}
+
+ test "BRPOPLPUSH with multiple blocked clients" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+ r del blist target1 target2
+ r set target1 nolist
+ $rd1 brpoplpush blist target1 0
+ $rd2 brpoplpush blist target2 0
+ r lpush blist foo
+
+ assert_error "WRONGTYPE*" {$rd1 read}
+ assert_equal {foo} [$rd2 read]
+ assert_equal {foo} [r lrange target2 0 -1]
+ }
+
+ test "Linked BRPOPLPUSH" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+
+ r del list1 list2 list3
+
+ $rd1 brpoplpush list1 list2 0
+ $rd2 brpoplpush list2 list3 0
+
+ r rpush list1 foo
+
+ assert_equal {} [r lrange list1 0 -1]
+ assert_equal {} [r lrange list2 0 -1]
+ assert_equal {foo} [r lrange list3 0 -1]
+ }
+
+ test "Circular BRPOPLPUSH" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+
+ r del list1 list2
+
+ $rd1 brpoplpush list1 list2 0
+ $rd2 brpoplpush list2 list1 0
+
+ r rpush list1 foo
+
+ assert_equal {foo} [r lrange list1 0 -1]
+ assert_equal {} [r lrange list2 0 -1]
+ }
+
+ test "Self-referential BRPOPLPUSH" {
+ set rd [redis_deferring_client]
+
+ r del blist
+
+ $rd brpoplpush blist blist 0
+
+ r rpush blist foo
+
+ assert_equal {foo} [r lrange blist 0 -1]
+ }
+
+ test "BRPOPLPUSH inside a transaction" {
+ r del xlist target
+ r lpush xlist foo
+ r lpush xlist bar
+
+ r multi
+ r brpoplpush xlist target 0
+ r brpoplpush xlist target 0
+ r brpoplpush xlist target 0
+ r lrange xlist 0 -1
+ r lrange target 0 -1
+ r exec
+ } {foo bar {} {} {bar foo}}
+
+ test "PUSH resulting from BRPOPLPUSH affect WATCH" {
+ set blocked_client [redis_deferring_client]
+ set watching_client [redis_deferring_client]
+ r del srclist dstlist somekey
+ r set somekey somevalue
+ $blocked_client brpoplpush srclist dstlist 0
+ $watching_client watch dstlist
+ $watching_client read
+ $watching_client multi
+ $watching_client read
+ $watching_client get somekey
+ $watching_client read
+ r lpush srclist element
+ $watching_client exec
+ $watching_client read
+ } {}
+
+ test "BRPOPLPUSH does not affect WATCH while still blocked" {
+ set blocked_client [redis_deferring_client]
+ set watching_client [redis_deferring_client]
+ r del srclist dstlist somekey
+ r set somekey somevalue
+ $blocked_client brpoplpush srclist dstlist 0
+ $watching_client watch dstlist
+ $watching_client read
+ $watching_client multi
+ $watching_client read
+ $watching_client get somekey
+ $watching_client read
+ $watching_client exec
+ # Blocked BLPOPLPUSH may create problems, unblock it.
+ r lpush srclist element
+ $watching_client read
+ } {somevalue}
+
+ test {BRPOPLPUSH timeout} {
+ set rd [redis_deferring_client]
+
+ $rd brpoplpush foo_list bar_list 1
+ after 2000
+ $rd read
+ } {}
+
+ test "BLPOP when new key is moved into place" {
+ set rd [redis_deferring_client]
+
+ $rd blpop foo 5
+ r lpush bob abc def hij
+ r rename bob foo
+ $rd read
+ } {foo hij}
+
+ test "BLPOP when result key is created by SORT..STORE" {
+ set rd [redis_deferring_client]
+
+ # zero out list from previous test without explicit delete
+ r lpop foo
+ r lpop foo
+ r lpop foo
+
+ $rd blpop foo 5
+ r lpush notfoo hello hola aguacate konichiwa zanzibar
+ r sort notfoo ALPHA store foo
+ $rd read
+ } {foo aguacate}
+
+ foreach {pop} {BLPOP BRPOP} {
+ test "$pop: with single empty list argument" {
+ set rd [redis_deferring_client]
+ r del blist1
+ $rd $pop blist1 1
+ r rpush blist1 foo
+ assert_equal {blist1 foo} [$rd read]
+ assert_equal 0 [r exists blist1]
+ }
+
+ test "$pop: with negative timeout" {
+ set rd [redis_deferring_client]
+ $rd $pop blist1 -1
+ assert_error "ERR*is negative*" {$rd read}
+ }
+
+ test "$pop: with non-integer timeout" {
+ set rd [redis_deferring_client]
+ $rd $pop blist1 1.1
+ assert_error "ERR*not an integer*" {$rd read}
+ }
+
+ test "$pop: with zero timeout should block indefinitely" {
+ # To test this, use a timeout of 0 and wait a second.
+ # The blocking pop should still be waiting for a push.
+ set rd [redis_deferring_client]
+ $rd $pop blist1 0
+ after 1000
+ r rpush blist1 foo
+ assert_equal {blist1 foo} [$rd read]
+ }
+
+ test "$pop: second argument is not a list" {
+ set rd [redis_deferring_client]
+ r del blist1 blist2
+ r set blist2 nolist
+ $rd $pop blist1 blist2 1
+ assert_error "WRONGTYPE*" {$rd read}
+ }
+
+ test "$pop: timeout" {
+ set rd [redis_deferring_client]
+ r del blist1 blist2
+ $rd $pop blist1 blist2 1
+ assert_equal {} [$rd read]
+ }
+
+ test "$pop: arguments are empty" {
+ set rd [redis_deferring_client]
+ r del blist1 blist2
+
+ $rd $pop blist1 blist2 1
+ r rpush blist1 foo
+ assert_equal {blist1 foo} [$rd read]
+ assert_equal 0 [r exists blist1]
+ assert_equal 0 [r exists blist2]
+
+ $rd $pop blist1 blist2 1
+ r rpush blist2 foo
+ assert_equal {blist2 foo} [$rd read]
+ assert_equal 0 [r exists blist1]
+ assert_equal 0 [r exists blist2]
+ }
+ }
+
+ test {BLPOP inside a transaction} {
+ r del xlist
+ r lpush xlist foo
+ r lpush xlist bar
+ r multi
+ r blpop xlist 0
+ r blpop xlist 0
+ r blpop xlist 0
+ r exec
+ } {{xlist bar} {xlist foo} {}}
+
+ test {LPUSHX, RPUSHX - generic} {
+ r del xlist
+ assert_equal 0 [r lpushx xlist a]
+ assert_equal 0 [r llen xlist]
+ assert_equal 0 [r rpushx xlist a]
+ assert_equal 0 [r llen xlist]
+ }
+
+ foreach {type large} [array get largevalue] {
+ test "LPUSHX, RPUSHX - $type" {
+ create_list xlist "$large c"
+ assert_equal 3 [r rpushx xlist d]
+ assert_equal 4 [r lpushx xlist a]
+ assert_equal 6 [r rpushx xlist 42 x]
+ assert_equal 9 [r lpushx xlist y3 y2 y1]
+ assert_equal "y1 y2 y3 a $large c d 42 x" [r lrange xlist 0 -1]
+ }
+
+ test "LINSERT - $type" {
+ create_list xlist "a $large c d"
+ assert_equal 5 [r linsert xlist before c zz] "before c"
+ assert_equal "a $large zz c d" [r lrange xlist 0 10] "lrangeA"
+ assert_equal 6 [r linsert xlist after c yy] "after c"
+ assert_equal "a $large zz c yy d" [r lrange xlist 0 10] "lrangeB"
+ assert_equal 7 [r linsert xlist after d dd] "after d"
+ assert_equal -1 [r linsert xlist after bad ddd] "after bad"
+ assert_equal "a $large zz c yy d dd" [r lrange xlist 0 10] "lrangeC"
+ assert_equal 8 [r linsert xlist before a aa] "before a"
+ assert_equal -1 [r linsert xlist before bad aaa] "before bad"
+ assert_equal "aa a $large zz c yy d dd" [r lrange xlist 0 10] "lrangeD"
+
+ # check inserting integer encoded value
+ assert_equal 9 [r linsert xlist before aa 42] "before aa"
+ assert_equal 42 [r lrange xlist 0 0] "lrangeE"
+ }
+ }
+
+ test {LINSERT raise error on bad syntax} {
+ catch {[r linsert xlist aft3r aa 42]} e
+ set e
+ } {*ERR*syntax*error*}
+
+ foreach {type num} {quicklist 250 quicklist 500} {
+ proc check_numbered_list_consistency {key} {
+ set len [r llen $key]
+ for {set i 0} {$i < $len} {incr i} {
+ assert_equal $i [r lindex $key $i]
+ assert_equal [expr $len-1-$i] [r lindex $key [expr (-$i)-1]]
+ }
+ }
+
+ proc check_random_access_consistency {key} {
+ set len [r llen $key]
+ for {set i 0} {$i < $len} {incr i} {
+ set rint [expr int(rand()*$len)]
+ assert_equal $rint [r lindex $key $rint]
+ assert_equal [expr $len-1-$rint] [r lindex $key [expr (-$rint)-1]]
+ }
+ }
+
+ test "LINDEX consistency test - $type" {
+ r del mylist
+ for {set i 0} {$i < $num} {incr i} {
+ r rpush mylist $i
+ }
+ assert_encoding $type mylist
+ check_numbered_list_consistency mylist
+ }
+
+ test "LINDEX random access - $type" {
+ assert_encoding $type mylist
+ check_random_access_consistency mylist
+ }
+
+ test "Check if list is still ok after a DEBUG RELOAD - $type" {
+ r debug reload
+ assert_encoding $type mylist
+ check_numbered_list_consistency mylist
+ check_random_access_consistency mylist
+ }
+ }
+
+ test {LLEN against non-list value error} {
+ r del mylist
+ r set mylist foobar
+ assert_error WRONGTYPE* {r llen mylist}
+ }
+
+ test {LLEN against non existing key} {
+ assert_equal 0 [r llen not-a-key]
+ }
+
+ test {LINDEX against non-list value error} {
+ assert_error WRONGTYPE* {r lindex mylist 0}
+ }
+
+ test {LINDEX against non existing key} {
+ assert_equal "" [r lindex not-a-key 10]
+ }
+
+ test {LPUSH against non-list value error} {
+ assert_error WRONGTYPE* {r lpush mylist 0}
+ }
+
+ test {RPUSH against non-list value error} {
+ assert_error WRONGTYPE* {r rpush mylist 0}
+ }
+
+ foreach {type large} [array get largevalue] {
+ test "RPOPLPUSH base case - $type" {
+ r del mylist1 mylist2
+ create_list mylist1 "a $large c d"
+ assert_equal d [r rpoplpush mylist1 mylist2]
+ assert_equal c [r rpoplpush mylist1 mylist2]
+ assert_equal "a $large" [r lrange mylist1 0 -1]
+ assert_equal "c d" [r lrange mylist2 0 -1]
+ assert_encoding quicklist mylist2
+ }
+
+ test "RPOPLPUSH with the same list as src and dst - $type" {
+ create_list mylist "a $large c"
+ assert_equal "a $large c" [r lrange mylist 0 -1]
+ assert_equal c [r rpoplpush mylist mylist]
+ assert_equal "c a $large" [r lrange mylist 0 -1]
+ }
+
+ foreach {othertype otherlarge} [array get largevalue] {
+ test "RPOPLPUSH with $type source and existing target $othertype" {
+ create_list srclist "a b c $large"
+ create_list dstlist "$otherlarge"
+ assert_equal $large [r rpoplpush srclist dstlist]
+ assert_equal c [r rpoplpush srclist dstlist]
+ assert_equal "a b" [r lrange srclist 0 -1]
+ assert_equal "c $large $otherlarge" [r lrange dstlist 0 -1]
+
+ # When we rpoplpush'ed a large value, dstlist should be
+ # converted to the same encoding as srclist.
+ if {$type eq "linkedlist"} {
+ assert_encoding quicklist dstlist
+ }
+ }
+ }
+ }
+
+ test {RPOPLPUSH against non existing key} {
+ r del srclist dstlist
+ assert_equal {} [r rpoplpush srclist dstlist]
+ assert_equal 0 [r exists srclist]
+ assert_equal 0 [r exists dstlist]
+ }
+
+ test {RPOPLPUSH against non list src key} {
+ r del srclist dstlist
+ r set srclist x
+ assert_error WRONGTYPE* {r rpoplpush srclist dstlist}
+ assert_type string srclist
+ assert_equal 0 [r exists newlist]
+ }
+
+ test {RPOPLPUSH against non list dst key} {
+ create_list srclist {a b c d}
+ r set dstlist x
+ assert_error WRONGTYPE* {r rpoplpush srclist dstlist}
+ assert_type string dstlist
+ assert_equal {a b c d} [r lrange srclist 0 -1]
+ }
+
+ test {RPOPLPUSH against non existing src key} {
+ r del srclist dstlist
+ assert_equal {} [r rpoplpush srclist dstlist]
+ } {}
+
+ foreach {type large} [array get largevalue] {
+ test "Basic LPOP/RPOP - $type" {
+ create_list mylist "$large 1 2"
+ assert_equal $large [r lpop mylist]
+ assert_equal 2 [r rpop mylist]
+ assert_equal 1 [r lpop mylist]
+ assert_equal 0 [r llen mylist]
+
+ # pop on empty list
+ assert_equal {} [r lpop mylist]
+ assert_equal {} [r rpop mylist]
+ }
+ }
+
+ test {LPOP/RPOP against non list value} {
+ r set notalist foo
+ assert_error WRONGTYPE* {r lpop notalist}
+ assert_error WRONGTYPE* {r rpop notalist}
+ }
+
+ foreach {type num} {quicklist 250 quicklist 500} {
+ test "Mass RPOP/LPOP - $type" {
+ r del mylist
+ set sum1 0
+ for {set i 0} {$i < $num} {incr i} {
+ r lpush mylist $i
+ incr sum1 $i
+ }
+ assert_encoding $type mylist
+ set sum2 0
+ for {set i 0} {$i < [expr $num/2]} {incr i} {
+ incr sum2 [r lpop mylist]
+ incr sum2 [r rpop mylist]
+ }
+ assert_equal $sum1 $sum2
+ }
+ }
+
+ foreach {type large} [array get largevalue] {
+ test "LRANGE basics - $type" {
+ create_list mylist "$large 1 2 3 4 5 6 7 8 9"
+ assert_equal {1 2 3 4 5 6 7 8} [r lrange mylist 1 -2]
+ assert_equal {7 8 9} [r lrange mylist -3 -1]
+ assert_equal {4} [r lrange mylist 4 4]
+ }
+
+ test "LRANGE inverted indexes - $type" {
+ create_list mylist "$large 1 2 3 4 5 6 7 8 9"
+ assert_equal {} [r lrange mylist 6 2]
+ }
+
+ test "LRANGE out of range indexes including the full list - $type" {
+ create_list mylist "$large 1 2 3"
+ assert_equal "$large 1 2 3" [r lrange mylist -1000 1000]
+ }
+
+ test "LRANGE out of range negative end index - $type" {
+ create_list mylist "$large 1 2 3"
+ assert_equal $large [r lrange mylist 0 -4]
+ assert_equal {} [r lrange mylist 0 -5]
+ }
+ }
+
+ test {LRANGE against non existing key} {
+ assert_equal {} [r lrange nosuchkey 0 1]
+ }
+
+ foreach {type large} [array get largevalue] {
+ proc trim_list {type min max} {
+ upvar 1 large large
+ r del mylist
+ create_list mylist "1 2 3 4 $large"
+ r ltrim mylist $min $max
+ r lrange mylist 0 -1
+ }
+
+ test "LTRIM basics - $type" {
+ assert_equal "1" [trim_list $type 0 0]
+ assert_equal "1 2" [trim_list $type 0 1]
+ assert_equal "1 2 3" [trim_list $type 0 2]
+ assert_equal "2 3" [trim_list $type 1 2]
+ assert_equal "2 3 4 $large" [trim_list $type 1 -1]
+ assert_equal "2 3 4" [trim_list $type 1 -2]
+ assert_equal "4 $large" [trim_list $type -2 -1]
+ assert_equal "$large" [trim_list $type -1 -1]
+ assert_equal "1 2 3 4 $large" [trim_list $type -5 -1]
+ assert_equal "1 2 3 4 $large" [trim_list $type -10 10]
+ assert_equal "1 2 3 4 $large" [trim_list $type 0 5]
+ assert_equal "1 2 3 4 $large" [trim_list $type 0 10]
+ }
+
+ test "LTRIM out of range negative end index - $type" {
+ assert_equal {1} [trim_list $type 0 -5]
+ assert_equal {} [trim_list $type 0 -6]
+ }
+
+ }
+
+ foreach {type large} [array get largevalue] {
+ test "LSET - $type" {
+ create_list mylist "99 98 $large 96 95"
+ r lset mylist 1 foo
+ r lset mylist -1 bar
+ assert_equal "99 foo $large 96 bar" [r lrange mylist 0 -1]
+ }
+
+ test "LSET out of range index - $type" {
+ assert_error ERR*range* {r lset mylist 10 foo}
+ }
+ }
+
+ test {LSET against non existing key} {
+ assert_error ERR*key* {r lset nosuchkey 10 foo}
+ }
+
+ test {LSET against non list value} {
+ r set nolist foobar
+ assert_error WRONGTYPE* {r lset nolist 0 foo}
+ }
+
+ foreach {type e} [array get largevalue] {
+ test "LREM remove all the occurrences - $type" {
+ create_list mylist "$e foo bar foobar foobared zap bar test foo"
+ assert_equal 2 [r lrem mylist 0 bar]
+ assert_equal "$e foo foobar foobared zap test foo" [r lrange mylist 0 -1]
+ }
+
+ test "LREM remove the first occurrence - $type" {
+ assert_equal 1 [r lrem mylist 1 foo]
+ assert_equal "$e foobar foobared zap test foo" [r lrange mylist 0 -1]
+ }
+
+ test "LREM remove non existing element - $type" {
+ assert_equal 0 [r lrem mylist 1 nosuchelement]
+ assert_equal "$e foobar foobared zap test foo" [r lrange mylist 0 -1]
+ }
+
+ test "LREM starting from tail with negative count - $type" {
+ create_list mylist "$e foo bar foobar foobared zap bar test foo foo"
+ assert_equal 1 [r lrem mylist -1 bar]
+ assert_equal "$e foo bar foobar foobared zap test foo foo" [r lrange mylist 0 -1]
+ }
+
+ test "LREM starting from tail with negative count (2) - $type" {
+ assert_equal 2 [r lrem mylist -2 foo]
+ assert_equal "$e foo bar foobar foobared zap test" [r lrange mylist 0 -1]
+ }
+
+ test "LREM deleting objects that may be int encoded - $type" {
+ create_list myotherlist "$e 1 2 3"
+ assert_equal 1 [r lrem myotherlist 1 2]
+ assert_equal 3 [r llen myotherlist]
+ }
+ }
+
+ test "Regression for bug 593 - chaining BRPOPLPUSH with other blocking cmds" {
+ set rd1 [redis_deferring_client]
+ set rd2 [redis_deferring_client]
+
+ $rd1 brpoplpush a b 0
+ $rd1 brpoplpush a b 0
+ $rd2 brpoplpush b c 0
+ after 1000
+ r lpush a data
+ $rd1 close
+ $rd2 close
+ r ping
+ } {PONG}
+}
diff --git a/tests/unit/type/set.tcl b/tests/unit/type/set.tcl
new file mode 100644
index 0000000..7b467f1
--- /dev/null
+++ b/tests/unit/type/set.tcl
@@ -0,0 +1,601 @@
+start_server {
+ tags {"set"}
+ overrides {
+ "set-max-intset-entries" 512
+ }
+} {
+ proc create_set {key entries} {
+ r del $key
+ foreach entry $entries { r sadd $key $entry }
+ }
+
+ test {SADD, SCARD, SISMEMBER, SMEMBERS basics - regular set} {
+ create_set myset {foo}
+ assert_encoding hashtable myset
+ assert_equal 1 [r sadd myset bar]
+ assert_equal 0 [r sadd myset bar]
+ assert_equal 2 [r scard myset]
+ assert_equal 1 [r sismember myset foo]
+ assert_equal 1 [r sismember myset bar]
+ assert_equal 0 [r sismember myset bla]
+ assert_equal {bar foo} [lsort [r smembers myset]]
+ }
+
+ test {SADD, SCARD, SISMEMBER, SMEMBERS basics - intset} {
+ create_set myset {17}
+ assert_encoding intset myset
+ assert_equal 1 [r sadd myset 16]
+ assert_equal 0 [r sadd myset 16]
+ assert_equal 2 [r scard myset]
+ assert_equal 1 [r sismember myset 16]
+ assert_equal 1 [r sismember myset 17]
+ assert_equal 0 [r sismember myset 18]
+ assert_equal {16 17} [lsort [r smembers myset]]
+ }
+
+ test {SADD against non set} {
+ r lpush mylist foo
+ assert_error WRONGTYPE* {r sadd mylist bar}
+ }
+
+ test "SADD a non-integer against an intset" {
+ create_set myset {1 2 3}
+ assert_encoding intset myset
+ assert_equal 1 [r sadd myset a]
+ assert_encoding hashtable myset
+ }
+
+ test "SADD an integer larger than 64 bits" {
+ create_set myset {213244124402402314402033402}
+ assert_encoding hashtable myset
+ assert_equal 1 [r sismember myset 213244124402402314402033402]
+ }
+
+ test "SADD overflows the maximum allowed integers in an intset" {
+ r del myset
+ for {set i 0} {$i < 512} {incr i} { r sadd myset $i }
+ assert_encoding intset myset
+ assert_equal 1 [r sadd myset 512]
+ assert_encoding hashtable myset
+ }
+
+ test {Variadic SADD} {
+ r del myset
+ assert_equal 3 [r sadd myset a b c]
+ assert_equal 2 [r sadd myset A a b c B]
+ assert_equal [lsort {A a b c B}] [lsort [r smembers myset]]
+ }
+
+ test "Set encoding after DEBUG RELOAD" {
+ r del myintset myhashset mylargeintset
+ for {set i 0} {$i < 100} {incr i} { r sadd myintset $i }
+ for {set i 0} {$i < 1280} {incr i} { r sadd mylargeintset $i }
+ for {set i 0} {$i < 256} {incr i} { r sadd myhashset [format "i%03d" $i] }
+ assert_encoding intset myintset
+ assert_encoding hashtable mylargeintset
+ assert_encoding hashtable myhashset
+
+ r debug reload
+ assert_encoding intset myintset
+ assert_encoding hashtable mylargeintset
+ assert_encoding hashtable myhashset
+ }
+
+ test {SREM basics - regular set} {
+ create_set myset {foo bar ciao}
+ assert_encoding hashtable myset
+ assert_equal 0 [r srem myset qux]
+ assert_equal 1 [r srem myset foo]
+ assert_equal {bar ciao} [lsort [r smembers myset]]
+ }
+
+ test {SREM basics - intset} {
+ create_set myset {3 4 5}
+ assert_encoding intset myset
+ assert_equal 0 [r srem myset 6]
+ assert_equal 1 [r srem myset 4]
+ assert_equal {3 5} [lsort [r smembers myset]]
+ }
+
+ test {SREM with multiple arguments} {
+ r del myset
+ r sadd myset a b c d
+ assert_equal 0 [r srem myset k k k]
+ assert_equal 2 [r srem myset b d x y]
+ lsort [r smembers myset]
+ } {a c}
+
+ test {SREM variadic version with more args needed to destroy the key} {
+ r del myset
+ r sadd myset 1 2 3
+ r srem myset 1 2 3 4 5 6 7 8
+ } {3}
+
+ foreach {type} {hashtable intset} {
+ for {set i 1} {$i <= 5} {incr i} {
+ r del [format "set%d" $i]
+ }
+ for {set i 0} {$i < 200} {incr i} {
+ r sadd set1 $i
+ r sadd set2 [expr $i+195]
+ }
+ foreach i {199 195 1000 2000} {
+ r sadd set3 $i
+ }
+ for {set i 5} {$i < 200} {incr i} {
+ r sadd set4 $i
+ }
+ r sadd set5 0
+
+ # To make sure the sets are encoded as the type we are testing -- also
+ # when the VM is enabled and the values may be swapped in and out
+ # while the tests are running -- an extra element is added to every
+ # set that determines its encoding.
+ set large 200
+ if {$type eq "hashtable"} {
+ set large foo
+ }
+
+ for {set i 1} {$i <= 5} {incr i} {
+ r sadd [format "set%d" $i] $large
+ }
+
+ test "Generated sets must be encoded as $type" {
+ for {set i 1} {$i <= 5} {incr i} {
+ assert_encoding $type [format "set%d" $i]
+ }
+ }
+
+ test "SINTER with two sets - $type" {
+ assert_equal [list 195 196 197 198 199 $large] [lsort [r sinter set1 set2]]
+ }
+
+ test "SINTERSTORE with two sets - $type" {
+ r sinterstore setres set1 set2
+ assert_encoding $type setres
+ assert_equal [list 195 196 197 198 199 $large] [lsort [r smembers setres]]
+ }
+
+ test "SINTERSTORE with two sets, after a DEBUG RELOAD - $type" {
+ r debug reload
+ r sinterstore setres set1 set2
+ assert_encoding $type setres
+ assert_equal [list 195 196 197 198 199 $large] [lsort [r smembers setres]]
+ }
+
+ test "SUNION with two sets - $type" {
+ set expected [lsort -uniq "[r smembers set1] [r smembers set2]"]
+ assert_equal $expected [lsort [r sunion set1 set2]]
+ }
+
+ test "SUNIONSTORE with two sets - $type" {
+ r sunionstore setres set1 set2
+ assert_encoding $type setres
+ set expected [lsort -uniq "[r smembers set1] [r smembers set2]"]
+ assert_equal $expected [lsort [r smembers setres]]
+ }
+
+ test "SINTER against three sets - $type" {
+ assert_equal [list 195 199 $large] [lsort [r sinter set1 set2 set3]]
+ }
+
+ test "SINTERSTORE with three sets - $type" {
+ r sinterstore setres set1 set2 set3
+ assert_equal [list 195 199 $large] [lsort [r smembers setres]]
+ }
+
+ test "SUNION with non existing keys - $type" {
+ set expected [lsort -uniq "[r smembers set1] [r smembers set2]"]
+ assert_equal $expected [lsort [r sunion nokey1 set1 set2 nokey2]]
+ }
+
+ test "SDIFF with two sets - $type" {
+ assert_equal {0 1 2 3 4} [lsort [r sdiff set1 set4]]
+ }
+
+ test "SDIFF with three sets - $type" {
+ assert_equal {1 2 3 4} [lsort [r sdiff set1 set4 set5]]
+ }
+
+ test "SDIFFSTORE with three sets - $type" {
+ r sdiffstore setres set1 set4 set5
+ # When we start with intsets, we should always end with intsets.
+ if {$type eq {intset}} {
+ assert_encoding intset setres
+ }
+ assert_equal {1 2 3 4} [lsort [r smembers setres]]
+ }
+ }
+
+ test "SDIFF with first set empty" {
+ r del set1 set2 set3
+ r sadd set2 1 2 3 4
+ r sadd set3 a b c d
+ r sdiff set1 set2 set3
+ } {}
+
+ test "SDIFF with same set two times" {
+ r del set1
+ r sadd set1 a b c 1 2 3 4 5 6
+ r sdiff set1 set1
+ } {}
+
+ test "SDIFF fuzzing" {
+ for {set j 0} {$j < 100} {incr j} {
+ unset -nocomplain s
+ array set s {}
+ set args {}
+ set num_sets [expr {[randomInt 10]+1}]
+ for {set i 0} {$i < $num_sets} {incr i} {
+ set num_elements [randomInt 100]
+ r del set_$i
+ lappend args set_$i
+ while {$num_elements} {
+ set ele [randomValue]
+ r sadd set_$i $ele
+ if {$i == 0} {
+ set s($ele) x
+ } else {
+ unset -nocomplain s($ele)
+ }
+ incr num_elements -1
+ }
+ }
+ set result [lsort [r sdiff {*}$args]]
+ assert_equal $result [lsort [array names s]]
+ }
+ }
+
+ test "SINTER against non-set should throw error" {
+ r set key1 x
+ assert_error "WRONGTYPE*" {r sinter key1 noset}
+ }
+
+ test "SUNION against non-set should throw error" {
+ r set key1 x
+ assert_error "WRONGTYPE*" {r sunion key1 noset}
+ }
+
+ test "SINTER should handle non existing key as empty" {
+ r del set1 set2 set3
+ r sadd set1 a b c
+ r sadd set2 b c d
+ r sinter set1 set2 set3
+ } {}
+
+ test "SINTER with same integer elements but different encoding" {
+ r del set1 set2
+ r sadd set1 1 2 3
+ r sadd set2 1 2 3 a
+ r srem set2 a
+ assert_encoding intset set1
+ assert_encoding hashtable set2
+ lsort [r sinter set1 set2]
+ } {1 2 3}
+
+ test "SINTERSTORE against non existing keys should delete dstkey" {
+ r set setres xxx
+ assert_equal 0 [r sinterstore setres foo111 bar222]
+ assert_equal 0 [r exists setres]
+ }
+
+ test "SUNIONSTORE against non existing keys should delete dstkey" {
+ r set setres xxx
+ assert_equal 0 [r sunionstore setres foo111 bar222]
+ assert_equal 0 [r exists setres]
+ }
+
+ foreach {type contents} {hashtable {a b c} intset {1 2 3}} {
+ test "SPOP basics - $type" {
+ create_set myset $contents
+ assert_encoding $type myset
+ assert_equal $contents [lsort [list [r spop myset] [r spop myset] [r spop myset]]]
+ assert_equal 0 [r scard myset]
+ }
+
+ test "SPOP with <count>=1 - $type" {
+ create_set myset $contents
+ assert_encoding $type myset
+ assert_equal $contents [lsort [list [r spop myset 1] [r spop myset 1] [r spop myset 1]]]
+ assert_equal 0 [r scard myset]
+ }
+
+ test "SRANDMEMBER - $type" {
+ create_set myset $contents
+ unset -nocomplain myset
+ array set myset {}
+ for {set i 0} {$i < 100} {incr i} {
+ set myset([r srandmember myset]) 1
+ }
+ assert_equal $contents [lsort [array names myset]]
+ }
+ }
+
+ foreach {type contents} {
+ hashtable {a b c d e f g h i j k l m n o p q r s t u v w x y z}
+ intset {1 10 11 12 13 14 15 16 17 18 19 2 20 21 22 23 24 25 26 3 4 5 6 7 8 9}
+ } {
+ test "SPOP with <count>" {
+ create_set myset $contents
+ assert_encoding $type myset
+ assert_equal $contents [lsort [concat [r spop myset 11] [r spop myset 9] [r spop myset 0] [r spop myset 4] [r spop myset 1] [r spop myset 0] [r spop myset 1] [r spop myset 0]]]
+ assert_equal 0 [r scard myset]
+ }
+ }
+
+ # As seen in intsetRandomMembers
+ test "SPOP using integers, testing Knuth's and Floyd's algorithm" {
+ create_set myset {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20}
+ assert_encoding intset myset
+ assert_equal 20 [r scard myset]
+ r spop myset 1
+ assert_equal 19 [r scard myset]
+ r spop myset 2
+ assert_equal 17 [r scard myset]
+ r spop myset 3
+ assert_equal 14 [r scard myset]
+ r spop myset 10
+ assert_equal 4 [r scard myset]
+ r spop myset 10
+ assert_equal 0 [r scard myset]
+ r spop myset 1
+ assert_equal 0 [r scard myset]
+ } {}
+
+ test "SPOP using integers with Knuth's algorithm" {
+ r spop nonexisting_key 100
+ } {}
+
+ test "SPOP new implementation: code path #1" {
+ set content {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20}
+ create_set myset $content
+ set res [r spop myset 30]
+ assert {[lsort $content] eq [lsort $res]}
+ }
+
+ test "SPOP new implementation: code path #2" {
+ set content {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20}
+ create_set myset $content
+ set res [r spop myset 2]
+ assert {[llength $res] == 2}
+ assert {[r scard myset] == 18}
+ set union [concat [r smembers myset] $res]
+ assert {[lsort $union] eq [lsort $content]}
+ }
+
+ test "SPOP new implementation: code path #3" {
+ set content {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20}
+ create_set myset $content
+ set res [r spop myset 18]
+ assert {[llength $res] == 18}
+ assert {[r scard myset] == 2}
+ set union [concat [r smembers myset] $res]
+ assert {[lsort $union] eq [lsort $content]}
+ }
+
+ test "SRANDMEMBER with <count> against non existing key" {
+ r srandmember nonexisting_key 100
+ } {}
+
+ foreach {type contents} {
+ hashtable {
+ 1 5 10 50 125 50000 33959417 4775547 65434162
+ 12098459 427716 483706 2726473884 72615637475
+ MARY PATRICIA LINDA BARBARA ELIZABETH JENNIFER MARIA
+ SUSAN MARGARET DOROTHY LISA NANCY KAREN BETTY HELEN
+ SANDRA DONNA CAROL RUTH SHARON MICHELLE LAURA SARAH
+ KIMBERLY DEBORAH JESSICA SHIRLEY CYNTHIA ANGELA MELISSA
+ BRENDA AMY ANNA REBECCA VIRGINIA KATHLEEN
+ }
+ intset {
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
+ 20 21 22 23 24 25 26 27 28 29
+ 30 31 32 33 34 35 36 37 38 39
+ 40 41 42 43 44 45 46 47 48 49
+ }
+ } {
+ test "SRANDMEMBER with <count> - $type" {
+ create_set myset $contents
+ unset -nocomplain myset
+ array set myset {}
+ foreach ele [r smembers myset] {
+ set myset($ele) 1
+ }
+ assert_equal [lsort $contents] [lsort [array names myset]]
+
+ # Make sure that a count of 0 is handled correctly.
+ assert_equal [r srandmember myset 0] {}
+
+ # We'll stress different parts of the code, see the implementation
+ # of SRANDMEMBER for more information, but basically there are
+ # four different code paths.
+ #
+ # PATH 1: Use negative count.
+ #
+ # 1) Check that it returns repeated elements.
+ set res [r srandmember myset -100]
+ assert_equal [llength $res] 100
+
+ # 2) Check that all the elements actually belong to the
+ # original set.
+ foreach ele $res {
+ assert {[info exists myset($ele)]}
+ }
+
+ # 3) Check that eventually all the elements are returned.
+ unset -nocomplain auxset
+ set iterations 1000
+ while {$iterations != 0} {
+ incr iterations -1
+ set res [r srandmember myset -10]
+ foreach ele $res {
+ set auxset($ele) 1
+ }
+ if {[lsort [array names myset]] eq
+ [lsort [array names auxset]]} {
+ break;
+ }
+ }
+ assert {$iterations != 0}
+
+ # PATH 2: positive count (unique behavior) with requested size
+ # equal or greater than set size.
+ foreach size {50 100} {
+ set res [r srandmember myset $size]
+ assert_equal [llength $res] 50
+ assert_equal [lsort $res] [lsort [array names myset]]
+ }
+
+ # PATH 3: Ask almost as elements as there are in the set.
+ # In this case the implementation will duplicate the original
+ # set and will remove random elements up to the requested size.
+ #
+ # PATH 4: Ask a number of elements definitely smaller than
+ # the set size.
+ #
+ # We can test both the code paths just changing the size but
+ # using the same code.
+
+ foreach size {45 5} {
+ set res [r srandmember myset $size]
+ assert_equal [llength $res] $size
+
+ # 1) Check that all the elements actually belong to the
+ # original set.
+ foreach ele $res {
+ assert {[info exists myset($ele)]}
+ }
+
+ # 2) Check that eventually all the elements are returned.
+ unset -nocomplain auxset
+ set iterations 1000
+ while {$iterations != 0} {
+ incr iterations -1
+ set res [r srandmember myset -10]
+ foreach ele $res {
+ set auxset($ele) 1
+ }
+ if {[lsort [array names myset]] eq
+ [lsort [array names auxset]]} {
+ break;
+ }
+ }
+ assert {$iterations != 0}
+ }
+ }
+ }
+
+ proc setup_move {} {
+ r del myset3 myset4
+ create_set myset1 {1 a b}
+ create_set myset2 {2 3 4}
+ assert_encoding hashtable myset1
+ assert_encoding intset myset2
+ }
+
+ test "SMOVE basics - from regular set to intset" {
+ # move a non-integer element to an intset should convert encoding
+ setup_move
+ assert_equal 1 [r smove myset1 myset2 a]
+ assert_equal {1 b} [lsort [r smembers myset1]]
+ assert_equal {2 3 4 a} [lsort [r smembers myset2]]
+ assert_encoding hashtable myset2
+
+ # move an integer element should not convert the encoding
+ setup_move
+ assert_equal 1 [r smove myset1 myset2 1]
+ assert_equal {a b} [lsort [r smembers myset1]]
+ assert_equal {1 2 3 4} [lsort [r smembers myset2]]
+ assert_encoding intset myset2
+ }
+
+ test "SMOVE basics - from intset to regular set" {
+ setup_move
+ assert_equal 1 [r smove myset2 myset1 2]
+ assert_equal {1 2 a b} [lsort [r smembers myset1]]
+ assert_equal {3 4} [lsort [r smembers myset2]]
+ }
+
+ test "SMOVE non existing key" {
+ setup_move
+ assert_equal 0 [r smove myset1 myset2 foo]
+ assert_equal 0 [r smove myset1 myset1 foo]
+ assert_equal {1 a b} [lsort [r smembers myset1]]
+ assert_equal {2 3 4} [lsort [r smembers myset2]]
+ }
+
+ test "SMOVE non existing src set" {
+ setup_move
+ assert_equal 0 [r smove noset myset2 foo]
+ assert_equal {2 3 4} [lsort [r smembers myset2]]
+ }
+
+ test "SMOVE from regular set to non existing destination set" {
+ setup_move
+ assert_equal 1 [r smove myset1 myset3 a]
+ assert_equal {1 b} [lsort [r smembers myset1]]
+ assert_equal {a} [lsort [r smembers myset3]]
+ assert_encoding hashtable myset3
+ }
+
+ test "SMOVE from intset to non existing destination set" {
+ setup_move
+ assert_equal 1 [r smove myset2 myset3 2]
+ assert_equal {3 4} [lsort [r smembers myset2]]
+ assert_equal {2} [lsort [r smembers myset3]]
+ assert_encoding intset myset3
+ }
+
+ test "SMOVE wrong src key type" {
+ r set x 10
+ assert_error "WRONGTYPE*" {r smove x myset2 foo}
+ }
+
+ test "SMOVE wrong dst key type" {
+ r set x 10
+ assert_error "WRONGTYPE*" {r smove myset2 x foo}
+ }
+
+ test "SMOVE with identical source and destination" {
+ r del set
+ r sadd set a b c
+ r smove set set b
+ lsort [r smembers set]
+ } {a b c}
+
+ tags {slow} {
+ test {intsets implementation stress testing} {
+ for {set j 0} {$j < 20} {incr j} {
+ unset -nocomplain s
+ array set s {}
+ r del s
+ set len [randomInt 1024]
+ for {set i 0} {$i < $len} {incr i} {
+ randpath {
+ set data [randomInt 65536]
+ } {
+ set data [randomInt 4294967296]
+ } {
+ set data [randomInt 18446744073709551616]
+ }
+ set s($data) {}
+ r sadd s $data
+ }
+ assert_equal [lsort [r smembers s]] [lsort [array names s]]
+ set len [array size s]
+ for {set i 0} {$i < $len} {incr i} {
+ set e [r spop s]
+ if {![info exists s($e)]} {
+ puts "Can't find '$e' on local array"
+ puts "Local array: [lsort [r smembers s]]"
+ puts "Remote array: [lsort [array names s]]"
+ error "exception"
+ }
+ array unset s $e
+ }
+ assert_equal [r scard s] 0
+ assert_equal [array size s] 0
+ }
+ }
+ }
+}
diff --git a/tests/unit/type/string.tcl b/tests/unit/type/string.tcl
new file mode 100644
index 0000000..7122fd9
--- /dev/null
+++ b/tests/unit/type/string.tcl
@@ -0,0 +1,422 @@
+start_server {tags {"string"}} {
+ test {SET and GET an item} {
+ r set x foobar
+ r get x
+ } {foobar}
+
+ test {SET and GET an empty item} {
+ r set x {}
+ r get x
+ } {}
+
+ test {Very big payload in GET/SET} {
+ set buf [string repeat "abcd" 1000000]
+ r set foo $buf
+ r get foo
+ } [string repeat "abcd" 1000000]
+
+ tags {"slow"} {
+ test {Very big payload random access} {
+ set err {}
+ array set payload {}
+ for {set j 0} {$j < 100} {incr j} {
+ set size [expr 1+[randomInt 100000]]
+ set buf [string repeat "pl-$j" $size]
+ set payload($j) $buf
+ r set bigpayload_$j $buf
+ }
+ for {set j 0} {$j < 1000} {incr j} {
+ set index [randomInt 100]
+ set buf [r get bigpayload_$index]
+ if {$buf != $payload($index)} {
+ set err "Values differ: I set '$payload($index)' but I read back '$buf'"
+ break
+ }
+ }
+ unset payload
+ set _ $err
+ } {}
+
+ test {SET 10000 numeric keys and access all them in reverse order} {
+ r flushdb
+ set err {}
+ for {set x 0} {$x < 10000} {incr x} {
+ r set $x $x
+ }
+ set sum 0
+ for {set x 9999} {$x >= 0} {incr x -1} {
+ set val [r get $x]
+ if {$val ne $x} {
+ set err "Element at position $x is $val instead of $x"
+ break
+ }
+ }
+ set _ $err
+ } {}
+
+ test {DBSIZE should be 10000 now} {
+ r dbsize
+ } {10000}
+ }
+
+ test "SETNX target key missing" {
+ r del novar
+ assert_equal 1 [r setnx novar foobared]
+ assert_equal "foobared" [r get novar]
+ }
+
+ test "SETNX target key exists" {
+ r set novar foobared
+ assert_equal 0 [r setnx novar blabla]
+ assert_equal "foobared" [r get novar]
+ }
+
+ test "SETNX against not-expired volatile key" {
+ r set x 10
+ r expire x 10000
+ assert_equal 0 [r setnx x 20]
+ assert_equal 10 [r get x]
+ }
+
+ test "SETNX against expired volatile key" {
+ # Make it very unlikely for the key this test uses to be expired by the
+ # active expiry cycle. This is tightly coupled to the implementation of
+ # active expiry and dbAdd() but currently the only way to test that
+ # SETNX expires a key when it should have been.
+ for {set x 0} {$x < 9999} {incr x} {
+ r setex key-$x 3600 value
+ }
+
+ # This will be one of 10000 expiring keys. A cycle is executed every
+ # 100ms, sampling 10 keys for being expired or not. This key will be
+ # expired for at most 1s when we wait 2s, resulting in a total sample
+ # of 100 keys. The probability of the success of this test being a
+ # false positive is therefore approx. 1%.
+ r set x 10
+ r expire x 1
+
+ # Wait for the key to expire
+ after 2000
+
+ assert_equal 1 [r setnx x 20]
+ assert_equal 20 [r get x]
+ }
+
+ test {MGET} {
+ r flushdb
+ r set foo BAR
+ r set bar FOO
+ r mget foo bar
+ } {BAR FOO}
+
+ test {MGET against non existing key} {
+ r mget foo baazz bar
+ } {BAR {} FOO}
+
+ test {MGET against non-string key} {
+ r sadd myset ciao
+ r sadd myset bau
+ r mget foo baazz bar myset
+ } {BAR {} FOO {}}
+
+ test {GETSET (set new value)} {
+ r del foo
+ list [r getset foo xyz] [r get foo]
+ } {{} xyz}
+
+ test {GETSET (replace old value)} {
+ r set foo bar
+ list [r getset foo xyz] [r get foo]
+ } {bar xyz}
+
+ test {MSET base case} {
+ r mset x 10 y "foo bar" z "x x x x x x x\n\n\r\n"
+ r mget x y z
+ } [list 10 {foo bar} "x x x x x x x\n\n\r\n"]
+
+ test {MSET wrong number of args} {
+ catch {r mset x 10 y "foo bar" z} err
+ format $err
+ } {*wrong number*}
+
+ test {MSETNX with already existent key} {
+ list [r msetnx x1 xxx y2 yyy x 20] [r exists x1] [r exists y2]
+ } {0 0 0}
+
+ test {MSETNX with not existing keys} {
+ list [r msetnx x1 xxx y2 yyy] [r get x1] [r get y2]
+ } {1 xxx yyy}
+
+ test "STRLEN against non-existing key" {
+ assert_equal 0 [r strlen notakey]
+ }
+
+ test "STRLEN against integer-encoded value" {
+ r set myinteger -555
+ assert_equal 4 [r strlen myinteger]
+ }
+
+ test "STRLEN against plain string" {
+ r set mystring "foozzz0123456789 baz"
+ assert_equal 20 [r strlen mystring]
+ }
+
+ test "SETBIT against non-existing key" {
+ r del mykey
+ assert_equal 0 [r setbit mykey 1 1]
+ assert_equal [binary format B* 01000000] [r get mykey]
+ }
+
+ test "SETBIT against string-encoded key" {
+ # Ascii "@" is integer 64 = 01 00 00 00
+ r set mykey "@"
+
+ assert_equal 0 [r setbit mykey 2 1]
+ assert_equal [binary format B* 01100000] [r get mykey]
+ assert_equal 1 [r setbit mykey 1 0]
+ assert_equal [binary format B* 00100000] [r get mykey]
+ }
+
+ test "SETBIT against integer-encoded key" {
+ # Ascii "1" is integer 49 = 00 11 00 01
+ r set mykey 1
+ assert_encoding int mykey
+
+ assert_equal 0 [r setbit mykey 6 1]
+ assert_equal [binary format B* 00110011] [r get mykey]
+ assert_equal 1 [r setbit mykey 2 0]
+ assert_equal [binary format B* 00010011] [r get mykey]
+ }
+
+ test "SETBIT against key with wrong type" {
+ r del mykey
+ r lpush mykey "foo"
+ assert_error "WRONGTYPE*" {r setbit mykey 0 1}
+ }
+
+ test "SETBIT with out of range bit offset" {
+ r del mykey
+ assert_error "*out of range*" {r setbit mykey [expr 4*1024*1024*1024] 1}
+ assert_error "*out of range*" {r setbit mykey -1 1}
+ }
+
+ test "SETBIT with non-bit argument" {
+ r del mykey
+ assert_error "*out of range*" {r setbit mykey 0 -1}
+ assert_error "*out of range*" {r setbit mykey 0 2}
+ assert_error "*out of range*" {r setbit mykey 0 10}
+ assert_error "*out of range*" {r setbit mykey 0 20}
+ }
+
+ test "SETBIT fuzzing" {
+ set str ""
+ set len [expr 256*8]
+ r del mykey
+
+ for {set i 0} {$i < 2000} {incr i} {
+ set bitnum [randomInt $len]
+ set bitval [randomInt 2]
+ set fmt [format "%%-%ds%%d%%-s" $bitnum]
+ set head [string range $str 0 $bitnum-1]
+ set tail [string range $str $bitnum+1 end]
+ set str [string map {" " 0} [format $fmt $head $bitval $tail]]
+
+ r setbit mykey $bitnum $bitval
+ assert_equal [binary format B* $str] [r get mykey]
+ }
+ }
+
+ test "GETBIT against non-existing key" {
+ r del mykey
+ assert_equal 0 [r getbit mykey 0]
+ }
+
+ test "GETBIT against string-encoded key" {
+ # Single byte with 2nd and 3rd bit set
+ r set mykey "`"
+
+ # In-range
+ assert_equal 0 [r getbit mykey 0]
+ assert_equal 1 [r getbit mykey 1]
+ assert_equal 1 [r getbit mykey 2]
+ assert_equal 0 [r getbit mykey 3]
+
+ # Out-range
+ assert_equal 0 [r getbit mykey 8]
+ assert_equal 0 [r getbit mykey 100]
+ assert_equal 0 [r getbit mykey 10000]
+ }
+
+ test "GETBIT against integer-encoded key" {
+ r set mykey 1
+ assert_encoding int mykey
+
+ # Ascii "1" is integer 49 = 00 11 00 01
+ assert_equal 0 [r getbit mykey 0]
+ assert_equal 0 [r getbit mykey 1]
+ assert_equal 1 [r getbit mykey 2]
+ assert_equal 1 [r getbit mykey 3]
+
+ # Out-range
+ assert_equal 0 [r getbit mykey 8]
+ assert_equal 0 [r getbit mykey 100]
+ assert_equal 0 [r getbit mykey 10000]
+ }
+
+ test "SETRANGE against non-existing key" {
+ r del mykey
+ assert_equal 3 [r setrange mykey 0 foo]
+ assert_equal "foo" [r get mykey]
+
+ r del mykey
+ assert_equal 0 [r setrange mykey 0 ""]
+ assert_equal 0 [r exists mykey]
+
+ r del mykey
+ assert_equal 4 [r setrange mykey 1 foo]
+ assert_equal "\000foo" [r get mykey]
+ }
+
+ test "SETRANGE against string-encoded key" {
+ r set mykey "foo"
+ assert_equal 3 [r setrange mykey 0 b]
+ assert_equal "boo" [r get mykey]
+
+ r set mykey "foo"
+ assert_equal 3 [r setrange mykey 0 ""]
+ assert_equal "foo" [r get mykey]
+
+ r set mykey "foo"
+ assert_equal 3 [r setrange mykey 1 b]
+ assert_equal "fbo" [r get mykey]
+
+ r set mykey "foo"
+ assert_equal 7 [r setrange mykey 4 bar]
+ assert_equal "foo\000bar" [r get mykey]
+ }
+
+ test "SETRANGE against integer-encoded key" {
+ r set mykey 1234
+ assert_encoding int mykey
+ assert_equal 4 [r setrange mykey 0 2]
+ assert_encoding raw mykey
+ assert_equal 2234 [r get mykey]
+
+ # Shouldn't change encoding when nothing is set
+ r set mykey 1234
+ assert_encoding int mykey
+ assert_equal 4 [r setrange mykey 0 ""]
+ assert_encoding int mykey
+ assert_equal 1234 [r get mykey]
+
+ r set mykey 1234
+ assert_encoding int mykey
+ assert_equal 4 [r setrange mykey 1 3]
+ assert_encoding raw mykey
+ assert_equal 1334 [r get mykey]
+
+ r set mykey 1234
+ assert_encoding int mykey
+ assert_equal 6 [r setrange mykey 5 2]
+ assert_encoding raw mykey
+ assert_equal "1234\0002" [r get mykey]
+ }
+
+ test "SETRANGE against key with wrong type" {
+ r del mykey
+ r lpush mykey "foo"
+ assert_error "WRONGTYPE*" {r setrange mykey 0 bar}
+ }
+
+ test "SETRANGE with out of range offset" {
+ r del mykey
+ assert_error "*maximum allowed size*" {r setrange mykey [expr 512*1024*1024-4] world}
+
+ r set mykey "hello"
+ assert_error "*out of range*" {r setrange mykey -1 world}
+ assert_error "*maximum allowed size*" {r setrange mykey [expr 512*1024*1024-4] world}
+ }
+
+ test "GETRANGE against non-existing key" {
+ r del mykey
+ assert_equal "" [r getrange mykey 0 -1]
+ }
+
+ test "GETRANGE against string value" {
+ r set mykey "Hello World"
+ assert_equal "Hell" [r getrange mykey 0 3]
+ assert_equal "Hello World" [r getrange mykey 0 -1]
+ assert_equal "orld" [r getrange mykey -4 -1]
+ assert_equal "" [r getrange mykey 5 3]
+ assert_equal " World" [r getrange mykey 5 5000]
+ assert_equal "Hello World" [r getrange mykey -5000 10000]
+ }
+
+ test "GETRANGE against integer-encoded value" {
+ r set mykey 1234
+ assert_equal "123" [r getrange mykey 0 2]
+ assert_equal "1234" [r getrange mykey 0 -1]
+ assert_equal "234" [r getrange mykey -3 -1]
+ assert_equal "" [r getrange mykey 5 3]
+ assert_equal "4" [r getrange mykey 3 5000]
+ assert_equal "1234" [r getrange mykey -5000 10000]
+ }
+
+ test "GETRANGE fuzzing" {
+ for {set i 0} {$i < 1000} {incr i} {
+ r set bin [set bin [randstring 0 1024 binary]]
+ set _start [set start [randomInt 1500]]
+ set _end [set end [randomInt 1500]]
+ if {$_start < 0} {set _start "end-[abs($_start)-1]"}
+ if {$_end < 0} {set _end "end-[abs($_end)-1]"}
+ assert_equal [string range $bin $_start $_end] [r getrange bin $start $end]
+ }
+ }
+
+ test {Extended SET can detect syntax errors} {
+ set e {}
+ catch {r set foo bar non-existing-option} e
+ set e
+ } {*syntax*}
+
+ test {Extended SET NX option} {
+ r del foo
+ set v1 [r set foo 1 nx]
+ set v2 [r set foo 2 nx]
+ list $v1 $v2 [r get foo]
+ } {OK {} 1}
+
+ test {Extended SET XX option} {
+ r del foo
+ set v1 [r set foo 1 xx]
+ r set foo bar
+ set v2 [r set foo 2 xx]
+ list $v1 $v2 [r get foo]
+ } {{} OK 2}
+
+ test {Extended SET EX option} {
+ r del foo
+ r set foo bar ex 10
+ set ttl [r ttl foo]
+ assert {$ttl <= 10 && $ttl > 5}
+ }
+
+ test {Extended SET PX option} {
+ r del foo
+ r set foo bar px 10000
+ set ttl [r ttl foo]
+ assert {$ttl <= 10 && $ttl > 5}
+ }
+
+ test {Extended SET using multiple options at once} {
+ r set foo val
+ assert {[r set foo bar xx px 10000] eq {OK}}
+ set ttl [r ttl foo]
+ assert {$ttl <= 10 && $ttl > 5}
+ }
+
+ test {GETRANGE with huge ranges, Github issue #1844} {
+ r set foo bar
+ r getrange foo 0 4294967297
+ } {bar}
+}
diff --git a/tests/unit/type/zset.tcl b/tests/unit/type/zset.tcl
new file mode 100644
index 0000000..82f76be
--- /dev/null
+++ b/tests/unit/type/zset.tcl
@@ -0,0 +1,1030 @@
+start_server {tags {"zset"}} {
+ proc create_zset {key items} {
+ r del $key
+ foreach {score entry} $items {
+ r zadd $key $score $entry
+ }
+ }
+
+ proc basics {encoding} {
+ if {$encoding == "ziplist"} {
+ r config set zset-max-ziplist-entries 128
+ r config set zset-max-ziplist-value 64
+ } elseif {$encoding == "skiplist"} {
+ r config set zset-max-ziplist-entries 0
+ r config set zset-max-ziplist-value 0
+ } else {
+ puts "Unknown sorted set encoding"
+ exit
+ }
+
+ test "Check encoding - $encoding" {
+ r del ztmp
+ r zadd ztmp 10 x
+ assert_encoding $encoding ztmp
+ }
+
+ test "ZSET basic ZADD and score update - $encoding" {
+ r del ztmp
+ r zadd ztmp 10 x
+ r zadd ztmp 20 y
+ r zadd ztmp 30 z
+ assert_equal {x y z} [r zrange ztmp 0 -1]
+
+ r zadd ztmp 1 y
+ assert_equal {y x z} [r zrange ztmp 0 -1]
+ }
+
+ test "ZSET element can't be set to NaN with ZADD - $encoding" {
+ assert_error "*not*float*" {r zadd myzset nan abc}
+ }
+
+ test "ZSET element can't be set to NaN with ZINCRBY" {
+ assert_error "*not*float*" {r zadd myzset nan abc}
+ }
+
+ test "ZADD with options syntax error with incomplete pair" {
+ r del ztmp
+ catch {r zadd ztmp xx 10 x 20} err
+ set err
+ } {ERR*}
+
+ test "ZADD XX option without key - $encoding" {
+ r del ztmp
+ assert {[r zadd ztmp xx 10 x] == 0}
+ assert {[r type ztmp] eq {none}}
+ }
+
+ test "ZADD XX existing key - $encoding" {
+ r del ztmp
+ r zadd ztmp 10 x
+ assert {[r zadd ztmp xx 20 y] == 0}
+ assert {[r zcard ztmp] == 1}
+ }
+
+ test "ZADD XX returns the number of elements actually added" {
+ r del ztmp
+ r zadd ztmp 10 x
+ set retval [r zadd ztmp 10 x 20 y 30 z]
+ assert {$retval == 2}
+ }
+
+ test "ZADD XX updates existing elements score" {
+ r del ztmp
+ r zadd ztmp 10 x 20 y 30 z
+ r zadd ztmp xx 5 foo 11 x 21 y 40 zap
+ assert {[r zcard ztmp] == 3}
+ assert {[r zscore ztmp x] == 11}
+ assert {[r zscore ztmp y] == 21}
+ }
+
+ test "ZADD XX and NX are not compatible" {
+ r del ztmp
+ catch {r zadd ztmp xx nx 10 x} err
+ set err
+ } {ERR*}
+
+ test "ZADD NX with non exisitng key" {
+ r del ztmp
+ r zadd ztmp nx 10 x 20 y 30 z
+ assert {[r zcard ztmp] == 3}
+ }
+
+ test "ZADD NX only add new elements without updating old ones" {
+ r del ztmp
+ r zadd ztmp 10 x 20 y 30 z
+ assert {[r zadd ztmp nx 11 x 21 y 100 a 200 b] == 2}
+ assert {[r zscore ztmp x] == 10}
+ assert {[r zscore ztmp y] == 20}
+ assert {[r zscore ztmp a] == 100}
+ assert {[r zscore ztmp b] == 200}
+ }
+
+ test "ZADD INCR works like ZINCRBY" {
+ r del ztmp
+ r zadd ztmp 10 x 20 y 30 z
+ r zadd ztmp INCR 15 x
+ assert {[r zscore ztmp x] == 25}
+ }
+
+ test "ZADD INCR works with a single score-elemenet pair" {
+ r del ztmp
+ r zadd ztmp 10 x 20 y 30 z
+ catch {r zadd ztmp INCR 15 x 10 y} err
+ set err
+ } {ERR*}
+
+ test "ZADD CH option changes return value to all changed elements" {
+ r del ztmp
+ r zadd ztmp 10 x 20 y 30 z
+ assert {[r zadd ztmp 11 x 21 y 30 z] == 0}
+ assert {[r zadd ztmp ch 12 x 22 y 30 z] == 2}
+ }
+
+ test "ZINCRBY calls leading to NaN result in error" {
+ r zincrby myzset +inf abc
+ assert_error "*NaN*" {r zincrby myzset -inf abc}
+ }
+
+ test {ZADD - Variadic version base case} {
+ r del myzset
+ list [r zadd myzset 10 a 20 b 30 c] [r zrange myzset 0 -1 withscores]
+ } {3 {a 10 b 20 c 30}}
+
+ test {ZADD - Return value is the number of actually added items} {
+ list [r zadd myzset 5 x 20 b 30 c] [r zrange myzset 0 -1 withscores]
+ } {1 {x 5 a 10 b 20 c 30}}
+
+ test {ZADD - Variadic version does not add nothing on single parsing err} {
+ r del myzset
+ catch {r zadd myzset 10 a 20 b 30.badscore c} e
+ assert_match {*ERR*not*float*} $e
+ r exists myzset
+ } {0}
+
+ test {ZADD - Variadic version will raise error on missing arg} {
+ r del myzset
+ catch {r zadd myzset 10 a 20 b 30 c 40} e
+ assert_match {*ERR*syntax*} $e
+ }
+
+ test {ZINCRBY does not work variadic even if shares ZADD implementation} {
+ r del myzset
+ catch {r zincrby myzset 10 a 20 b 30 c} e
+ assert_match {*ERR*wrong*number*arg*} $e
+ }
+
+ test "ZCARD basics - $encoding" {
+ r del ztmp
+ r zadd ztmp 10 a 20 b 30 c
+ assert_equal 3 [r zcard ztmp]
+ assert_equal 0 [r zcard zdoesntexist]
+ }
+
+ test "ZREM removes key after last element is removed" {
+ r del ztmp
+ r zadd ztmp 10 x
+ r zadd ztmp 20 y
+
+ assert_equal 1 [r exists ztmp]
+ assert_equal 0 [r zrem ztmp z]
+ assert_equal 1 [r zrem ztmp y]
+ assert_equal 1 [r zrem ztmp x]
+ assert_equal 0 [r exists ztmp]
+ }
+
+ test "ZREM variadic version" {
+ r del ztmp
+ r zadd ztmp 10 a 20 b 30 c
+ assert_equal 2 [r zrem ztmp x y a b k]
+ assert_equal 0 [r zrem ztmp foo bar]
+ assert_equal 1 [r zrem ztmp c]
+ r exists ztmp
+ } {0}
+
+ test "ZREM variadic version -- remove elements after key deletion" {
+ r del ztmp
+ r zadd ztmp 10 a 20 b 30 c
+ r zrem ztmp a b c d e f g
+ } {3}
+
+ test "ZRANGE basics - $encoding" {
+ r del ztmp
+ r zadd ztmp 1 a
+ r zadd ztmp 2 b
+ r zadd ztmp 3 c
+ r zadd ztmp 4 d
+
+ assert_equal {a b c d} [r zrange ztmp 0 -1]
+ assert_equal {a b c} [r zrange ztmp 0 -2]
+ assert_equal {b c d} [r zrange ztmp 1 -1]
+ assert_equal {b c} [r zrange ztmp 1 -2]
+ assert_equal {c d} [r zrange ztmp -2 -1]
+ assert_equal {c} [r zrange ztmp -2 -2]
+
+ # out of range start index
+ assert_equal {a b c} [r zrange ztmp -5 2]
+ assert_equal {a b} [r zrange ztmp -5 1]
+ assert_equal {} [r zrange ztmp 5 -1]
+ assert_equal {} [r zrange ztmp 5 -2]
+
+ # out of range end index
+ assert_equal {a b c d} [r zrange ztmp 0 5]
+ assert_equal {b c d} [r zrange ztmp 1 5]
+ assert_equal {} [r zrange ztmp 0 -5]
+ assert_equal {} [r zrange ztmp 1 -5]
+
+ # withscores
+ assert_equal {a 1 b 2 c 3 d 4} [r zrange ztmp 0 -1 withscores]
+ }
+
+ test "ZREVRANGE basics - $encoding" {
+ r del ztmp
+ r zadd ztmp 1 a
+ r zadd ztmp 2 b
+ r zadd ztmp 3 c
+ r zadd ztmp 4 d
+
+ assert_equal {d c b a} [r zrevrange ztmp 0 -1]
+ assert_equal {d c b} [r zrevrange ztmp 0 -2]
+ assert_equal {c b a} [r zrevrange ztmp 1 -1]
+ assert_equal {c b} [r zrevrange ztmp 1 -2]
+ assert_equal {b a} [r zrevrange ztmp -2 -1]
+ assert_equal {b} [r zrevrange ztmp -2 -2]
+
+ # out of range start index
+ assert_equal {d c b} [r zrevrange ztmp -5 2]
+ assert_equal {d c} [r zrevrange ztmp -5 1]
+ assert_equal {} [r zrevrange ztmp 5 -1]
+ assert_equal {} [r zrevrange ztmp 5 -2]
+
+ # out of range end index
+ assert_equal {d c b a} [r zrevrange ztmp 0 5]
+ assert_equal {c b a} [r zrevrange ztmp 1 5]
+ assert_equal {} [r zrevrange ztmp 0 -5]
+ assert_equal {} [r zrevrange ztmp 1 -5]
+
+ # withscores
+ assert_equal {d 4 c 3 b 2 a 1} [r zrevrange ztmp 0 -1 withscores]
+ }
+
+ test "ZRANK/ZREVRANK basics - $encoding" {
+ r del zranktmp
+ r zadd zranktmp 10 x
+ r zadd zranktmp 20 y
+ r zadd zranktmp 30 z
+ assert_equal 0 [r zrank zranktmp x]
+ assert_equal 1 [r zrank zranktmp y]
+ assert_equal 2 [r zrank zranktmp z]
+ assert_equal "" [r zrank zranktmp foo]
+ assert_equal 2 [r zrevrank zranktmp x]
+ assert_equal 1 [r zrevrank zranktmp y]
+ assert_equal 0 [r zrevrank zranktmp z]
+ assert_equal "" [r zrevrank zranktmp foo]
+ }
+
+ test "ZRANK - after deletion - $encoding" {
+ r zrem zranktmp y
+ assert_equal 0 [r zrank zranktmp x]
+ assert_equal 1 [r zrank zranktmp z]
+ }
+
+ test "ZINCRBY - can create a new sorted set - $encoding" {
+ r del zset
+ r zincrby zset 1 foo
+ assert_equal {foo} [r zrange zset 0 -1]
+ assert_equal 1 [r zscore zset foo]
+ }
+
+ test "ZINCRBY - increment and decrement - $encoding" {
+ r zincrby zset 2 foo
+ r zincrby zset 1 bar
+ assert_equal {bar foo} [r zrange zset 0 -1]
+
+ r zincrby zset 10 bar
+ r zincrby zset -5 foo
+ r zincrby zset -5 bar
+ assert_equal {foo bar} [r zrange zset 0 -1]
+
+ assert_equal -2 [r zscore zset foo]
+ assert_equal 6 [r zscore zset bar]
+ }
+
+ test "ZINCRBY return value" {
+ r del ztmp
+ set retval [r zincrby ztmp 1.0 x]
+ assert {$retval == 1.0}
+ }
+
+ proc create_default_zset {} {
+ create_zset zset {-inf a 1 b 2 c 3 d 4 e 5 f +inf g}
+ }
+
+ test "ZRANGEBYSCORE/ZREVRANGEBYSCORE/ZCOUNT basics" {
+ create_default_zset
+
+ # inclusive range
+ assert_equal {a b c} [r zrangebyscore zset -inf 2]
+ assert_equal {b c d} [r zrangebyscore zset 0 3]
+ assert_equal {d e f} [r zrangebyscore zset 3 6]
+ assert_equal {e f g} [r zrangebyscore zset 4 +inf]
+ assert_equal {c b a} [r zrevrangebyscore zset 2 -inf]
+ assert_equal {d c b} [r zrevrangebyscore zset 3 0]
+ assert_equal {f e d} [r zrevrangebyscore zset 6 3]
+ assert_equal {g f e} [r zrevrangebyscore zset +inf 4]
+ assert_equal 3 [r zcount zset 0 3]
+
+ # exclusive range
+ assert_equal {b} [r zrangebyscore zset (-inf (2]
+ assert_equal {b c} [r zrangebyscore zset (0 (3]
+ assert_equal {e f} [r zrangebyscore zset (3 (6]
+ assert_equal {f} [r zrangebyscore zset (4 (+inf]
+ assert_equal {b} [r zrevrangebyscore zset (2 (-inf]
+ assert_equal {c b} [r zrevrangebyscore zset (3 (0]
+ assert_equal {f e} [r zrevrangebyscore zset (6 (3]
+ assert_equal {f} [r zrevrangebyscore zset (+inf (4]
+ assert_equal 2 [r zcount zset (0 (3]
+
+ # test empty ranges
+ r zrem zset a
+ r zrem zset g
+
+ # inclusive
+ assert_equal {} [r zrangebyscore zset 4 2]
+ assert_equal {} [r zrangebyscore zset 6 +inf]
+ assert_equal {} [r zrangebyscore zset -inf -6]
+ assert_equal {} [r zrevrangebyscore zset +inf 6]
+ assert_equal {} [r zrevrangebyscore zset -6 -inf]
+
+ # exclusive
+ assert_equal {} [r zrangebyscore zset (4 (2]
+ assert_equal {} [r zrangebyscore zset 2 (2]
+ assert_equal {} [r zrangebyscore zset (2 2]
+ assert_equal {} [r zrangebyscore zset (6 (+inf]
+ assert_equal {} [r zrangebyscore zset (-inf (-6]
+ assert_equal {} [r zrevrangebyscore zset (+inf (6]
+ assert_equal {} [r zrevrangebyscore zset (-6 (-inf]
+
+ # empty inner range
+ assert_equal {} [r zrangebyscore zset 2.4 2.6]
+ assert_equal {} [r zrangebyscore zset (2.4 2.6]
+ assert_equal {} [r zrangebyscore zset 2.4 (2.6]
+ assert_equal {} [r zrangebyscore zset (2.4 (2.6]
+ }
+
+ test "ZRANGEBYSCORE with WITHSCORES" {
+ create_default_zset
+ assert_equal {b 1 c 2 d 3} [r zrangebyscore zset 0 3 withscores]
+ assert_equal {d 3 c 2 b 1} [r zrevrangebyscore zset 3 0 withscores]
+ }
+
+ test "ZRANGEBYSCORE with LIMIT" {
+ create_default_zset
+ assert_equal {b c} [r zrangebyscore zset 0 10 LIMIT 0 2]
+ assert_equal {d e f} [r zrangebyscore zset 0 10 LIMIT 2 3]
+ assert_equal {d e f} [r zrangebyscore zset 0 10 LIMIT 2 10]
+ assert_equal {} [r zrangebyscore zset 0 10 LIMIT 20 10]
+ assert_equal {f e} [r zrevrangebyscore zset 10 0 LIMIT 0 2]
+ assert_equal {d c b} [r zrevrangebyscore zset 10 0 LIMIT 2 3]
+ assert_equal {d c b} [r zrevrangebyscore zset 10 0 LIMIT 2 10]
+ assert_equal {} [r zrevrangebyscore zset 10 0 LIMIT 20 10]
+ }
+
+ test "ZRANGEBYSCORE with LIMIT and WITHSCORES" {
+ create_default_zset
+ assert_equal {e 4 f 5} [r zrangebyscore zset 2 5 LIMIT 2 3 WITHSCORES]
+ assert_equal {d 3 c 2} [r zrevrangebyscore zset 5 2 LIMIT 2 3 WITHSCORES]
+ }
+
+ test "ZRANGEBYSCORE with non-value min or max" {
+ assert_error "*not*float*" {r zrangebyscore fooz str 1}
+ assert_error "*not*float*" {r zrangebyscore fooz 1 str}
+ assert_error "*not*float*" {r zrangebyscore fooz 1 NaN}
+ }
+
+ proc create_default_lex_zset {} {
+ create_zset zset {0 alpha 0 bar 0 cool 0 down
+ 0 elephant 0 foo 0 great 0 hill
+ 0 omega}
+ }
+
+ test "ZRANGEBYLEX/ZREVRANGEBYLEX/ZCOUNT basics" {
+ create_default_lex_zset
+
+ # inclusive range
+ assert_equal {alpha bar cool} [r zrangebylex zset - \[cool]
+ assert_equal {bar cool down} [r zrangebylex zset \[bar \[down]
+ assert_equal {great hill omega} [r zrangebylex zset \[g +]
+ assert_equal {cool bar alpha} [r zrevrangebylex zset \[cool -]
+ assert_equal {down cool bar} [r zrevrangebylex zset \[down \[bar]
+ assert_equal {omega hill great foo elephant down} [r zrevrangebylex zset + \[d]
+ assert_equal 3 [r zlexcount zset \[ele \[h]
+
+ # exclusive range
+ assert_equal {alpha bar} [r zrangebylex zset - (cool]
+ assert_equal {cool} [r zrangebylex zset (bar (down]
+ assert_equal {hill omega} [r zrangebylex zset (great +]
+ assert_equal {bar alpha} [r zrevrangebylex zset (cool -]
+ assert_equal {cool} [r zrevrangebylex zset (down (bar]
+ assert_equal {omega hill} [r zrevrangebylex zset + (great]
+ assert_equal 2 [r zlexcount zset (ele (great]
+
+ # inclusive and exclusive
+ assert_equal {} [r zrangebylex zset (az (b]
+ assert_equal {} [r zrangebylex zset (z +]
+ assert_equal {} [r zrangebylex zset - \[aaaa]
+ assert_equal {} [r zrevrangebylex zset \[elez \[elex]
+ assert_equal {} [r zrevrangebylex zset (hill (omega]
+ }
+
+ test "ZRANGEBYSLEX with LIMIT" {
+ create_default_lex_zset
+ assert_equal {alpha bar} [r zrangebylex zset - \[cool LIMIT 0 2]
+ assert_equal {bar cool} [r zrangebylex zset - \[cool LIMIT 1 2]
+ assert_equal {} [r zrangebylex zset \[bar \[down LIMIT 0 0]
+ assert_equal {} [r zrangebylex zset \[bar \[down LIMIT 2 0]
+ assert_equal {bar} [r zrangebylex zset \[bar \[down LIMIT 0 1]
+ assert_equal {cool} [r zrangebylex zset \[bar \[down LIMIT 1 1]
+ assert_equal {bar cool down} [r zrangebylex zset \[bar \[down LIMIT 0 100]
+ assert_equal {omega hill great foo elephant} [r zrevrangebylex zset + \[d LIMIT 0 5]
+ assert_equal {omega hill great foo} [r zrevrangebylex zset + \[d LIMIT 0 4]
+ }
+
+ test "ZRANGEBYLEX with invalid lex range specifiers" {
+ assert_error "*not*string*" {r zrangebylex fooz foo bar}
+ assert_error "*not*string*" {r zrangebylex fooz \[foo bar}
+ assert_error "*not*string*" {r zrangebylex fooz foo \[bar}
+ assert_error "*not*string*" {r zrangebylex fooz +x \[bar}
+ assert_error "*not*string*" {r zrangebylex fooz -x \[bar}
+ }
+
+ test "ZREMRANGEBYSCORE basics" {
+ proc remrangebyscore {min max} {
+ create_zset zset {1 a 2 b 3 c 4 d 5 e}
+ assert_equal 1 [r exists zset]
+ r zremrangebyscore zset $min $max
+ }
+
+ # inner range
+ assert_equal 3 [remrangebyscore 2 4]
+ assert_equal {a e} [r zrange zset 0 -1]
+
+ # start underflow
+ assert_equal 1 [remrangebyscore -10 1]
+ assert_equal {b c d e} [r zrange zset 0 -1]
+
+ # end overflow
+ assert_equal 1 [remrangebyscore 5 10]
+ assert_equal {a b c d} [r zrange zset 0 -1]
+
+ # switch min and max
+ assert_equal 0 [remrangebyscore 4 2]
+ assert_equal {a b c d e} [r zrange zset 0 -1]
+
+ # -inf to mid
+ assert_equal 3 [remrangebyscore -inf 3]
+ assert_equal {d e} [r zrange zset 0 -1]
+
+ # mid to +inf
+ assert_equal 3 [remrangebyscore 3 +inf]
+ assert_equal {a b} [r zrange zset 0 -1]
+
+ # -inf to +inf
+ assert_equal 5 [remrangebyscore -inf +inf]
+ assert_equal {} [r zrange zset 0 -1]
+
+ # exclusive min
+ assert_equal 4 [remrangebyscore (1 5]
+ assert_equal {a} [r zrange zset 0 -1]
+ assert_equal 3 [remrangebyscore (2 5]
+ assert_equal {a b} [r zrange zset 0 -1]
+
+ # exclusive max
+ assert_equal 4 [remrangebyscore 1 (5]
+ assert_equal {e} [r zrange zset 0 -1]
+ assert_equal 3 [remrangebyscore 1 (4]
+ assert_equal {d e} [r zrange zset 0 -1]
+
+ # exclusive min and max
+ assert_equal 3 [remrangebyscore (1 (5]
+ assert_equal {a e} [r zrange zset 0 -1]
+
+ # destroy when empty
+ assert_equal 5 [remrangebyscore 1 5]
+ assert_equal 0 [r exists zset]
+ }
+
+ test "ZREMRANGEBYSCORE with non-value min or max" {
+ assert_error "*not*float*" {r zremrangebyscore fooz str 1}
+ assert_error "*not*float*" {r zremrangebyscore fooz 1 str}
+ assert_error "*not*float*" {r zremrangebyscore fooz 1 NaN}
+ }
+
+ test "ZREMRANGEBYRANK basics" {
+ proc remrangebyrank {min max} {
+ create_zset zset {1 a 2 b 3 c 4 d 5 e}
+ assert_equal 1 [r exists zset]
+ r zremrangebyrank zset $min $max
+ }
+
+ # inner range
+ assert_equal 3 [remrangebyrank 1 3]
+ assert_equal {a e} [r zrange zset 0 -1]
+
+ # start underflow
+ assert_equal 1 [remrangebyrank -10 0]
+ assert_equal {b c d e} [r zrange zset 0 -1]
+
+ # start overflow
+ assert_equal 0 [remrangebyrank 10 -1]
+ assert_equal {a b c d e} [r zrange zset 0 -1]
+
+ # end underflow
+ assert_equal 0 [remrangebyrank 0 -10]
+ assert_equal {a b c d e} [r zrange zset 0 -1]
+
+ # end overflow
+ assert_equal 5 [remrangebyrank 0 10]
+ assert_equal {} [r zrange zset 0 -1]
+
+ # destroy when empty
+ assert_equal 5 [remrangebyrank 0 4]
+ assert_equal 0 [r exists zset]
+ }
+
+ test "ZUNIONSTORE against non-existing key doesn't set destination - $encoding" {
+ r del zseta
+ assert_equal 0 [r zunionstore dst_key 1 zseta]
+ assert_equal 0 [r exists dst_key]
+ }
+
+ test "ZUNIONSTORE with empty set - $encoding" {
+ r del zseta zsetb
+ r zadd zseta 1 a
+ r zadd zseta 2 b
+ r zunionstore zsetc 2 zseta zsetb
+ r zrange zsetc 0 -1 withscores
+ } {a 1 b 2}
+
+ test "ZUNIONSTORE basics - $encoding" {
+ r del zseta zsetb zsetc
+ r zadd zseta 1 a
+ r zadd zseta 2 b
+ r zadd zseta 3 c
+ r zadd zsetb 1 b
+ r zadd zsetb 2 c
+ r zadd zsetb 3 d
+
+ assert_equal 4 [r zunionstore zsetc 2 zseta zsetb]
+ assert_equal {a 1 b 3 d 3 c 5} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZUNIONSTORE with weights - $encoding" {
+ assert_equal 4 [r zunionstore zsetc 2 zseta zsetb weights 2 3]
+ assert_equal {a 2 b 7 d 9 c 12} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZUNIONSTORE with a regular set and weights - $encoding" {
+ r del seta
+ r sadd seta a
+ r sadd seta b
+ r sadd seta c
+
+ assert_equal 4 [r zunionstore zsetc 2 seta zsetb weights 2 3]
+ assert_equal {a 2 b 5 c 8 d 9} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZUNIONSTORE with AGGREGATE MIN - $encoding" {
+ assert_equal 4 [r zunionstore zsetc 2 zseta zsetb aggregate min]
+ assert_equal {a 1 b 1 c 2 d 3} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZUNIONSTORE with AGGREGATE MAX - $encoding" {
+ assert_equal 4 [r zunionstore zsetc 2 zseta zsetb aggregate max]
+ assert_equal {a 1 b 2 c 3 d 3} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZINTERSTORE basics - $encoding" {
+ assert_equal 2 [r zinterstore zsetc 2 zseta zsetb]
+ assert_equal {b 3 c 5} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZINTERSTORE with weights - $encoding" {
+ assert_equal 2 [r zinterstore zsetc 2 zseta zsetb weights 2 3]
+ assert_equal {b 7 c 12} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZINTERSTORE with a regular set and weights - $encoding" {
+ r del seta
+ r sadd seta a
+ r sadd seta b
+ r sadd seta c
+ assert_equal 2 [r zinterstore zsetc 2 seta zsetb weights 2 3]
+ assert_equal {b 5 c 8} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZINTERSTORE with AGGREGATE MIN - $encoding" {
+ assert_equal 2 [r zinterstore zsetc 2 zseta zsetb aggregate min]
+ assert_equal {b 1 c 2} [r zrange zsetc 0 -1 withscores]
+ }
+
+ test "ZINTERSTORE with AGGREGATE MAX - $encoding" {
+ assert_equal 2 [r zinterstore zsetc 2 zseta zsetb aggregate max]
+ assert_equal {b 2 c 3} [r zrange zsetc 0 -1 withscores]
+ }
+
+ foreach cmd {ZUNIONSTORE ZINTERSTORE} {
+ test "$cmd with +inf/-inf scores - $encoding" {
+ r del zsetinf1 zsetinf2
+
+ r zadd zsetinf1 +inf key
+ r zadd zsetinf2 +inf key
+ r $cmd zsetinf3 2 zsetinf1 zsetinf2
+ assert_equal inf [r zscore zsetinf3 key]
+
+ r zadd zsetinf1 -inf key
+ r zadd zsetinf2 +inf key
+ r $cmd zsetinf3 2 zsetinf1 zsetinf2
+ assert_equal 0 [r zscore zsetinf3 key]
+
+ r zadd zsetinf1 +inf key
+ r zadd zsetinf2 -inf key
+ r $cmd zsetinf3 2 zsetinf1 zsetinf2
+ assert_equal 0 [r zscore zsetinf3 key]
+
+ r zadd zsetinf1 -inf key
+ r zadd zsetinf2 -inf key
+ r $cmd zsetinf3 2 zsetinf1 zsetinf2
+ assert_equal -inf [r zscore zsetinf3 key]
+ }
+
+ test "$cmd with NaN weights $encoding" {
+ r del zsetinf1 zsetinf2
+
+ r zadd zsetinf1 1.0 key
+ r zadd zsetinf2 1.0 key
+ assert_error "*weight*not*float*" {
+ r $cmd zsetinf3 2 zsetinf1 zsetinf2 weights nan nan
+ }
+ }
+ }
+ }
+
+ basics ziplist
+ basics skiplist
+
+ test {ZINTERSTORE regression with two sets, intset+hashtable} {
+ r del seta setb setc
+ r sadd set1 a
+ r sadd set2 10
+ r zinterstore set3 2 set1 set2
+ } {0}
+
+ test {ZUNIONSTORE regression, should not create NaN in scores} {
+ r zadd z -inf neginf
+ r zunionstore out 1 z weights 0
+ r zrange out 0 -1 withscores
+ } {neginf 0}
+
+ test {ZINTERSTORE #516 regression, mixed sets and ziplist zsets} {
+ r sadd one 100 101 102 103
+ r sadd two 100 200 201 202
+ r zadd three 1 500 1 501 1 502 1 503 1 100
+ r zinterstore to_here 3 one two three WEIGHTS 0 0 1
+ r zrange to_here 0 -1
+ } {100}
+
+ test {ZUNIONSTORE result is sorted} {
+ # Create two sets with common and not common elements, perform
+ # the UNION, check that elements are still sorted.
+ r del one two dest
+ set cmd1 [list r zadd one]
+ set cmd2 [list r zadd two]
+ for {set j 0} {$j < 1000} {incr j} {
+ lappend cmd1 [expr rand()] [randomInt 1000]
+ lappend cmd2 [expr rand()] [randomInt 1000]
+ }
+ {*}$cmd1
+ {*}$cmd2
+ assert {[r zcard one] > 100}
+ assert {[r zcard two] > 100}
+ r zunionstore dest 2 one two
+ set oldscore 0
+ foreach {ele score} [r zrange dest 0 -1 withscores] {
+ assert {$score >= $oldscore}
+ set oldscore $score
+ }
+ }
+
+ proc stressers {encoding} {
+ if {$encoding == "ziplist"} {
+ # Little extra to allow proper fuzzing in the sorting stresser
+ r config set zset-max-ziplist-entries 256
+ r config set zset-max-ziplist-value 64
+ set elements 128
+ } elseif {$encoding == "skiplist"} {
+ r config set zset-max-ziplist-entries 0
+ r config set zset-max-ziplist-value 0
+ if {$::accurate} {set elements 1000} else {set elements 100}
+ } else {
+ puts "Unknown sorted set encoding"
+ exit
+ }
+
+ test "ZSCORE - $encoding" {
+ r del zscoretest
+ set aux {}
+ for {set i 0} {$i < $elements} {incr i} {
+ set score [expr rand()]
+ lappend aux $score
+ r zadd zscoretest $score $i
+ }
+
+ assert_encoding $encoding zscoretest
+ for {set i 0} {$i < $elements} {incr i} {
+ assert_equal [lindex $aux $i] [r zscore zscoretest $i]
+ }
+ }
+
+ test "ZSCORE after a DEBUG RELOAD - $encoding" {
+ r del zscoretest
+ set aux {}
+ for {set i 0} {$i < $elements} {incr i} {
+ set score [expr rand()]
+ lappend aux $score
+ r zadd zscoretest $score $i
+ }
+
+ r debug reload
+ assert_encoding $encoding zscoretest
+ for {set i 0} {$i < $elements} {incr i} {
+ assert_equal [lindex $aux $i] [r zscore zscoretest $i]
+ }
+ }
+
+ test "ZSET sorting stresser - $encoding" {
+ set delta 0
+ for {set test 0} {$test < 2} {incr test} {
+ unset -nocomplain auxarray
+ array set auxarray {}
+ set auxlist {}
+ r del myzset
+ for {set i 0} {$i < $elements} {incr i} {
+ if {$test == 0} {
+ set score [expr rand()]
+ } else {
+ set score [expr int(rand()*10)]
+ }
+ set auxarray($i) $score
+ r zadd myzset $score $i
+ # Random update
+ if {[expr rand()] < .2} {
+ set j [expr int(rand()*1000)]
+ if {$test == 0} {
+ set score [expr rand()]
+ } else {
+ set score [expr int(rand()*10)]
+ }
+ set auxarray($j) $score
+ r zadd myzset $score $j
+ }
+ }
+ foreach {item score} [array get auxarray] {
+ lappend auxlist [list $score $item]
+ }
+ set sorted [lsort -command zlistAlikeSort $auxlist]
+ set auxlist {}
+ foreach x $sorted {
+ lappend auxlist [lindex $x 1]
+ }
+
+ assert_encoding $encoding myzset
+ set fromredis [r zrange myzset 0 -1]
+ set delta 0
+ for {set i 0} {$i < [llength $fromredis]} {incr i} {
+ if {[lindex $fromredis $i] != [lindex $auxlist $i]} {
+ incr delta
+ }
+ }
+ }
+ assert_equal 0 $delta
+ }
+
+ test "ZRANGEBYSCORE fuzzy test, 100 ranges in $elements element sorted set - $encoding" {
+ set err {}
+ r del zset
+ for {set i 0} {$i < $elements} {incr i} {
+ r zadd zset [expr rand()] $i
+ }
+
+ assert_encoding $encoding zset
+ for {set i 0} {$i < 100} {incr i} {
+ set min [expr rand()]
+ set max [expr rand()]
+ if {$min > $max} {
+ set aux $min
+ set min $max
+ set max $aux
+ }
+ set low [r zrangebyscore zset -inf $min]
+ set ok [r zrangebyscore zset $min $max]
+ set high [r zrangebyscore zset $max +inf]
+ set lowx [r zrangebyscore zset -inf ($min]
+ set okx [r zrangebyscore zset ($min ($max]
+ set highx [r zrangebyscore zset ($max +inf]
+
+ if {[r zcount zset -inf $min] != [llength $low]} {
+ append err "Error, len does not match zcount\n"
+ }
+ if {[r zcount zset $min $max] != [llength $ok]} {
+ append err "Error, len does not match zcount\n"
+ }
+ if {[r zcount zset $max +inf] != [llength $high]} {
+ append err "Error, len does not match zcount\n"
+ }
+ if {[r zcount zset -inf ($min] != [llength $lowx]} {
+ append err "Error, len does not match zcount\n"
+ }
+ if {[r zcount zset ($min ($max] != [llength $okx]} {
+ append err "Error, len does not match zcount\n"
+ }
+ if {[r zcount zset ($max +inf] != [llength $highx]} {
+ append err "Error, len does not match zcount\n"
+ }
+
+ foreach x $low {
+ set score [r zscore zset $x]
+ if {$score > $min} {
+ append err "Error, score for $x is $score > $min\n"
+ }
+ }
+ foreach x $lowx {
+ set score [r zscore zset $x]
+ if {$score >= $min} {
+ append err "Error, score for $x is $score >= $min\n"
+ }
+ }
+ foreach x $ok {
+ set score [r zscore zset $x]
+ if {$score < $min || $score > $max} {
+ append err "Error, score for $x is $score outside $min-$max range\n"
+ }
+ }
+ foreach x $okx {
+ set score [r zscore zset $x]
+ if {$score <= $min || $score >= $max} {
+ append err "Error, score for $x is $score outside $min-$max open range\n"
+ }
+ }
+ foreach x $high {
+ set score [r zscore zset $x]
+ if {$score < $max} {
+ append err "Error, score for $x is $score < $max\n"
+ }
+ }
+ foreach x $highx {
+ set score [r zscore zset $x]
+ if {$score <= $max} {
+ append err "Error, score for $x is $score <= $max\n"
+ }
+ }
+ }
+ assert_equal {} $err
+ }
+
+ test "ZRANGEBYLEX fuzzy test, 100 ranges in $elements element sorted set - $encoding" {
+ set lexset {}
+ r del zset
+ for {set j 0} {$j < $elements} {incr j} {
+ set e [randstring 0 30 alpha]
+ lappend lexset $e
+ r zadd zset 0 $e
+ }
+ set lexset [lsort -unique $lexset]
+ for {set j 0} {$j < 100} {incr j} {
+ set min [randstring 0 30 alpha]
+ set max [randstring 0 30 alpha]
+ set mininc [randomInt 2]
+ set maxinc [randomInt 2]
+ if {$mininc} {set cmin "\[$min"} else {set cmin "($min"}
+ if {$maxinc} {set cmax "\[$max"} else {set cmax "($max"}
+ set rev [randomInt 2]
+ if {$rev} {
+ set cmd zrevrangebylex
+ } else {
+ set cmd zrangebylex
+ }
+
+ # Make sure data is the same in both sides
+ assert {[r zrange zset 0 -1] eq $lexset}
+
+ # Get the Redis output
+ set output [r $cmd zset $cmin $cmax]
+ if {$rev} {
+ set outlen [r zlexcount zset $cmax $cmin]
+ } else {
+ set outlen [r zlexcount zset $cmin $cmax]
+ }
+
+ # Compute the same output via Tcl
+ set o {}
+ set copy $lexset
+ if {(!$rev && [string compare $min $max] > 0) ||
+ ($rev && [string compare $max $min] > 0)} {
+ # Empty output when ranges are inverted.
+ } else {
+ if {$rev} {
+ # Invert the Tcl array using Redis itself.
+ set copy [r zrevrange zset 0 -1]
+ # Invert min / max as well
+ lassign [list $min $max $mininc $maxinc] \
+ max min maxinc mininc
+ }
+ foreach e $copy {
+ set mincmp [string compare $e $min]
+ set maxcmp [string compare $e $max]
+ if {
+ ($mininc && $mincmp >= 0 || !$mininc && $mincmp > 0)
+ &&
+ ($maxinc && $maxcmp <= 0 || !$maxinc && $maxcmp < 0)
+ } {
+ lappend o $e
+ }
+ }
+ }
+ assert {$o eq $output}
+ assert {$outlen eq [llength $output]}
+ }
+ }
+
+ test "ZREMRANGEBYLEX fuzzy test, 100 ranges in $elements element sorted set - $encoding" {
+ set lexset {}
+ r del zset zsetcopy
+ for {set j 0} {$j < $elements} {incr j} {
+ set e [randstring 0 30 alpha]
+ lappend lexset $e
+ r zadd zset 0 $e
+ }
+ set lexset [lsort -unique $lexset]
+ for {set j 0} {$j < 100} {incr j} {
+ # Copy...
+ r zunionstore zsetcopy 1 zset
+ set lexsetcopy $lexset
+
+ set min [randstring 0 30 alpha]
+ set max [randstring 0 30 alpha]
+ set mininc [randomInt 2]
+ set maxinc [randomInt 2]
+ if {$mininc} {set cmin "\[$min"} else {set cmin "($min"}
+ if {$maxinc} {set cmax "\[$max"} else {set cmax "($max"}
+
+ # Make sure data is the same in both sides
+ assert {[r zrange zset 0 -1] eq $lexset}
+
+ # Get the range we are going to remove
+ set torem [r zrangebylex zset $cmin $cmax]
+ set toremlen [r zlexcount zset $cmin $cmax]
+ r zremrangebylex zsetcopy $cmin $cmax
+ set output [r zrange zsetcopy 0 -1]
+
+ # Remove the range with Tcl from the original list
+ if {$toremlen} {
+ set first [lsearch -exact $lexsetcopy [lindex $torem 0]]
+ set last [expr {$first+$toremlen-1}]
+ set lexsetcopy [lreplace $lexsetcopy $first $last]
+ }
+ assert {$lexsetcopy eq $output}
+ }
+ }
+
+ test "ZSETs skiplist implementation backlink consistency test - $encoding" {
+ set diff 0
+ for {set j 0} {$j < $elements} {incr j} {
+ r zadd myzset [expr rand()] "Element-$j"
+ r zrem myzset "Element-[expr int(rand()*$elements)]"
+ }
+
+ assert_encoding $encoding myzset
+ set l1 [r zrange myzset 0 -1]
+ set l2 [r zrevrange myzset 0 -1]
+ for {set j 0} {$j < [llength $l1]} {incr j} {
+ if {[lindex $l1 $j] ne [lindex $l2 end-$j]} {
+ incr diff
+ }
+ }
+ assert_equal 0 $diff
+ }
+
+ test "ZSETs ZRANK augmented skip list stress testing - $encoding" {
+ set err {}
+ r del myzset
+ for {set k 0} {$k < 2000} {incr k} {
+ set i [expr {$k % $elements}]
+ if {[expr rand()] < .2} {
+ r zrem myzset $i
+ } else {
+ set score [expr rand()]
+ r zadd myzset $score $i
+ assert_encoding $encoding myzset
+ }
+
+ set card [r zcard myzset]
+ if {$card > 0} {
+ set index [randomInt $card]
+ set ele [lindex [r zrange myzset $index $index] 0]
+ set rank [r zrank myzset $ele]
+ if {$rank != $index} {
+ set err "$ele RANK is wrong! ($rank != $index)"
+ break
+ }
+ }
+ }
+ assert_equal {} $err
+ }
+ }
+
+ tags {"slow"} {
+ stressers ziplist
+ stressers skiplist
+ }
+}
diff --git a/tests/unit/wait.tcl b/tests/unit/wait.tcl
new file mode 100644
index 0000000..e2f5d29
--- /dev/null
+++ b/tests/unit/wait.tcl
@@ -0,0 +1,42 @@
+start_server {tags {"wait"}} {
+start_server {} {
+ set slave [srv 0 client]
+ set slave_host [srv 0 host]
+ set slave_port [srv 0 port]
+ set master [srv -1 client]
+ set master_host [srv -1 host]
+ set master_port [srv -1 port]
+
+ test {Setup slave} {
+ $slave slaveof $master_host $master_port
+ wait_for_condition 50 100 {
+ [s 0 master_link_status] eq {up}
+ } else {
+ fail "Replication not started."
+ }
+ }
+
+ test {WAIT should acknowledge 1 additional copy of the data} {
+ $master set foo 0
+ $master incr foo
+ $master incr foo
+ $master incr foo
+ assert {[$master wait 1 5000] == 1}
+ assert {[$slave get foo] == 3}
+ }
+
+ test {WAIT should not acknowledge 2 additional copies of the data} {
+ $master incr foo
+ assert {[$master wait 2 1000] <= 1}
+ }
+
+ test {WAIT should not acknowledge 1 additional copy if slave is blocked} {
+ exec src/redis-cli -h $slave_host -p $slave_port debug sleep 5 > /dev/null 2> /dev/null &
+ after 1000 ;# Give redis-cli the time to execute the command.
+ $master set foo 0
+ $master incr foo
+ $master incr foo
+ $master incr foo
+ assert {[$master wait 1 3000] == 0}
+ }
+}}