├── .gitignore ├── tcltests ├── assets │ ├── nodefaultuser.acl │ ├── userwithselectors.acl │ ├── encodings.rdb │ ├── hash-zipmap.rdb │ ├── hash-ziplist.rdb │ ├── list-quicklist.rdb │ ├── scriptbackup.rdb │ ├── zset-ziplist.rdb │ ├── corrupt_ziplist.rdb │ ├── corrupt_empty_keys.rdb │ ├── minimal.conf │ ├── user.acl │ ├── default.conf │ └── test_cli_hint_suite.txt ├── redis-cli ├── helpers │ ├── bg_complex_data.tcl │ ├── gen_write_load.tcl │ ├── bg_block_op.tcl │ └── fake_redis_node.tcl ├── support │ ├── tmpfile.tcl │ ├── benchmark.tcl │ ├── cli.tcl │ ├── response_transformers.tcl │ ├── aofmanifest.tcl │ ├── cluster_util.tcl │ ├── test.tcl │ ├── cluster.tcl │ ├── redis.tcl │ ├── server.tcl │ └── util.tcl ├── unit │ └── keyspace.tcl ├── integration │ └── redis-cli.tcl └── test_helper.tcl ├── README.md ├── runtest ├── dice-patch └── tcltest.patch └── tcltest /.gitignore: -------------------------------------------------------------------------------- 1 | .rediscli_history_test 2 | .idea/ 3 | -------------------------------------------------------------------------------- /tcltests/assets/nodefaultuser.acl: -------------------------------------------------------------------------------- 1 | user alice on nopass ~* +@all 2 | user bob on nopass ~* &* +@all -------------------------------------------------------------------------------- /tcltests/redis-cli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/redis-cli -------------------------------------------------------------------------------- /tcltests/assets/userwithselectors.acl: -------------------------------------------------------------------------------- 1 | user alice on (+get ~rw*) 2 | user bob on (+set %W~w*) (+get %R~r*) -------------------------------------------------------------------------------- /tcltests/assets/encodings.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/encodings.rdb -------------------------------------------------------------------------------- /tcltests/assets/hash-zipmap.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/hash-zipmap.rdb -------------------------------------------------------------------------------- /tcltests/assets/hash-ziplist.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/hash-ziplist.rdb -------------------------------------------------------------------------------- /tcltests/assets/list-quicklist.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/list-quicklist.rdb -------------------------------------------------------------------------------- /tcltests/assets/scriptbackup.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/scriptbackup.rdb -------------------------------------------------------------------------------- /tcltests/assets/zset-ziplist.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/zset-ziplist.rdb -------------------------------------------------------------------------------- /tcltests/assets/corrupt_ziplist.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/corrupt_ziplist.rdb -------------------------------------------------------------------------------- /tcltests/assets/corrupt_empty_keys.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arpitbbhayani/dice-tests/HEAD/tcltests/assets/corrupt_empty_keys.rdb -------------------------------------------------------------------------------- /tcltests/assets/minimal.conf: -------------------------------------------------------------------------------- 1 | # Minimal configuration for testing. 2 | always-show-logo yes 3 | daemonize no 4 | pidfile /var/run/redis.pid 5 | loglevel verbose 6 | -------------------------------------------------------------------------------- /tcltests/assets/user.acl: -------------------------------------------------------------------------------- 1 | user alice on allcommands allkeys &* >alice 2 | user bob on -@all +@set +acl ~set* &* >bob 3 | user doug on resetchannels &test +@all ~* >doug 4 | user default on nopass ~* &* +@all 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # dice-tests 2 | This repository consists of test suite required for dice db 3 | 4 | ## Steps to run test against dice-db 5 | - `./tcltest` 6 | - If `git` is not configured then: 7 | - Clone dice-db [repo](https://github.com/DiceDB/dice) 8 | - `./tcltest ` 9 | -------------------------------------------------------------------------------- /runtest: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | TCL_VERSIONS="8.5 8.6 8.7" 3 | TCLSH="" 4 | 5 | for VERSION in $TCL_VERSIONS; do 6 | TCL=`which tclsh$VERSION 2>/dev/null` && TCLSH=$TCL 7 | done 8 | 9 | if [ -z $TCLSH ] 10 | then 11 | echo "You need tcl 8.5 or newer in order to run the Redis test" 12 | exit 1 13 | fi 14 | $TCLSH tcltests/test_helper.tcl "${@}" 15 | -------------------------------------------------------------------------------- /tcltests/helpers/bg_complex_data.tcl: -------------------------------------------------------------------------------- 1 | source tests/support/redis.tcl 2 | source tests/support/util.tcl 3 | 4 | set ::tlsdir "tests/tls" 5 | 6 | proc bg_complex_data {host port db ops tls} { 7 | set r [redis $host $port 0 $tls] 8 | $r client setname LOAD_HANDLER 9 | $r select $db 10 | createComplexDataset $r $ops 11 | } 12 | 13 | bg_complex_data [lindex $argv 0] [lindex $argv 1] [lindex $argv 2] [lindex $argv 3] [lindex $argv 4] 14 | -------------------------------------------------------------------------------- /tcltests/support/tmpfile.tcl: -------------------------------------------------------------------------------- 1 | set ::tmpcounter 0 2 | set ::tmproot "./tests/tmp" 3 | file mkdir $::tmproot 4 | 5 | # returns a dirname unique to this process to write to 6 | proc tmpdir {basename} { 7 | set dir [file join $::tmproot $basename.[pid].[incr ::tmpcounter]] 8 | file mkdir $dir 9 | set _ $dir 10 | } 11 | 12 | # return a filename unique to this process to write to 13 | proc tmpfile {basename} { 14 | file join $::tmproot $basename.[pid].[incr ::tmpcounter] 15 | } 16 | -------------------------------------------------------------------------------- /tcltests/helpers/gen_write_load.tcl: -------------------------------------------------------------------------------- 1 | source tests/support/redis.tcl 2 | 3 | set ::tlsdir "tests/tls" 4 | 5 | proc gen_write_load {host port seconds tls} { 6 | set start_time [clock seconds] 7 | set r [redis $host $port 1 $tls] 8 | $r client setname LOAD_HANDLER 9 | $r select 9 10 | while 1 { 11 | $r set [expr rand()] [expr rand()] 12 | if {[clock seconds]-$start_time > $seconds} { 13 | exit 0 14 | } 15 | } 16 | } 17 | 18 | gen_write_load [lindex $argv 0] [lindex $argv 1] [lindex $argv 2] [lindex $argv 3] 19 | -------------------------------------------------------------------------------- /tcltests/assets/default.conf: -------------------------------------------------------------------------------- 1 | # Redis configuration for testing. 2 | 3 | always-show-logo yes 4 | notify-keyspace-events KEA 5 | daemonize no 6 | pidfile /var/run/redis.pid 7 | port 6379 8 | timeout 0 9 | bind 127.0.0.1 10 | loglevel verbose 11 | logfile '' 12 | databases 16 13 | latency-monitor-threshold 1 14 | repl-diskless-sync-delay 0 15 | 16 | # Turn off RDB by default (to speedup tests) 17 | # Note the infrastructure in server.tcl uses a dict, we can't provide several save directives 18 | save '' 19 | 20 | rdbcompression yes 21 | dbfilename dump.rdb 22 | dir ./ 23 | 24 | slave-serve-stale-data yes 25 | appendonly no 26 | appendfsync everysec 27 | no-appendfsync-on-rewrite no 28 | activerehashing yes 29 | 30 | enable-protected-configs yes 31 | enable-debug-command yes 32 | enable-module-command yes 33 | 34 | propagation-error-behavior panic 35 | 36 | # Make sure shutdown doesn't fail if there's an initial AOFRW 37 | shutdown-on-sigterm force 38 | -------------------------------------------------------------------------------- /tcltests/support/benchmark.tcl: -------------------------------------------------------------------------------- 1 | proc redisbenchmark_tls_config {testsdir} { 2 | set tlsdir [file join $testsdir tls] 3 | set cert [file join $tlsdir client.crt] 4 | set key [file join $tlsdir client.key] 5 | set cacert [file join $tlsdir ca.crt] 6 | 7 | if {$::tls} { 8 | return [list --tls --cert $cert --key $key --cacert $cacert] 9 | } else { 10 | return {} 11 | } 12 | } 13 | 14 | proc redisbenchmark {host port {opts {}}} { 15 | set cmd [list src/redis-benchmark -h $host -p $port] 16 | lappend cmd {*}[redisbenchmark_tls_config "tests"] 17 | lappend cmd {*}$opts 18 | return $cmd 19 | } 20 | 21 | proc redisbenchmarkuri {host port {opts {}}} { 22 | set cmd [list src/redis-benchmark -u redis://$host:$port] 23 | lappend cmd {*}[redisbenchmark_tls_config "tests"] 24 | lappend cmd {*}$opts 25 | return $cmd 26 | } 27 | 28 | proc redisbenchmarkuriuserpass {host port user pass {opts {}}} { 29 | set cmd [list src/redis-benchmark -u redis://$user:$pass@$host:$port] 30 | lappend cmd {*}[redisbenchmark_tls_config "tests"] 31 | lappend cmd {*}$opts 32 | return $cmd 33 | } 34 | -------------------------------------------------------------------------------- /tcltests/support/cli.tcl: -------------------------------------------------------------------------------- 1 | proc rediscli_tls_config {testsdir} { 2 | set tlsdir [file join $testsdir tls] 3 | set cert [file join $tlsdir client.crt] 4 | set key [file join $tlsdir client.key] 5 | set cacert [file join $tlsdir ca.crt] 6 | 7 | if {$::tls} { 8 | return [list --tls --cert $cert --key $key --cacert $cacert] 9 | } else { 10 | return {} 11 | } 12 | } 13 | 14 | # Returns command line for executing redis-cli 15 | proc rediscli {host port {opts {}}} { 16 | set cmd [list tcltests/redis-cli -h $host -p $port] 17 | lappend cmd {*}[rediscli_tls_config "tests"] 18 | lappend cmd {*}$opts 19 | return $cmd 20 | } 21 | 22 | # Returns command line for executing redis-cli with a unix socket address 23 | proc rediscli_unixsocket {unixsocket {opts {}}} { 24 | return [list tcltests/redis-cli -s $unixsocket {*}$opts] 25 | } 26 | 27 | # Run redis-cli with specified args on the server of specified level. 28 | # Returns output broken down into individual lines. 29 | proc rediscli_exec {level args} { 30 | set cmd [rediscli_unixsocket [srv $level unixsocket] $args] 31 | set fd [open "|$cmd" "r"] 32 | set ret [lrange [split [read $fd] "\n"] 0 end-1] 33 | close $fd 34 | 35 | return $ret 36 | } 37 | -------------------------------------------------------------------------------- /tcltests/helpers/bg_block_op.tcl: -------------------------------------------------------------------------------- 1 | source tests/support/redis.tcl 2 | source tests/support/util.tcl 3 | 4 | set ::tlsdir "tests/tls" 5 | 6 | # This function sometimes writes sometimes blocking-reads from lists/sorted 7 | # sets. There are multiple processes like this executing at the same time 8 | # so that we have some chance to trap some corner condition if there is 9 | # a regression. For this to happen it is important that we narrow the key 10 | # space to just a few elements, and balance the operations so that it is 11 | # unlikely that lists and zsets just get more data without ever causing 12 | # blocking. 13 | proc bg_block_op {host port db ops tls} { 14 | set r [redis $host $port 0 $tls] 15 | $r client setname LOAD_HANDLER 16 | $r select $db 17 | 18 | for {set j 0} {$j < $ops} {incr j} { 19 | 20 | # List side 21 | set k list_[randomInt 10] 22 | set k2 list_[randomInt 10] 23 | set v [randomValue] 24 | 25 | randpath { 26 | randpath { 27 | $r rpush $k $v 28 | } { 29 | $r lpush $k $v 30 | } 31 | } { 32 | $r blpop $k 2 33 | } { 34 | $r blpop $k $k2 2 35 | } 36 | 37 | # Zset side 38 | set k zset_[randomInt 10] 39 | set k2 zset_[randomInt 10] 40 | set v1 [randomValue] 41 | set v2 [randomValue] 42 | 43 | randpath { 44 | $r zadd $k [randomInt 10000] $v 45 | } { 46 | $r zadd $k [randomInt 10000] $v [randomInt 10000] $v2 47 | } { 48 | $r bzpopmin $k 2 49 | } { 50 | $r bzpopmax $k 2 51 | } 52 | } 53 | } 54 | 55 | bg_block_op [lindex $argv 0] [lindex $argv 1] [lindex $argv 2] [lindex $argv 3] [lindex $argv 4] 56 | -------------------------------------------------------------------------------- /tcltests/helpers/fake_redis_node.tcl: -------------------------------------------------------------------------------- 1 | # A fake Redis node for replaying predefined/expected traffic with a client. 2 | # 3 | # Usage: tclsh fake_redis_node.tcl PORT COMMAND REPLY [ COMMAND REPLY [ ... ] ] 4 | # 5 | # Commands are given as space-separated strings, e.g. "GET foo", and replies as 6 | # RESP-encoded replies minus the trailing \r\n, e.g. "+OK". 7 | 8 | set port [lindex $argv 0]; 9 | set expected_traffic [lrange $argv 1 end]; 10 | 11 | # Reads and parses a command from a socket and returns it as a space-separated 12 | # string, e.g. "set foo bar". 13 | proc read_command {sock} { 14 | set char [read $sock 1] 15 | switch $char { 16 | * { 17 | set numargs [gets $sock] 18 | set result {} 19 | for {set i 0} {$i<$numargs} {incr i} { 20 | read $sock 1; # dollar sign 21 | set len [gets $sock] 22 | set str [read $sock $len] 23 | gets $sock; # trailing \r\n 24 | lappend result $str 25 | } 26 | return $result 27 | } 28 | {} { 29 | # EOF 30 | return {} 31 | } 32 | default { 33 | # Non-RESP command 34 | set rest [gets $sock] 35 | return "$char$rest" 36 | } 37 | } 38 | } 39 | 40 | proc accept {sock host port} { 41 | global expected_traffic 42 | foreach {expect_cmd reply} $expected_traffic { 43 | if {[eof $sock]} {break} 44 | set cmd [read_command $sock] 45 | if {[string equal -nocase $cmd $expect_cmd]} { 46 | puts $sock $reply 47 | flush $sock 48 | } else { 49 | puts $sock "-ERR unexpected command $cmd" 50 | break 51 | } 52 | } 53 | close $sock 54 | } 55 | 56 | set sockfd [socket -server accept -myaddr 127.0.0.1 $port] 57 | after 5000 set done timeout 58 | vwait done 59 | close $sockfd 60 | 61 | -------------------------------------------------------------------------------- /dice-patch/tcltest.patch: -------------------------------------------------------------------------------- 1 | diff --git a/internal/constants/constants.go b/internal/constants/constants.go 2 | index 8cf4e54..396c637 100644 3 | --- a/internal/constants/constants.go 4 | +++ b/internal/constants/constants.go 5 | @@ -52,3 +52,27 @@ const ( 6 | Set string = "set" 7 | Del string = "del" 8 | ) 9 | + 10 | +// Temporary set for ignoring these commands while tcl tests. 11 | +// Once these commands are implemented we can remove them from the set one by one. 12 | +var IgnoreCommands = map[string]string{ 13 | + "SELECT": "ignore for tcl test", 14 | + "FUNCTION": "ignore for tcl test", 15 | + "FLUSHALL": "ignore for tcl test", 16 | + "RPUSH": "ignore for tcl test", 17 | + "HGET": "ignore for tcl test", 18 | + "LRANGE": "ignore for tcl test", 19 | + "ACL": "ignore for tcl test", 20 | + "FLUSHDB": "ignore for tcl test", 21 | + "SCAN": "ignore for tcl test", 22 | + "SCARD": "ignore for tcl test", 23 | + "SLAVEOF": "ignore for tcl test", 24 | + "BLPOP": "ignore for tcl test", 25 | + "ZADD": "ignore for tcl test", 26 | + "BZPOPMIN": "ignore for tcl test", 27 | + "BZPOPMAX": "ignore for tcl test", 28 | + "DEBUG": "ignore for tcl test", 29 | + "REPLICAOF": "ignore for tcl test", 30 | + "SAVE": "ignore for tcl test", 31 | + "CONFIG": "ignore for tcl test", 32 | +} 33 | diff --git a/internal/shard/shard_thread.go b/internal/shard/shard_thread.go 34 | index 09d65d5..82103b8 100644 35 | --- a/internal/shard/shard_thread.go 36 | +++ b/internal/shard/shard_thread.go 37 | @@ -3,6 +3,9 @@ package shard 38 | import ( 39 | "context" 40 | "fmt" 41 | + "github.com/dicedb/dice/internal/constants" 42 | + "os" 43 | + "strconv" 44 | "strings" 45 | "sync" 46 | "time" 47 | @@ -105,6 +108,19 @@ func (shard *ShardThread) processRequest(op *ops.StoreOp) { 48 | func (shard *ShardThread) executeCommand(op *ops.StoreOp) []byte { 49 | diceCmd, ok := eval.DiceCmds[op.Cmd.Cmd] 50 | if !ok { 51 | + // Temporary workaround for redis tcl commands 52 | + // To run the tcl tests need to set env variable 53 | + runTclTests, err := strconv.ParseBool(os.Getenv("TCL_TESTS")) 54 | + if err != nil { 55 | + runTclTests = false 56 | + } 57 | + 58 | + // if env variable is set, then only ignore unknown commands 59 | + if runTclTests { 60 | + if _, exists := constants.IgnoreCommands[op.Cmd.Cmd]; exists { 61 | + return clientio.RespOK 62 | + } 63 | + } 64 | return diceerrors.NewErrWithFormattedMessage("unknown command '%s', with args beginning with: %s", op.Cmd.Cmd, strings.Join(op.Cmd.Args, " ")) 65 | } 66 | 67 | -------------------------------------------------------------------------------- /tcltest: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Variables 4 | WORK_DIR=$(pwd) 5 | SERVER_HOST=127.0.0.1 6 | REPO_URL="git@github.com:DiceDB/dice.git" 7 | CLONE_DIR="dice" # Directory to clone into if no arg is provided 8 | SERVER_PORT=7379 9 | SERVER_CMD="air" 10 | TEST_CMD="./runtest --host $SERVER_HOST --port $SERVER_PORT --tags -needs:debug --tags -cluster:skip --singledb --ignore-encoding" 11 | SERVER_PID_FILE="$WORK_DIR/server.pid" 12 | PATCH_DIR="dice-patch" 13 | PATCH_FILE_NAME="tcltest.patch" 14 | ABS_PATH_PATCH_FILE="$WORK_DIR/$PATCH_DIR/$PATCH_FILE_NAME" 15 | 16 | # Function to clone the repository 17 | clone_repo() { 18 | if [ -d "$CLONE_DIR" ]; then 19 | echo "Directory '$CLONE_DIR' exists. Removing it to fetch latest master." 20 | rm -rf "$CLONE_DIR" 21 | fi 22 | git clone "$REPO_URL" "$CLONE_DIR" || { echo "Error cloning repository."; exit 1; } 23 | } 24 | 25 | # Function to apply patch 26 | apply_patch() { 27 | git apply "$ABS_PATH_PATCH_FILE" || { echo "Patch apply failed. Aborting."; exit 1; } 28 | echo "Patch applied successfully." 29 | } 30 | 31 | # Function to start the server 32 | start_server() { 33 | export TCL_TESTS=true 34 | if ! command -v air &>/dev/null; then 35 | echo "'air' not found, running 'go run main.go'..." 36 | go run main.go & 37 | else 38 | echo "'air' found, running 'air'..." 39 | $SERVER_CMD & 40 | fi 41 | SERVER_PID=$! 42 | echo "$SERVER_PID" > "$SERVER_PID_FILE" 43 | sleep 5 # Adjust based on server startup time 44 | } 45 | 46 | # Function to run tests 47 | run_tests() { 48 | echo "Running tests..." 49 | $TEST_CMD 50 | return $? 51 | } 52 | 53 | # Function to stop server 54 | stop_server() { 55 | echo "Stopping the server..." 56 | kill "$SERVER_PID" 57 | rm -f "$SERVER_PID_FILE" 58 | } 59 | 60 | # Main script execution 61 | if [ -z "$1" ]; then 62 | echo "No directory path provided. Cloning repository..." 63 | clone_repo 64 | TARGET_DIR="$CLONE_DIR" 65 | else 66 | TARGET_DIR="$1" 67 | fi 68 | 69 | # Ensure target directory exists 70 | if [ ! -d "$TARGET_DIR" ]; then 71 | echo "Error: Directory '$TARGET_DIR' does not exist." 72 | exit 1 73 | fi 74 | 75 | # Navigate to target directory and apply patch 76 | cd "$TARGET_DIR" || exit 77 | apply_patch 78 | 79 | # Start the server 80 | start_server 81 | 82 | # Switch back to working directory and run tests 83 | cd "$WORK_DIR" 84 | run_tests 85 | TEST_EXIT_CODE=$? 86 | 87 | # Stop the server 88 | stop_server 89 | 90 | # Remove the cloned directory if we cloned it 91 | if [ "$TARGET_DIR" == "$CLONE_DIR" ]; then 92 | echo "Removing cloned directory '$CLONE_DIR'..." 93 | rm -rf "$CLONE_DIR" 94 | fi 95 | 96 | # Exit with test command exit code 97 | exit $TEST_EXIT_CODE 98 | -------------------------------------------------------------------------------- /tcltests/support/response_transformers.tcl: -------------------------------------------------------------------------------- 1 | # Tcl client library - used by the Redis test 2 | # 3 | # Copyright (C) 2009-Present, Redis Ltd. 4 | # All Rights reserved. 5 | # 6 | # Licensed under your choice of the Redis Source Available License 2.0 7 | # (RSALv2) or the Server Side Public License v1 (SSPLv1). 8 | # 9 | # This file contains a bunch of commands whose purpose is to transform 10 | # a RESP3 response to RESP2 11 | # Why is it needed? 12 | # When writing the reply_schema part in COMMAND DOCS we decided to use 13 | # the existing tests in order to verify the schemas (see logreqres.c) 14 | # The problem was that many tests were relying on the RESP2 structure 15 | # of the response (e.g. HRANDFIELD WITHVALUES in RESP2: {f1 v1 f2 v2} 16 | # vs. RESP3: {{f1 v1} {f2 v2}}). 17 | # Instead of adjusting the tests to expect RESP3 responses (a lot of 18 | # changes in many files) we decided to transform the response to RESP2 19 | # when running with --force-resp3 20 | 21 | package require Tcl 8.5 22 | 23 | namespace eval response_transformers {} 24 | 25 | # Transform a map response into an array of tuples (tuple = array with 2 elements) 26 | # Used for XREAD[GROUP] 27 | proc transfrom_map_to_tupple_array {argv response} { 28 | set tuparray {} 29 | foreach {key val} $response { 30 | set tmp {} 31 | lappend tmp $key 32 | lappend tmp $val 33 | lappend tuparray $tmp 34 | } 35 | return $tuparray 36 | } 37 | 38 | # Transform an array of tuples to a flat array 39 | proc transfrom_tuple_array_to_flat_array {argv response} { 40 | set flatarray {} 41 | foreach pair $response { 42 | lappend flatarray {*}$pair 43 | } 44 | return $flatarray 45 | } 46 | 47 | # With HRANDFIELD, we only need to transform the response if the request had WITHVALUES 48 | # (otherwise the returned response is a flat array in both RESPs) 49 | proc transfrom_hrandfield_command {argv response} { 50 | foreach ele $argv { 51 | if {[string compare -nocase $ele "WITHVALUES"] == 0} { 52 | return [transfrom_tuple_array_to_flat_array $argv $response] 53 | } 54 | } 55 | return $response 56 | } 57 | 58 | # With some zset commands, we only need to transform the response if the request had WITHSCORES 59 | # (otherwise the returned response is a flat array in both RESPs) 60 | proc transfrom_zset_withscores_command {argv response} { 61 | foreach ele $argv { 62 | if {[string compare -nocase $ele "WITHSCORES"] == 0} { 63 | return [transfrom_tuple_array_to_flat_array $argv $response] 64 | } 65 | } 66 | return $response 67 | } 68 | 69 | # With ZPOPMIN/ZPOPMAX, we only need to transform the response if the request had COUNT (3rd arg) 70 | # (otherwise the returned response is a flat array in both RESPs) 71 | proc transfrom_zpopmin_zpopmax {argv response} { 72 | if {[llength $argv] == 3} { 73 | return [transfrom_tuple_array_to_flat_array $argv $response] 74 | } 75 | return $response 76 | } 77 | 78 | set ::trasformer_funcs { 79 | XREAD transfrom_map_to_tupple_array 80 | XREADGROUP transfrom_map_to_tupple_array 81 | HRANDFIELD transfrom_hrandfield_command 82 | ZRANDMEMBER transfrom_zset_withscores_command 83 | ZRANGE transfrom_zset_withscores_command 84 | ZRANGEBYSCORE transfrom_zset_withscores_command 85 | ZRANGEBYLEX transfrom_zset_withscores_command 86 | ZREVRANGE transfrom_zset_withscores_command 87 | ZREVRANGEBYSCORE transfrom_zset_withscores_command 88 | ZREVRANGEBYLEX transfrom_zset_withscores_command 89 | ZUNION transfrom_zset_withscores_command 90 | ZDIFF transfrom_zset_withscores_command 91 | ZINTER transfrom_zset_withscores_command 92 | ZPOPMIN transfrom_zpopmin_zpopmax 93 | ZPOPMAX transfrom_zpopmin_zpopmax 94 | } 95 | 96 | proc ::response_transformers::transform_response_if_needed {id argv response} { 97 | if {![::redis::should_transform_to_resp2 $id] || $::redis::readraw($id)} { 98 | return $response 99 | } 100 | 101 | set key [string toupper [lindex $argv 0]] 102 | if {![dict exists $::trasformer_funcs $key]} { 103 | return $response 104 | } 105 | 106 | set transform [dict get $::trasformer_funcs $key] 107 | 108 | return [$transform $argv $response] 109 | } 110 | -------------------------------------------------------------------------------- /tcltests/support/aofmanifest.tcl: -------------------------------------------------------------------------------- 1 | set ::base_aof_sufix ".base" 2 | set ::incr_aof_sufix ".incr" 3 | set ::manifest_suffix ".manifest" 4 | set ::aof_format_suffix ".aof" 5 | set ::rdb_format_suffix ".rdb" 6 | 7 | proc get_full_path {dir filename} { 8 | set _ [format "%s/%s" $dir $filename] 9 | } 10 | 11 | proc join_path {dir1 dir2} { 12 | return [format "%s/%s" $dir1 $dir2] 13 | } 14 | 15 | proc get_redis_dir {} { 16 | set config [srv config] 17 | set _ [dict get $config "dir"] 18 | } 19 | 20 | proc check_file_exist {dir filename} { 21 | set file_path [get_full_path $dir $filename] 22 | return [file exists $file_path] 23 | } 24 | 25 | proc del_file {dir filename} { 26 | set file_path [get_full_path $dir $filename] 27 | catch {exec rm -rf $file_path} 28 | } 29 | 30 | proc get_cur_base_aof_name {manifest_filepath} { 31 | set fp [open $manifest_filepath r+] 32 | set lines {} 33 | while {1} { 34 | set line [gets $fp] 35 | if {[eof $fp]} { 36 | close $fp 37 | break; 38 | } 39 | 40 | lappend lines $line 41 | } 42 | 43 | if {[llength $lines] == 0} { 44 | return "" 45 | } 46 | 47 | set first_line [lindex $lines 0] 48 | set aofname [lindex [split $first_line " "] 1] 49 | set aoftype [lindex [split $first_line " "] 5] 50 | if { $aoftype eq "b" } { 51 | return $aofname 52 | } 53 | 54 | return "" 55 | } 56 | 57 | proc get_last_incr_aof_name {manifest_filepath} { 58 | set fp [open $manifest_filepath r+] 59 | set lines {} 60 | while {1} { 61 | set line [gets $fp] 62 | if {[eof $fp]} { 63 | close $fp 64 | break; 65 | } 66 | 67 | lappend lines $line 68 | } 69 | 70 | if {[llength $lines] == 0} { 71 | return "" 72 | } 73 | 74 | set len [llength $lines] 75 | set last_line [lindex $lines [expr $len - 1]] 76 | set aofname [lindex [split $last_line " "] 1] 77 | set aoftype [lindex [split $last_line " "] 5] 78 | if { $aoftype eq "i" } { 79 | return $aofname 80 | } 81 | 82 | return "" 83 | } 84 | 85 | proc get_last_incr_aof_path {r} { 86 | set dir [lindex [$r config get dir] 1] 87 | set appenddirname [lindex [$r config get appenddirname] 1] 88 | set appendfilename [lindex [$r config get appendfilename] 1] 89 | set manifest_filepath [file join $dir $appenddirname $appendfilename$::manifest_suffix] 90 | set last_incr_aof_name [get_last_incr_aof_name $manifest_filepath] 91 | if {$last_incr_aof_name == ""} { 92 | return "" 93 | } 94 | return [file join $dir $appenddirname $last_incr_aof_name] 95 | } 96 | 97 | proc get_base_aof_path {r} { 98 | set dir [lindex [$r config get dir] 1] 99 | set appenddirname [lindex [$r config get appenddirname] 1] 100 | set appendfilename [lindex [$r config get appendfilename] 1] 101 | set manifest_filepath [file join $dir $appenddirname $appendfilename$::manifest_suffix] 102 | set cur_base_aof_name [get_cur_base_aof_name $manifest_filepath] 103 | if {$cur_base_aof_name == ""} { 104 | return "" 105 | } 106 | return [file join $dir $appenddirname $cur_base_aof_name] 107 | } 108 | 109 | proc assert_aof_manifest_content {manifest_path content} { 110 | set fp [open $manifest_path r+] 111 | set lines {} 112 | while {1} { 113 | set line [gets $fp] 114 | if {[eof $fp]} { 115 | close $fp 116 | break; 117 | } 118 | 119 | lappend lines $line 120 | } 121 | 122 | assert_equal [llength $lines] [llength $content] 123 | 124 | for { set i 0 } { $i < [llength $lines] } {incr i} { 125 | assert_equal [lindex $lines $i] [lindex $content $i] 126 | } 127 | } 128 | 129 | proc clean_aof_persistence {aof_dirpath} { 130 | catch {eval exec rm -rf [glob $aof_dirpath]} 131 | } 132 | 133 | proc append_to_manifest {str} { 134 | upvar fp fp 135 | puts -nonewline $fp $str 136 | } 137 | 138 | proc create_aof_manifest {dir aof_manifest_file code} { 139 | create_aof_dir $dir 140 | upvar fp fp 141 | set fp [open $aof_manifest_file w+] 142 | uplevel 1 $code 143 | close $fp 144 | } 145 | 146 | proc append_to_aof {str} { 147 | upvar fp fp 148 | puts -nonewline $fp $str 149 | } 150 | 151 | proc create_aof {dir aof_file code} { 152 | create_aof_dir $dir 153 | upvar fp fp 154 | set fp [open $aof_file w+] 155 | uplevel 1 $code 156 | close $fp 157 | } 158 | 159 | proc create_aof_dir {dir_path} { 160 | file mkdir $dir_path 161 | } 162 | 163 | proc start_server_aof {overrides code} { 164 | upvar defaults defaults srv srv server_path server_path aof_basename aof_basename aof_dirpath aof_dirpath aof_manifest_file aof_manifest_file aof_manifest_file2 aof_manifest_file2 165 | set config [concat $defaults $overrides] 166 | start_server [list overrides $config keep_persistence true] $code 167 | } 168 | 169 | proc start_server_aof_ex {overrides options code} { 170 | upvar defaults defaults srv srv server_path server_path 171 | set config [concat $defaults $overrides] 172 | start_server [concat [list overrides $config keep_persistence true] $options] $code 173 | } 174 | -------------------------------------------------------------------------------- /tcltests/assets/test_cli_hint_suite.txt: -------------------------------------------------------------------------------- 1 | # Test suite for redis-cli command-line hinting mechanism. 2 | # Each test case consists of two strings: a (partial) input command line, and the expected hint string. 3 | 4 | # Command with one arg: GET key 5 | "GET " "key" 6 | "GET abc " "" 7 | 8 | # Command with two args: DECRBY key decrement 9 | "DECRBY xyz 2 " "" 10 | "DECRBY xyz " "decrement" 11 | "DECRBY " "key decrement" 12 | 13 | # Command with optional arg: LPOP key [count] 14 | "LPOP key " "[count]" 15 | "LPOP key 3 " "" 16 | 17 | # Command with optional token arg: XRANGE key start end [COUNT count] 18 | "XRANGE " "key start end [COUNT count]" 19 | "XRANGE k 4 2 " "[COUNT count]" 20 | "XRANGE k 4 2 COU" "[COUNT count]" 21 | "XRANGE k 4 2 COUNT" "[COUNT count]" 22 | "XRANGE k 4 2 COUNT " "count" 23 | 24 | # Command with optional token block arg: BITFIELD_RO key [GET encoding offset [GET encoding offset ...]] 25 | "BITFIELD_RO k " "[GET encoding offset [GET encoding offset ...]]" 26 | "BITFIELD_RO k GE" "[GET encoding offset [GET encoding offset ...]]" 27 | "BITFIELD_RO k GET" "[GET encoding offset [GET encoding offset ...]]" 28 | # TODO: The following hints end with an unbalanced "]" which shouldn't be there. 29 | "BITFIELD_RO k GET " "encoding offset [GET encoding offset ...]]" 30 | "BITFIELD_RO k GET xyz " "offset [GET encoding offset ...]]" 31 | "BITFIELD_RO k GET xyz 12 " "[GET encoding offset ...]]" 32 | "BITFIELD_RO k GET xyz 12 GET " "encoding offset [GET encoding offset ...]]" 33 | "BITFIELD_RO k GET enc1 12 GET enc2 " "offset [GET encoding offset ...]]" 34 | "BITFIELD_RO k GET enc1 12 GET enc2 34 " "[GET encoding offset ...]]" 35 | 36 | # Two-word command with multiple non-token block args: CONFIG SET parameter value [parameter value ...] 37 | "CONFIG SET param " "value [parameter value ...]" 38 | "CONFIG SET param val " "[parameter value ...]" 39 | "CONFIG SET param val parm2 val2 " "[parameter value ...]" 40 | 41 | # Command with nested optional args: ZRANDMEMBER key [count [WITHSCORES]] 42 | "ZRANDMEMBER k " "[count [WITHSCORES]]" 43 | "ZRANDMEMBER k 3 " "[WITHSCORES]" 44 | "ZRANDMEMBER k 3 WI" "[WITHSCORES]" 45 | "ZRANDMEMBER k 3 WITHSCORES " "" 46 | # Wrong data type: count must be an integer. Hinting fails. 47 | "ZRANDMEMBER k cnt " "" 48 | 49 | # Command ends with repeated arg: MGET key [key ...] 50 | "MGET " "key [key ...]" 51 | "MGET k " "[key ...]" 52 | "MGET k k " "[key ...]" 53 | 54 | # Optional args can be in any order: SCAN cursor [MATCH pattern] [COUNT count] [TYPE type] 55 | "SCAN 2 MATCH " "pattern [COUNT count] [TYPE type]" 56 | "SCAN 2 COUNT " "count [MATCH pattern] [TYPE type]" 57 | 58 | # One-of choices: BLMOVE source destination LEFT|RIGHT LEFT|RIGHT timeout 59 | "BLMOVE src dst LEFT " "LEFT|RIGHT timeout" 60 | 61 | # Optional args can be in any order: ZRANGE key min max [BYSCORE|BYLEX] [REV] [LIMIT offset count] [WITHSCORES] 62 | "ZRANGE k 1 2 " "[BYSCORE|BYLEX] [REV] [LIMIT offset count] [WITHSCORES]" 63 | "ZRANGE k 1 2 bylex " "[REV] [LIMIT offset count] [WITHSCORES]" 64 | "ZRANGE k 1 2 bylex rev " "[LIMIT offset count] [WITHSCORES]" 65 | "ZRANGE k 1 2 limit 2 4 " "[BYSCORE|BYLEX] [REV] [WITHSCORES]" 66 | "ZRANGE k 1 2 bylex rev limit 2 4 WITHSCORES " "" 67 | "ZRANGE k 1 2 rev " "[BYSCORE|BYLEX] [LIMIT offset count] [WITHSCORES]" 68 | "ZRANGE k 1 2 WITHSCORES " "[BYSCORE|BYLEX] [REV] [LIMIT offset count]" 69 | 70 | # Optional one-of args with parameters: SET key value [NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL] 71 | "SET key value " "[NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 72 | "SET key value EX" "[NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 73 | "SET key value EX " "seconds [NX|XX] [GET]" 74 | "SET key value EX 23 " "[NX|XX] [GET]" 75 | "SET key value EXAT" "[NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 76 | "SET key value EXAT " "unix-time-seconds [NX|XX] [GET]" 77 | "SET key value PX" "[NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 78 | "SET key value PX " "milliseconds [NX|XX] [GET]" 79 | "SET key value PXAT" "[NX|XX] [GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 80 | "SET key value PXAT " "unix-time-milliseconds [NX|XX] [GET]" 81 | "SET key value KEEPTTL " "[NX|XX] [GET]" 82 | "SET key value XX " "[GET] [EX seconds|PX milliseconds|EXAT unix-time-seconds|PXAT unix-time-milliseconds|KEEPTTL]" 83 | 84 | # If an input word can't be matched, stop hinting. 85 | "SET key value FOOBAR " "" 86 | # Incorrect type for EX 'seconds' parameter - stop hinting. 87 | "SET key value EX sec " "" 88 | 89 | # Reordering partially-matched optional argument: GEORADIUS key longitude latitude radius M|KM|FT|MI [WITHCOORD] [WITHDIST] [WITHHASH] [COUNT count [ANY]] [ASC|DESC] [STORE key|STOREDIST key] 90 | "GEORADIUS key " "longitude latitude radius M|KM|FT|MI [WITHCOORD] [WITHDIST] [WITHHASH] [COUNT count [ANY]] [ASC|DESC] [STORE key|STOREDIST key]" 91 | "GEORADIUS key 1 2 3 M " "[WITHCOORD] [WITHDIST] [WITHHASH] [COUNT count [ANY]] [ASC|DESC] [STORE key|STOREDIST key]" 92 | "GEORADIUS key 1 2 3 M COUNT " "count [ANY] [WITHCOORD] [WITHDIST] [WITHHASH] [ASC|DESC] [STORE key|STOREDIST key]" 93 | "GEORADIUS key 1 2 3 M COUNT 12 " "[ANY] [WITHCOORD] [WITHDIST] [WITHHASH] [ASC|DESC] [STORE key|STOREDIST key]" 94 | "GEORADIUS key 1 2 3 M COUNT 12 " "[ANY] [WITHCOORD] [WITHDIST] [WITHHASH] [ASC|DESC] [STORE key|STOREDIST key]" 95 | "GEORADIUS key 1 -2.345 3 M COUNT 12 " "[ANY] [WITHCOORD] [WITHDIST] [WITHHASH] [ASC|DESC] [STORE key|STOREDIST key]"" "" 96 | # Wrong data type: latitude must be a double. Hinting fails. 97 | "GEORADIUS key 1 X " "" 98 | # Once the next optional argument is started, the [ANY] hint completing the COUNT argument disappears. 99 | "GEORADIUS key 1 2 3 M COUNT 12 ASC " "[WITHCOORD] [WITHDIST] [WITHHASH] [STORE key|STOREDIST key]" 100 | 101 | # Incorrect argument type for double-valued token parameter. 102 | "GEOSEARCH k FROMLONLAT " "longitude latitude BYRADIUS radius M|KM|FT|MI|BYBOX width height M|KM|FT|MI [ASC|DESC] [COUNT count [ANY]] [WITHCOORD] [WITHDIST] [WITHHASH]" 103 | "GEOSEARCH k FROMLONLAT 2.34 4.45 BYRADIUS badvalue " "" 104 | 105 | # Optional parameters followed by mandatory params: ZADD key [NX|XX] [GT|LT] [CH] [INCR] score member [score member ...] 106 | "ZADD key " "[NX|XX] [GT|LT] [CH] [INCR] score member [score member ...]" 107 | "ZADD key CH LT " "[NX|XX] [INCR] score member [score member ...]" 108 | "ZADD key 0 " "member [score member ...]" 109 | 110 | # Empty-valued token argument represented as a pair of double-quotes. 111 | "MIGRATE " "host port key|\"\" destination-db timeout [COPY] [REPLACE] [AUTH password|AUTH2 username password] [KEYS key [key ...]]" 112 | -------------------------------------------------------------------------------- /tcltests/support/cluster_util.tcl: -------------------------------------------------------------------------------- 1 | # Cluster helper functions 2 | 3 | # Check if cluster configuration is consistent. 4 | proc cluster_config_consistent {} { 5 | for {set j 0} {$j < [llength $::servers]} {incr j} { 6 | if {$j == 0} { 7 | set base_cfg [R $j cluster slots] 8 | } else { 9 | if {[R $j cluster slots] != $base_cfg} { 10 | return 0 11 | } 12 | } 13 | } 14 | 15 | return 1 16 | } 17 | 18 | # Check if cluster size is consistent. 19 | proc cluster_size_consistent {cluster_size} { 20 | for {set j 0} {$j < $cluster_size} {incr j} { 21 | if {[CI $j cluster_known_nodes] ne $cluster_size} { 22 | return 0 23 | } 24 | } 25 | return 1 26 | } 27 | 28 | # Wait for cluster configuration to propagate and be consistent across nodes. 29 | proc wait_for_cluster_propagation {} { 30 | wait_for_condition 50 100 { 31 | [cluster_config_consistent] eq 1 32 | } else { 33 | fail "cluster config did not reach a consistent state" 34 | } 35 | } 36 | 37 | # Wait for cluster size to be consistent across nodes. 38 | proc wait_for_cluster_size {cluster_size} { 39 | wait_for_condition 1000 50 { 40 | [cluster_size_consistent $cluster_size] eq 1 41 | } else { 42 | fail "cluster size did not reach a consistent size $cluster_size" 43 | } 44 | } 45 | 46 | # Check that cluster nodes agree about "state", or raise an error. 47 | proc wait_for_cluster_state {state} { 48 | for {set j 0} {$j < [llength $::servers]} {incr j} { 49 | wait_for_condition 100 50 { 50 | [CI $j cluster_state] eq $state 51 | } else { 52 | fail "Cluster node $j cluster_state:[CI $j cluster_state]" 53 | } 54 | } 55 | } 56 | 57 | # Default slot allocation for clusters, each master has a continuous block 58 | # and approximately equal number of slots. 59 | proc continuous_slot_allocation {masters} { 60 | set avg [expr double(16384) / $masters] 61 | set slot_start 0 62 | for {set j 0} {$j < $masters} {incr j} { 63 | set slot_end [expr int(ceil(($j + 1) * $avg) - 1)] 64 | R $j cluster addslotsrange $slot_start $slot_end 65 | set slot_start [expr $slot_end + 1] 66 | } 67 | } 68 | 69 | # Setup method to be executed to configure the cluster before the 70 | # tests run. 71 | proc cluster_setup {masters node_count slot_allocator code} { 72 | # Have all nodes meet 73 | if {$::tls} { 74 | set tls_cluster [lindex [R 0 CONFIG GET tls-cluster] 1] 75 | } 76 | if {$::tls && !$tls_cluster} { 77 | for {set i 1} {$i < $node_count} {incr i} { 78 | R 0 CLUSTER MEET [srv -$i host] [srv -$i pport] 79 | } 80 | } else { 81 | for {set i 1} {$i < $node_count} {incr i} { 82 | R 0 CLUSTER MEET [srv -$i host] [srv -$i port] 83 | } 84 | } 85 | 86 | $slot_allocator $masters 87 | 88 | wait_for_cluster_propagation 89 | 90 | # Setup master/replica relationships 91 | for {set i 0} {$i < $masters} {incr i} { 92 | set nodeid [R $i CLUSTER MYID] 93 | for {set j [expr $i + $masters]} {$j < $node_count} {incr j $masters} { 94 | R $j CLUSTER REPLICATE $nodeid 95 | } 96 | } 97 | 98 | wait_for_cluster_propagation 99 | wait_for_cluster_state "ok" 100 | 101 | uplevel 1 $code 102 | } 103 | 104 | # Start a cluster with the given number of masters and replicas. Replicas 105 | # will be allocated to masters by round robin. 106 | proc start_cluster {masters replicas options code {slot_allocator continuous_slot_allocation}} { 107 | set node_count [expr $masters + $replicas] 108 | 109 | # Set the final code to be the tests + cluster setup 110 | set code [list cluster_setup $masters $node_count $slot_allocator $code] 111 | 112 | # Configure the starting of multiple servers. Set cluster node timeout 113 | # aggressively since many tests depend on ping/pong messages. 114 | set cluster_options [list overrides [list cluster-enabled yes cluster-ping-interval 100 cluster-node-timeout 3000]] 115 | set options [concat $cluster_options $options] 116 | 117 | # Cluster mode only supports a single database, so before executing the tests 118 | # it needs to be configured correctly and needs to be reset after the tests. 119 | set old_singledb $::singledb 120 | set ::singledb 1 121 | start_multiple_servers $node_count $options $code 122 | set ::singledb $old_singledb 123 | } 124 | 125 | # Test node for flag. 126 | proc cluster_has_flag {node flag} { 127 | expr {[lsearch -exact [dict get $node flags] $flag] != -1} 128 | } 129 | 130 | # Returns the parsed "myself" node entry as a dictionary. 131 | proc cluster_get_myself id { 132 | set nodes [get_cluster_nodes $id] 133 | foreach n $nodes { 134 | if {[cluster_has_flag $n myself]} {return $n} 135 | } 136 | return {} 137 | } 138 | 139 | # Returns a parsed CLUSTER NODES output as a list of dictionaries. 140 | proc get_cluster_nodes id { 141 | set lines [split [R $id cluster nodes] "\r\n"] 142 | set nodes {} 143 | foreach l $lines { 144 | set l [string trim $l] 145 | if {$l eq {}} continue 146 | set args [split $l] 147 | set node [dict create \ 148 | id [lindex $args 0] \ 149 | addr [lindex $args 1] \ 150 | flags [split [lindex $args 2] ,] \ 151 | slaveof [lindex $args 3] \ 152 | ping_sent [lindex $args 4] \ 153 | pong_recv [lindex $args 5] \ 154 | config_epoch [lindex $args 6] \ 155 | linkstate [lindex $args 7] \ 156 | slots [lrange $args 8 end] \ 157 | ] 158 | lappend nodes $node 159 | } 160 | return $nodes 161 | } 162 | 163 | # Returns 1 if no node knows node_id, 0 if any node knows it. 164 | proc node_is_forgotten {node_id} { 165 | for {set j 0} {$j < [llength $::servers]} {incr j} { 166 | set cluster_nodes [R $j CLUSTER NODES] 167 | if { [string match "*$node_id*" $cluster_nodes] } { 168 | return 0 169 | } 170 | } 171 | return 1 172 | } 173 | 174 | # Isolate a node from the cluster and give it a new nodeid 175 | proc isolate_node {id} { 176 | set node_id [R $id CLUSTER MYID] 177 | R $id CLUSTER RESET HARD 178 | # Here we additionally test that CLUSTER FORGET propagates to all nodes. 179 | set other_id [expr $id == 0 ? 1 : 0] 180 | R $other_id CLUSTER FORGET $node_id 181 | wait_for_condition 50 100 { 182 | [node_is_forgotten $node_id] 183 | } else { 184 | fail "CLUSTER FORGET was not propagated to all nodes" 185 | } 186 | } 187 | 188 | # Check if cluster's view of hostnames is consistent 189 | proc are_hostnames_propagated {match_string} { 190 | for {set j 0} {$j < [llength $::servers]} {incr j} { 191 | set cfg [R $j cluster slots] 192 | foreach node $cfg { 193 | for {set i 2} {$i < [llength $node]} {incr i} { 194 | if {! [string match $match_string [lindex [lindex [lindex $node $i] 3] 1]] } { 195 | return 0 196 | } 197 | } 198 | } 199 | } 200 | return 1 201 | } 202 | 203 | proc wait_node_marked_fail {ref_node_index instance_id_to_check} { 204 | wait_for_condition 1000 50 { 205 | [check_cluster_node_mark fail $ref_node_index $instance_id_to_check] 206 | } else { 207 | fail "Replica node never marked as FAIL ('fail')" 208 | } 209 | } 210 | 211 | proc wait_node_marked_pfail {ref_node_index instance_id_to_check} { 212 | wait_for_condition 1000 50 { 213 | [check_cluster_node_mark fail\? $ref_node_index $instance_id_to_check] 214 | } else { 215 | fail "Replica node never marked as PFAIL ('fail?')" 216 | } 217 | } 218 | 219 | proc check_cluster_node_mark {flag ref_node_index instance_id_to_check} { 220 | set nodes [get_cluster_nodes $ref_node_index] 221 | 222 | foreach n $nodes { 223 | if {[dict get $n id] eq $instance_id_to_check} { 224 | return [cluster_has_flag $n $flag] 225 | } 226 | } 227 | fail "Unable to find instance id in cluster nodes. ID: $instance_id_to_check" 228 | } 229 | -------------------------------------------------------------------------------- /tcltests/support/test.tcl: -------------------------------------------------------------------------------- 1 | set ::num_tests 0 2 | set ::num_passed 0 3 | set ::num_failed 0 4 | set ::num_skipped 0 5 | set ::num_aborted 0 6 | set ::tests_failed {} 7 | set ::cur_test "" 8 | 9 | proc fail {msg} { 10 | error "assertion:$msg" 11 | } 12 | 13 | proc assert {condition} { 14 | if {![uplevel 1 [list expr $condition]]} { 15 | set context "(context: [info frame -1])" 16 | error "assertion:Expected [uplevel 1 [list subst -nocommands $condition]] $context" 17 | } 18 | } 19 | 20 | proc assert_no_match {pattern value} { 21 | if {[string match $pattern $value]} { 22 | set context "(context: [info frame -1])" 23 | error "assertion:Expected '$value' to not match '$pattern' $context" 24 | } 25 | } 26 | 27 | proc assert_match {pattern value {detail ""} {context ""}} { 28 | if {![string match $pattern $value]} { 29 | if {$context eq ""} { 30 | set context "(context: [info frame -1])" 31 | } 32 | error "assertion:Expected '$value' to match '$pattern' $context $detail" 33 | } 34 | } 35 | 36 | proc assert_failed {expected_err detail} { 37 | if {$detail ne ""} { 38 | set detail "(detail: $detail)" 39 | } else { 40 | set detail "(context: [info frame -2])" 41 | } 42 | error "assertion:$expected_err $detail" 43 | } 44 | 45 | proc assert_not_equal {value expected {detail ""}} { 46 | if {!($expected ne $value)} { 47 | assert_failed "Expected '$value' not equal to '$expected'" $detail 48 | } 49 | } 50 | 51 | proc assert_equal {value expected {detail ""}} { 52 | if {$expected ne $value} { 53 | assert_failed "Expected '$value' to be equal to '$expected'" $detail 54 | } 55 | } 56 | 57 | proc assert_lessthan {value expected {detail ""}} { 58 | if {!($value < $expected)} { 59 | assert_failed "Expected '$value' to be less than '$expected'" $detail 60 | } 61 | } 62 | 63 | proc assert_lessthan_equal {value expected {detail ""}} { 64 | if {!($value <= $expected)} { 65 | assert_failed "Expected '$value' to be less than or equal to '$expected'" $detail 66 | } 67 | } 68 | 69 | proc assert_morethan {value expected {detail ""}} { 70 | if {!($value > $expected)} { 71 | assert_failed "Expected '$value' to be more than '$expected'" $detail 72 | } 73 | } 74 | 75 | proc assert_morethan_equal {value expected {detail ""}} { 76 | if {!($value >= $expected)} { 77 | assert_failed "Expected '$value' to be more than or equal to '$expected'" $detail 78 | } 79 | } 80 | 81 | proc assert_range {value min max {detail ""}} { 82 | if {!($value <= $max && $value >= $min)} { 83 | assert_failed "Expected '$value' to be between to '$min' and '$max'" $detail 84 | } 85 | } 86 | 87 | proc assert_error {pattern code {detail ""}} { 88 | if {[catch {uplevel 1 $code} error]} { 89 | assert_match $pattern $error $detail 90 | } else { 91 | assert_failed "Expected an error matching '$pattern' but got '$error'" $detail 92 | } 93 | } 94 | 95 | proc assert_encoding {enc key} { 96 | if {$::ignoreencoding} { 97 | return 98 | } 99 | set val [r object encoding $key] 100 | assert_match $enc $val 101 | } 102 | 103 | proc assert_type {type key} { 104 | assert_equal $type [r type $key] 105 | } 106 | 107 | proc assert_refcount {ref key} { 108 | if {[lsearch $::denytags "needs:debug"] >= 0} { 109 | return 110 | } 111 | 112 | set val [r object refcount $key] 113 | assert_equal $ref $val 114 | } 115 | 116 | proc assert_refcount_morethan {key ref} { 117 | if {[lsearch $::denytags "needs:debug"] >= 0} { 118 | return 119 | } 120 | 121 | set val [r object refcount $key] 122 | assert_morethan $val $ref 123 | } 124 | 125 | # Wait for the specified condition to be true, with the specified number of 126 | # max retries and delay between retries. Otherwise the 'elsescript' is 127 | # executed. 128 | proc wait_for_condition {maxtries delay e _else_ elsescript} { 129 | while {[incr maxtries -1] >= 0} { 130 | set errcode [catch {uplevel 1 [list expr $e]} result] 131 | if {$errcode == 0} { 132 | if {$result} break 133 | } else { 134 | return -code $errcode $result 135 | } 136 | after $delay 137 | } 138 | if {$maxtries == -1} { 139 | set errcode [catch [uplevel 1 $elsescript] result] 140 | return -code $errcode $result 141 | } 142 | } 143 | 144 | # try to match a value to a list of patterns that are either regex (starts with "/") or plain string. 145 | # The caller can specify to use only glob-pattern match 146 | proc search_pattern_list {value pattern_list {glob_pattern false}} { 147 | foreach el $pattern_list { 148 | if {[string length $el] == 0} { continue } 149 | if { $glob_pattern } { 150 | if {[string match $el $value]} { 151 | return 1 152 | } 153 | continue 154 | } 155 | if {[string equal / [string index $el 0]] && [regexp -- [string range $el 1 end] $value]} { 156 | return 1 157 | } elseif {[string equal $el $value]} { 158 | return 1 159 | } 160 | } 161 | return 0 162 | } 163 | 164 | proc test {name code {okpattern undefined} {tags {}}} { 165 | # abort if test name in skiptests 166 | if {[search_pattern_list $name $::skiptests]} { 167 | incr ::num_skipped 168 | send_data_packet $::test_server_fd skip $name 169 | return 170 | } 171 | if {$::verbose > 1} { 172 | puts "starting test $name" 173 | } 174 | # abort if only_tests was set but test name is not included 175 | if {[llength $::only_tests] > 0 && ![search_pattern_list $name $::only_tests]} { 176 | incr ::num_skipped 177 | send_data_packet $::test_server_fd skip $name 178 | return 179 | } 180 | 181 | set tags [concat $::tags $tags] 182 | if {![tags_acceptable $tags err]} { 183 | incr ::num_aborted 184 | send_data_packet $::test_server_fd ignore "$name: $err" 185 | return 186 | } 187 | 188 | incr ::num_tests 189 | set details {} 190 | lappend details "$name in $::curfile" 191 | 192 | # set a cur_test global to be logged into new servers that are spawn 193 | # and log the test name in all existing servers 194 | set prev_test $::cur_test 195 | set ::cur_test "$name in $::curfile" 196 | if {$::external} { 197 | catch { 198 | set r [redis [srv 0 host] [srv 0 port] 0 $::tls] 199 | catch { 200 | $r debug log "### Starting test $::cur_test" 201 | } 202 | $r close 203 | } 204 | } else { 205 | set servers {} 206 | foreach srv $::servers { 207 | set stdout [dict get $srv stdout] 208 | set fd [open $stdout "a+"] 209 | puts $fd "### Starting test $::cur_test" 210 | close $fd 211 | lappend servers $stdout 212 | } 213 | if {$::verbose > 1} { 214 | puts "### Starting test $::cur_test - with servers: $servers" 215 | } 216 | } 217 | 218 | send_data_packet $::test_server_fd testing $name 219 | 220 | set failed false 221 | set test_start_time [clock milliseconds] 222 | if {[catch {set retval [uplevel 1 $code]} error]} { 223 | set assertion [string match "assertion:*" $error] 224 | if {$assertion || $::durable} { 225 | # durable prevents the whole tcl test from exiting on an exception. 226 | # an assertion is handled gracefully anyway. 227 | set msg [string range $error 10 end] 228 | lappend details $msg 229 | if {!$assertion} { 230 | lappend details $::errorInfo 231 | } 232 | lappend ::tests_failed $details 233 | 234 | incr ::num_failed 235 | set failed true 236 | send_data_packet $::test_server_fd err [join $details "\n"] 237 | 238 | if {$::stop_on_failure} { 239 | puts "Test error (last server port:[srv port], log:[srv stdout]), press enter to teardown the test." 240 | flush stdout 241 | gets stdin 242 | } 243 | } else { 244 | # Re-raise, let handler up the stack take care of this. 245 | error $error $::errorInfo 246 | } 247 | } else { 248 | if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} { 249 | incr ::num_passed 250 | set elapsed [expr {[clock milliseconds]-$test_start_time}] 251 | send_data_packet $::test_server_fd ok $name $elapsed 252 | } else { 253 | set msg "Expected '$okpattern' to equal or match '$retval'" 254 | lappend details $msg 255 | lappend ::tests_failed $details 256 | 257 | incr ::num_failed 258 | set failed true 259 | send_data_packet $::test_server_fd err [join $details "\n"] 260 | } 261 | } 262 | 263 | if {$::dump_logs && $failed} { 264 | foreach srv $::servers { 265 | dump_server_log $srv 266 | } 267 | } 268 | 269 | if {$::traceleaks} { 270 | set output [exec leaks redis-server] 271 | if {![string match {*0 leaks*} $output]} { 272 | send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output" 273 | } 274 | } 275 | set ::cur_test $prev_test 276 | } 277 | -------------------------------------------------------------------------------- /tcltests/support/cluster.tcl: -------------------------------------------------------------------------------- 1 | # Tcl redis cluster client as a wrapper of redis.rb. 2 | # 3 | # Copyright (C) 2014-Present, Redis Ltd. 4 | # All Rights reserved. 5 | # 6 | # Licensed under your choice of the Redis Source Available License 2.0 7 | # (RSALv2) or the Server Side Public License v1 (SSPLv1). 8 | # 9 | # Example usage: 10 | # 11 | # set c [redis_cluster {127.0.0.1:6379 127.0.0.1:6380}] 12 | # $c set foo 13 | # $c get foo 14 | # $c close 15 | 16 | package require Tcl 8.5 17 | package provide redis_cluster 0.1 18 | 19 | namespace eval redis_cluster {} 20 | set ::redis_cluster::internal_id 0 21 | set ::redis_cluster::id 0 22 | array set ::redis_cluster::startup_nodes {} 23 | array set ::redis_cluster::nodes {} 24 | array set ::redis_cluster::slots {} 25 | array set ::redis_cluster::tls {} 26 | 27 | # List of "plain" commands, which are commands where the sole key is always 28 | # the first argument. 29 | set ::redis_cluster::plain_commands { 30 | get set setnx setex psetex append strlen exists setbit getbit 31 | setrange getrange substr incr decr rpush lpush rpushx lpushx 32 | linsert rpop lpop brpop llen lindex lset lrange ltrim lrem 33 | sadd srem sismember smismember scard spop srandmember smembers sscan zadd 34 | zincrby zrem zremrangebyscore zremrangebyrank zremrangebylex zrange 35 | zrangebyscore zrevrangebyscore zrangebylex zrevrangebylex zcount 36 | zlexcount zrevrange zcard zscore zmscore zrank zrevrank zscan hset hsetnx 37 | hget hmset hmget hincrby hincrbyfloat hdel hlen hkeys hvals 38 | hgetall hexists hscan incrby decrby incrbyfloat getset move 39 | expire expireat pexpire pexpireat type ttl pttl persist restore 40 | dump bitcount bitpos pfadd pfcount cluster ssubscribe spublish 41 | sunsubscribe 42 | } 43 | 44 | # Create a cluster client. The nodes are given as a list of host:port. The TLS 45 | # parameter (1 or 0) is optional and defaults to the global $::tls. 46 | proc redis_cluster {nodes {tls -1}} { 47 | set id [incr ::redis_cluster::id] 48 | set ::redis_cluster::startup_nodes($id) $nodes 49 | set ::redis_cluster::nodes($id) {} 50 | set ::redis_cluster::slots($id) {} 51 | set ::redis_cluster::tls($id) [expr $tls == -1 ? $::tls : $tls] 52 | set handle [interp alias {} ::redis_cluster::instance$id {} ::redis_cluster::__dispatch__ $id] 53 | $handle refresh_nodes_map 54 | return $handle 55 | } 56 | 57 | # Totally reset the slots / nodes state for the client, calls 58 | # CLUSTER NODES in the first startup node available, populates the 59 | # list of nodes ::redis_cluster::nodes($id) with an hash mapping node 60 | # ip:port to a representation of the node (another hash), and finally 61 | # maps ::redis_cluster::slots($id) with an hash mapping slot numbers 62 | # to node IDs. 63 | # 64 | # This function is called when a new Redis Cluster client is initialized 65 | # and every time we get a -MOVED redirection error. 66 | proc ::redis_cluster::__method__refresh_nodes_map {id} { 67 | # Contact the first responding startup node. 68 | set idx 0; # Index of the node that will respond. 69 | set errmsg {} 70 | foreach start_node $::redis_cluster::startup_nodes($id) { 71 | set ip_port [lindex [split $start_node @] 0] 72 | lassign [split $ip_port :] start_host start_port 73 | set tls $::redis_cluster::tls($id) 74 | if {[catch { 75 | set r {} 76 | set r [redis $start_host $start_port 0 $tls] 77 | set nodes_descr [$r cluster nodes] 78 | $r close 79 | } e]} { 80 | if {$r ne {}} {catch {$r close}} 81 | incr idx 82 | if {[string length $errmsg] < 200} { 83 | append errmsg " $ip_port: $e" 84 | } 85 | continue ; # Try next. 86 | } else { 87 | break; # Good node found. 88 | } 89 | } 90 | 91 | if {$idx == [llength $::redis_cluster::startup_nodes($id)]} { 92 | error "No good startup node found. $errmsg" 93 | } 94 | 95 | # Put the node that responded as first in the list if it is not 96 | # already the first. 97 | if {$idx != 0} { 98 | set l $::redis_cluster::startup_nodes($id) 99 | set left [lrange $l 0 [expr {$idx-1}]] 100 | set right [lrange $l [expr {$idx+1}] end] 101 | set l [concat [lindex $l $idx] $left $right] 102 | set ::redis_cluster::startup_nodes($id) $l 103 | } 104 | 105 | # Parse CLUSTER NODES output to populate the nodes description. 106 | set nodes {} ; # addr -> node description hash. 107 | foreach line [split $nodes_descr "\n"] { 108 | set line [string trim $line] 109 | if {$line eq {}} continue 110 | set args [split $line " "] 111 | lassign $args nodeid addr flags slaveof pingsent pongrecv configepoch linkstate 112 | set slots [lrange $args 8 end] 113 | set addr [lindex [split $addr @] 0] 114 | if {$addr eq {:0}} { 115 | set addr $start_host:$start_port 116 | } 117 | lassign [split $addr :] host port 118 | 119 | # Connect to the node 120 | set link {} 121 | set tls $::redis_cluster::tls($id) 122 | catch {set link [redis $host $port 0 $tls]} 123 | 124 | # Build this node description as an hash. 125 | set node [dict create \ 126 | id $nodeid \ 127 | internal_id $id \ 128 | addr $addr \ 129 | host $host \ 130 | port $port \ 131 | flags $flags \ 132 | slaveof $slaveof \ 133 | slots $slots \ 134 | link $link \ 135 | ] 136 | dict set nodes $addr $node 137 | lappend ::redis_cluster::startup_nodes($id) $addr 138 | } 139 | 140 | # Close all the existing links in the old nodes map, and set the new 141 | # map as current. 142 | foreach n $::redis_cluster::nodes($id) { 143 | catch { 144 | [dict get $n link] close 145 | } 146 | } 147 | set ::redis_cluster::nodes($id) $nodes 148 | 149 | # Populates the slots -> nodes map. 150 | dict for {addr node} $nodes { 151 | foreach slotrange [dict get $node slots] { 152 | lassign [split $slotrange -] start end 153 | if {$end == {}} {set end $start} 154 | for {set j $start} {$j <= $end} {incr j} { 155 | dict set ::redis_cluster::slots($id) $j $addr 156 | } 157 | } 158 | } 159 | 160 | # Only retain unique entries in the startup nodes list 161 | set ::redis_cluster::startup_nodes($id) [lsort -unique $::redis_cluster::startup_nodes($id)] 162 | } 163 | 164 | # Free a redis_cluster handle. 165 | proc ::redis_cluster::__method__close {id} { 166 | catch { 167 | set nodes $::redis_cluster::nodes($id) 168 | dict for {addr node} $nodes { 169 | catch { 170 | [dict get $node link] close 171 | } 172 | } 173 | } 174 | catch {unset ::redis_cluster::startup_nodes($id)} 175 | catch {unset ::redis_cluster::nodes($id)} 176 | catch {unset ::redis_cluster::slots($id)} 177 | catch {unset ::redis_cluster::tls($id)} 178 | catch {interp alias {} ::redis_cluster::instance$id {}} 179 | } 180 | 181 | proc ::redis_cluster::__method__masternode_for_slot {id slot} { 182 | # Get the node mapped to this slot. 183 | set node_addr [dict get $::redis_cluster::slots($id) $slot] 184 | if {$node_addr eq {}} { 185 | error "No mapped node for slot $slot." 186 | } 187 | return [dict get $::redis_cluster::nodes($id) $node_addr] 188 | } 189 | 190 | proc ::redis_cluster::__method__masternode_notfor_slot {id slot} { 191 | # Get a node that is not mapped to this slot. 192 | set node_addr [dict get $::redis_cluster::slots($id) $slot] 193 | set addrs [dict keys $::redis_cluster::nodes($id)] 194 | foreach addr [lshuffle $addrs] { 195 | set node [dict get $::redis_cluster::nodes($id) $addr] 196 | if {$node_addr ne $addr && [dict get $node slaveof] eq "-"} { 197 | return $node 198 | } 199 | } 200 | error "Slot $slot is everywhere" 201 | } 202 | 203 | proc ::redis_cluster::__dispatch__ {id method args} { 204 | if {[info command ::redis_cluster::__method__$method] eq {}} { 205 | # Get the keys from the command. 206 | set keys [::redis_cluster::get_keys_from_command $method $args] 207 | if {$keys eq {}} { 208 | error "Redis command '$method' is not supported by redis_cluster." 209 | } 210 | 211 | # Resolve the keys in the corresponding hash slot they hash to. 212 | set slot [::redis_cluster::get_slot_from_keys $keys] 213 | if {$slot eq {}} { 214 | error "Invalid command: multiple keys not hashing to the same slot." 215 | } 216 | 217 | # Get the node mapped to this slot. 218 | set node_addr [dict get $::redis_cluster::slots($id) $slot] 219 | if {$node_addr eq {}} { 220 | error "No mapped node for slot $slot." 221 | } 222 | 223 | # Execute the command in the node we think is the slot owner. 224 | set retry 100 225 | set asking 0 226 | while {[incr retry -1]} { 227 | if {$retry < 5} {after 100} 228 | set node [dict get $::redis_cluster::nodes($id) $node_addr] 229 | set link [dict get $node link] 230 | if {$asking} { 231 | $link ASKING 232 | set asking 0 233 | } 234 | if {[catch {$link $method {*}$args} e]} { 235 | if {$link eq {} || \ 236 | [string range $e 0 4] eq {MOVED} || \ 237 | [string range $e 0 2] eq {I/O} \ 238 | } { 239 | # MOVED redirection. 240 | ::redis_cluster::__method__refresh_nodes_map $id 241 | set node_addr [dict get $::redis_cluster::slots($id) $slot] 242 | continue 243 | } elseif {[string range $e 0 2] eq {ASK}} { 244 | # ASK redirection. 245 | set node_addr [lindex $e 2] 246 | set asking 1 247 | continue 248 | } else { 249 | # Non redirecting error. 250 | error $e $::errorInfo $::errorCode 251 | } 252 | } else { 253 | # OK query went fine 254 | return $e 255 | } 256 | } 257 | error "Too many redirections or failures contacting Redis Cluster." 258 | } else { 259 | uplevel 1 [list ::redis_cluster::__method__$method $id] $args 260 | } 261 | } 262 | 263 | proc ::redis_cluster::get_keys_from_command {cmd argv} { 264 | set cmd [string tolower $cmd] 265 | # Most Redis commands get just one key as first argument. 266 | if {[lsearch -exact $::redis_cluster::plain_commands $cmd] != -1} { 267 | return [list [lindex $argv 0]] 268 | } 269 | 270 | # Special handling for other commands 271 | switch -exact $cmd { 272 | mget {return $argv} 273 | eval {return [lrange $argv 2 1+[lindex $argv 1]]} 274 | evalsha {return [lrange $argv 2 1+[lindex $argv 1]]} 275 | spublish {return [list [lindex $argv 1]]} 276 | } 277 | 278 | # All the remaining commands are not handled. 279 | return {} 280 | } 281 | 282 | # Returns the CRC16 of the specified string. 283 | # The CRC parameters are described in the Redis Cluster specification. 284 | set ::redis_cluster::XMODEMCRC16Lookup { 285 | 0x0000 0x1021 0x2042 0x3063 0x4084 0x50a5 0x60c6 0x70e7 286 | 0x8108 0x9129 0xa14a 0xb16b 0xc18c 0xd1ad 0xe1ce 0xf1ef 287 | 0x1231 0x0210 0x3273 0x2252 0x52b5 0x4294 0x72f7 0x62d6 288 | 0x9339 0x8318 0xb37b 0xa35a 0xd3bd 0xc39c 0xf3ff 0xe3de 289 | 0x2462 0x3443 0x0420 0x1401 0x64e6 0x74c7 0x44a4 0x5485 290 | 0xa56a 0xb54b 0x8528 0x9509 0xe5ee 0xf5cf 0xc5ac 0xd58d 291 | 0x3653 0x2672 0x1611 0x0630 0x76d7 0x66f6 0x5695 0x46b4 292 | 0xb75b 0xa77a 0x9719 0x8738 0xf7df 0xe7fe 0xd79d 0xc7bc 293 | 0x48c4 0x58e5 0x6886 0x78a7 0x0840 0x1861 0x2802 0x3823 294 | 0xc9cc 0xd9ed 0xe98e 0xf9af 0x8948 0x9969 0xa90a 0xb92b 295 | 0x5af5 0x4ad4 0x7ab7 0x6a96 0x1a71 0x0a50 0x3a33 0x2a12 296 | 0xdbfd 0xcbdc 0xfbbf 0xeb9e 0x9b79 0x8b58 0xbb3b 0xab1a 297 | 0x6ca6 0x7c87 0x4ce4 0x5cc5 0x2c22 0x3c03 0x0c60 0x1c41 298 | 0xedae 0xfd8f 0xcdec 0xddcd 0xad2a 0xbd0b 0x8d68 0x9d49 299 | 0x7e97 0x6eb6 0x5ed5 0x4ef4 0x3e13 0x2e32 0x1e51 0x0e70 300 | 0xff9f 0xefbe 0xdfdd 0xcffc 0xbf1b 0xaf3a 0x9f59 0x8f78 301 | 0x9188 0x81a9 0xb1ca 0xa1eb 0xd10c 0xc12d 0xf14e 0xe16f 302 | 0x1080 0x00a1 0x30c2 0x20e3 0x5004 0x4025 0x7046 0x6067 303 | 0x83b9 0x9398 0xa3fb 0xb3da 0xc33d 0xd31c 0xe37f 0xf35e 304 | 0x02b1 0x1290 0x22f3 0x32d2 0x4235 0x5214 0x6277 0x7256 305 | 0xb5ea 0xa5cb 0x95a8 0x8589 0xf56e 0xe54f 0xd52c 0xc50d 306 | 0x34e2 0x24c3 0x14a0 0x0481 0x7466 0x6447 0x5424 0x4405 307 | 0xa7db 0xb7fa 0x8799 0x97b8 0xe75f 0xf77e 0xc71d 0xd73c 308 | 0x26d3 0x36f2 0x0691 0x16b0 0x6657 0x7676 0x4615 0x5634 309 | 0xd94c 0xc96d 0xf90e 0xe92f 0x99c8 0x89e9 0xb98a 0xa9ab 310 | 0x5844 0x4865 0x7806 0x6827 0x18c0 0x08e1 0x3882 0x28a3 311 | 0xcb7d 0xdb5c 0xeb3f 0xfb1e 0x8bf9 0x9bd8 0xabbb 0xbb9a 312 | 0x4a75 0x5a54 0x6a37 0x7a16 0x0af1 0x1ad0 0x2ab3 0x3a92 313 | 0xfd2e 0xed0f 0xdd6c 0xcd4d 0xbdaa 0xad8b 0x9de8 0x8dc9 314 | 0x7c26 0x6c07 0x5c64 0x4c45 0x3ca2 0x2c83 0x1ce0 0x0cc1 315 | 0xef1f 0xff3e 0xcf5d 0xdf7c 0xaf9b 0xbfba 0x8fd9 0x9ff8 316 | 0x6e17 0x7e36 0x4e55 0x5e74 0x2e93 0x3eb2 0x0ed1 0x1ef0 317 | } 318 | 319 | proc ::redis_cluster::crc16 {s} { 320 | set s [encoding convertto ascii $s] 321 | set crc 0 322 | foreach char [split $s {}] { 323 | scan $char %c byte 324 | set crc [expr {(($crc<<8)&0xffff) ^ [lindex $::redis_cluster::XMODEMCRC16Lookup [expr {(($crc>>8)^$byte) & 0xff}]]}] 325 | } 326 | return $crc 327 | } 328 | 329 | # Hash a single key returning the slot it belongs to, Implemented hash 330 | # tags as described in the Redis Cluster specification. 331 | proc ::redis_cluster::hash {key} { 332 | set keylen [string length $key] 333 | set s {} 334 | set e {} 335 | for {set s 0} {$s < $keylen} {incr s} { 336 | if {[string index $key $s] eq "\{"} break 337 | } 338 | 339 | if {[expr {$s == $keylen}]} { 340 | set res [expr {[crc16 $key] & 16383}] 341 | return $res 342 | } 343 | 344 | for {set e [expr {$s+1}]} {$e < $keylen} {incr e} { 345 | if {[string index $key $e] == "\}"} break 346 | } 347 | 348 | if {$e == $keylen || $e == [expr {$s+1}]} { 349 | set res [expr {[crc16 $key] & 16383}] 350 | return $res 351 | } 352 | 353 | set key_sub [string range $key [expr {$s+1}] [expr {$e-1}]] 354 | return [expr {[crc16 $key_sub] & 16383}] 355 | } 356 | 357 | # Return the slot the specified keys hash to. 358 | # If the keys hash to multiple slots, an empty string is returned to 359 | # signal that the command can't be run in Redis Cluster. 360 | proc ::redis_cluster::get_slot_from_keys {keys} { 361 | set slot {} 362 | foreach k $keys { 363 | set s [::redis_cluster::hash $k] 364 | if {$slot eq {}} { 365 | set slot $s 366 | } elseif {$slot != $s} { 367 | return {} ; # Error 368 | } 369 | } 370 | return $slot 371 | } 372 | -------------------------------------------------------------------------------- /tcltests/support/redis.tcl: -------------------------------------------------------------------------------- 1 | # Tcl client library - used by the Redis test 2 | # 3 | # Copyright (C) 2014-Present, Redis Ltd. 4 | # All Rights reserved. 5 | # 6 | # Licensed under your choice of the Redis Source Available License 2.0 7 | # (RSALv2) or the Server Side Public License v1 (SSPLv1). 8 | # 9 | # Example usage: 10 | # 11 | # set r [redis 127.0.0.1 6379] 12 | # $r lpush mylist foo 13 | # $r lpush mylist bar 14 | # $r lrange mylist 0 -1 15 | # $r close 16 | # 17 | # Non blocking usage example: 18 | # 19 | # proc handlePong {r type reply} { 20 | # puts "PONG $type '$reply'" 21 | # if {$reply ne "PONG"} { 22 | # $r ping [list handlePong] 23 | # } 24 | # } 25 | # 26 | # set r [redis] 27 | # $r blocking 0 28 | # $r get fo [list handlePong] 29 | # 30 | # vwait forever 31 | 32 | package require Tcl 8.5 33 | package provide redis 0.1 34 | 35 | source [file join [file dirname [info script]] "response_transformers.tcl"] 36 | 37 | namespace eval redis {} 38 | set ::redis::id 0 39 | array set ::redis::fd {} 40 | array set ::redis::addr {} 41 | array set ::redis::blocking {} 42 | array set ::redis::deferred {} 43 | array set ::redis::readraw {} 44 | array set ::redis::attributes {} ;# Holds the RESP3 attributes from the last call 45 | array set ::redis::reconnect {} 46 | array set ::redis::tls {} 47 | array set ::redis::callback {} 48 | array set ::redis::state {} ;# State in non-blocking reply reading 49 | array set ::redis::statestack {} ;# Stack of states, for nested mbulks 50 | array set ::redis::curr_argv {} ;# Remember the current argv, to be used in response_transformers.tcl 51 | array set ::redis::testing_resp3 {} ;# Indicating if the current client is using RESP3 (only if the test is trying to test RESP3 specific behavior. It won't be on in case of force_resp3) 52 | 53 | set ::force_resp3 0 54 | set ::log_req_res 0 55 | 56 | proc redis {{server 127.0.0.1} {port 6379} {defer 0} {tls 0} {tlsoptions {}} {readraw 0}} { 57 | if {$tls} { 58 | package require tls 59 | ::tls::init \ 60 | -cafile "$::tlsdir/ca.crt" \ 61 | -certfile "$::tlsdir/client.crt" \ 62 | -keyfile "$::tlsdir/client.key" \ 63 | {*}$tlsoptions 64 | set fd [::tls::socket $server $port] 65 | } else { 66 | set fd [socket $server $port] 67 | } 68 | fconfigure $fd -translation binary 69 | set id [incr ::redis::id] 70 | set ::redis::fd($id) $fd 71 | set ::redis::addr($id) [list $server $port] 72 | set ::redis::blocking($id) 1 73 | set ::redis::deferred($id) $defer 74 | set ::redis::readraw($id) $readraw 75 | set ::redis::reconnect($id) 0 76 | set ::redis::curr_argv($id) 0 77 | set ::redis::testing_resp3($id) 0 78 | set ::redis::tls($id) $tls 79 | ::redis::redis_reset_state $id 80 | interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id 81 | } 82 | 83 | # On recent versions of tcl-tls/OpenSSL, reading from a dropped connection 84 | # results with an error we need to catch and mimic the old behavior. 85 | proc ::redis::redis_safe_read {fd len} { 86 | if {$len == -1} { 87 | set err [catch {set val [read $fd]} msg] 88 | } else { 89 | set err [catch {set val [read $fd $len]} msg] 90 | } 91 | if {!$err} { 92 | return $val 93 | } 94 | if {[string match "*connection abort*" $msg]} { 95 | return {} 96 | } 97 | error $msg 98 | } 99 | 100 | proc ::redis::redis_safe_gets {fd} { 101 | if {[catch {set val [gets $fd]} msg]} { 102 | if {[string match "*connection abort*" $msg]} { 103 | return {} 104 | } 105 | error $msg 106 | } 107 | return $val 108 | } 109 | 110 | # This is a wrapper to the actual dispatching procedure that handles 111 | # reconnection if needed. 112 | proc ::redis::__dispatch__ {id method args} { 113 | set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval] 114 | if {$errorcode && $::redis::reconnect($id) && $::redis::fd($id) eq {}} { 115 | # Try again if the connection was lost. 116 | # FIXME: we don't re-select the previously selected DB, nor we check 117 | # if we are inside a transaction that needs to be re-issued from 118 | # scratch. 119 | set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval] 120 | } 121 | return -code $errorcode $retval 122 | } 123 | 124 | proc ::redis::__dispatch__raw__ {id method argv} { 125 | set fd $::redis::fd($id) 126 | 127 | # Reconnect the link if needed. 128 | if {$fd eq {} && $method ne {close}} { 129 | lassign $::redis::addr($id) host port 130 | if {$::redis::tls($id)} { 131 | set ::redis::fd($id) [::tls::socket $host $port] 132 | } else { 133 | set ::redis::fd($id) [socket $host $port] 134 | } 135 | fconfigure $::redis::fd($id) -translation binary 136 | set fd $::redis::fd($id) 137 | } 138 | 139 | # Transform HELLO 2 to HELLO 3 if force_resp3 140 | # All set the connection var testing_resp3 in case of HELLO 3 141 | if {[llength $argv] > 0 && [string compare -nocase $method "HELLO"] == 0} { 142 | if {[lindex $argv 0] == 3} { 143 | set ::redis::testing_resp3($id) 1 144 | } else { 145 | set ::redis::testing_resp3($id) 0 146 | if {$::force_resp3} { 147 | # If we are in force_resp3 we run HELLO 3 instead of HELLO 2 148 | lset argv 0 3 149 | } 150 | } 151 | } 152 | 153 | set blocking $::redis::blocking($id) 154 | set deferred $::redis::deferred($id) 155 | if {$blocking == 0} { 156 | if {[llength $argv] == 0} { 157 | error "Please provide a callback in non-blocking mode" 158 | } 159 | set callback [lindex $argv end] 160 | set argv [lrange $argv 0 end-1] 161 | } 162 | if {[info command ::redis::__method__$method] eq {}} { 163 | catch {unset ::redis::attributes($id)} 164 | set cmd "*[expr {[llength $argv]+1}]\r\n" 165 | append cmd "$[string length $method]\r\n$method\r\n" 166 | foreach a $argv { 167 | append cmd "$[string length $a]\r\n$a\r\n" 168 | } 169 | ::redis::redis_write $fd $cmd 170 | if {[catch {flush $fd}]} { 171 | catch {close $fd} 172 | set ::redis::fd($id) {} 173 | return -code error "I/O error reading reply" 174 | } 175 | 176 | set ::redis::curr_argv($id) [concat $method $argv] 177 | if {!$deferred} { 178 | if {$blocking} { 179 | ::redis::redis_read_reply $id $fd 180 | } else { 181 | # Every well formed reply read will pop an element from this 182 | # list and use it as a callback. So pipelining is supported 183 | # in non blocking mode. 184 | lappend ::redis::callback($id) $callback 185 | fileevent $fd readable [list ::redis::redis_readable $fd $id] 186 | } 187 | } 188 | } else { 189 | uplevel 1 [list ::redis::__method__$method $id $fd] $argv 190 | } 191 | } 192 | 193 | proc ::redis::__method__blocking {id fd val} { 194 | set ::redis::blocking($id) $val 195 | fconfigure $fd -blocking $val 196 | } 197 | 198 | proc ::redis::__method__reconnect {id fd val} { 199 | set ::redis::reconnect($id) $val 200 | } 201 | 202 | proc ::redis::__method__read {id fd} { 203 | ::redis::redis_read_reply $id $fd 204 | } 205 | 206 | proc ::redis::__method__rawread {id fd {len -1}} { 207 | return [redis_safe_read $fd $len] 208 | } 209 | 210 | proc ::redis::__method__write {id fd buf} { 211 | ::redis::redis_write $fd $buf 212 | } 213 | 214 | proc ::redis::__method__flush {id fd} { 215 | flush $fd 216 | } 217 | 218 | proc ::redis::__method__close {id fd} { 219 | catch {close $fd} 220 | catch {unset ::redis::fd($id)} 221 | catch {unset ::redis::addr($id)} 222 | catch {unset ::redis::blocking($id)} 223 | catch {unset ::redis::deferred($id)} 224 | catch {unset ::redis::readraw($id)} 225 | catch {unset ::redis::attributes($id)} 226 | catch {unset ::redis::reconnect($id)} 227 | catch {unset ::redis::tls($id)} 228 | catch {unset ::redis::state($id)} 229 | catch {unset ::redis::statestack($id)} 230 | catch {unset ::redis::callback($id)} 231 | catch {unset ::redis::curr_argv($id)} 232 | catch {unset ::redis::testing_resp3($id)} 233 | catch {interp alias {} ::redis::redisHandle$id {}} 234 | } 235 | 236 | proc ::redis::__method__channel {id fd} { 237 | return $fd 238 | } 239 | 240 | proc ::redis::__method__deferred {id fd val} { 241 | set ::redis::deferred($id) $val 242 | } 243 | 244 | proc ::redis::__method__readraw {id fd val} { 245 | set ::redis::readraw($id) $val 246 | } 247 | 248 | proc ::redis::__method__readingraw {id fd} { 249 | return $::redis::readraw($id) 250 | } 251 | 252 | proc ::redis::__method__attributes {id fd} { 253 | set _ $::redis::attributes($id) 254 | } 255 | 256 | proc ::redis::redis_write {fd buf} { 257 | puts -nonewline $fd $buf 258 | } 259 | 260 | proc ::redis::redis_writenl {fd buf} { 261 | redis_write $fd $buf 262 | redis_write $fd "\r\n" 263 | flush $fd 264 | } 265 | 266 | proc ::redis::redis_readnl {fd len} { 267 | set buf [redis_safe_read $fd $len] 268 | redis_safe_read $fd 2 ; # discard CR LF 269 | return $buf 270 | } 271 | 272 | proc ::redis::redis_bulk_read {fd} { 273 | set count [redis_read_line $fd] 274 | if {$count == -1} return {} 275 | set buf [redis_readnl $fd $count] 276 | return $buf 277 | } 278 | 279 | proc ::redis::redis_multi_bulk_read {id fd} { 280 | set count [redis_read_line $fd] 281 | if {$count == -1} return {} 282 | set l {} 283 | set err {} 284 | for {set i 0} {$i < $count} {incr i} { 285 | if {[catch { 286 | lappend l [redis_read_reply_logic $id $fd] 287 | } e] && $err eq {}} { 288 | set err $e 289 | } 290 | } 291 | if {$err ne {}} {return -code error $err} 292 | return $l 293 | } 294 | 295 | proc ::redis::redis_read_map {id fd} { 296 | set count [redis_read_line $fd] 297 | if {$count == -1} return {} 298 | set d {} 299 | set err {} 300 | for {set i 0} {$i < $count} {incr i} { 301 | if {[catch { 302 | set k [redis_read_reply_logic $id $fd] ; # key 303 | set v [redis_read_reply_logic $id $fd] ; # value 304 | dict set d $k $v 305 | } e] && $err eq {}} { 306 | set err $e 307 | } 308 | } 309 | if {$err ne {}} {return -code error $err} 310 | return $d 311 | } 312 | 313 | proc ::redis::redis_read_line fd { 314 | string trim [redis_safe_gets $fd] 315 | } 316 | 317 | proc ::redis::redis_read_null fd { 318 | redis_safe_gets $fd 319 | return {} 320 | } 321 | 322 | proc ::redis::redis_read_bool fd { 323 | set v [redis_read_line $fd] 324 | if {$v == "t"} {return 1} 325 | if {$v == "f"} {return 0} 326 | return -code error "Bad protocol, '$v' as bool type" 327 | } 328 | 329 | proc ::redis::redis_read_double {id fd} { 330 | set v [redis_read_line $fd] 331 | # unlike many other DTs, there is a textual difference between double and a string with the same value, 332 | # so we need to transform to double if we are testing RESP3 (i.e. some tests check that a 333 | # double reply is "1.0" and not "1") 334 | if {[should_transform_to_resp2 $id]} { 335 | return $v 336 | } else { 337 | return [expr {double($v)}] 338 | } 339 | } 340 | 341 | proc ::redis::redis_read_verbatim_str fd { 342 | set v [redis_bulk_read $fd] 343 | # strip the first 4 chars ("txt:") 344 | return [string range $v 4 end] 345 | } 346 | 347 | proc ::redis::redis_read_reply_logic {id fd} { 348 | if {$::redis::readraw($id)} { 349 | return [redis_read_line $fd] 350 | } 351 | 352 | while {1} { 353 | set type [redis_safe_read $fd 1] 354 | switch -exact -- $type { 355 | _ {return [redis_read_null $fd]} 356 | : - 357 | ( - 358 | + {return [redis_read_line $fd]} 359 | , {return [redis_read_double $id $fd]} 360 | # {return [redis_read_bool $fd]} 361 | = {return [redis_read_verbatim_str $fd]} 362 | - {return -code error [redis_read_line $fd]} 363 | $ {return [redis_bulk_read $fd]} 364 | > - 365 | ~ - 366 | * {return [redis_multi_bulk_read $id $fd]} 367 | % {return [redis_read_map $id $fd]} 368 | | { 369 | set attrib [redis_read_map $id $fd] 370 | set ::redis::attributes($id) $attrib 371 | continue 372 | } 373 | default { 374 | if {$type eq {}} { 375 | catch {close $fd} 376 | set ::redis::fd($id) {} 377 | return -code error "I/O error reading reply" 378 | } 379 | return -code error "Bad protocol, '$type' as reply type byte" 380 | } 381 | } 382 | } 383 | } 384 | 385 | proc ::redis::redis_read_reply {id fd} { 386 | set response [redis_read_reply_logic $id $fd] 387 | ::response_transformers::transform_response_if_needed $id $::redis::curr_argv($id) $response 388 | } 389 | 390 | proc ::redis::redis_reset_state id { 391 | set ::redis::state($id) [dict create buf {} mbulk -1 bulk -1 reply {}] 392 | set ::redis::statestack($id) {} 393 | } 394 | 395 | proc ::redis::redis_call_callback {id type reply} { 396 | set cb [lindex $::redis::callback($id) 0] 397 | set ::redis::callback($id) [lrange $::redis::callback($id) 1 end] 398 | uplevel #0 $cb [list ::redis::redisHandle$id $type $reply] 399 | ::redis::redis_reset_state $id 400 | } 401 | 402 | # Read a reply in non-blocking mode. 403 | proc ::redis::redis_readable {fd id} { 404 | if {[eof $fd]} { 405 | redis_call_callback $id eof {} 406 | ::redis::__method__close $id $fd 407 | return 408 | } 409 | if {[dict get $::redis::state($id) bulk] == -1} { 410 | set line [gets $fd] 411 | if {$line eq {}} return ;# No complete line available, return 412 | switch -exact -- [string index $line 0] { 413 | : - 414 | + {redis_call_callback $id reply [string range $line 1 end-1]} 415 | - {redis_call_callback $id err [string range $line 1 end-1]} 416 | ( {redis_call_callback $id reply [string range $line 1 end-1]} 417 | $ { 418 | dict set ::redis::state($id) bulk \ 419 | [expr [string range $line 1 end-1]+2] 420 | if {[dict get $::redis::state($id) bulk] == 1} { 421 | # We got a $-1, hack the state to play well with this. 422 | dict set ::redis::state($id) bulk 2 423 | dict set ::redis::state($id) buf "\r\n" 424 | ::redis::redis_readable $fd $id 425 | } 426 | } 427 | * { 428 | dict set ::redis::state($id) mbulk [string range $line 1 end-1] 429 | # Handle *-1 430 | if {[dict get $::redis::state($id) mbulk] == -1} { 431 | redis_call_callback $id reply {} 432 | } 433 | } 434 | default { 435 | redis_call_callback $id err \ 436 | "Bad protocol, $type as reply type byte" 437 | } 438 | } 439 | } else { 440 | set totlen [dict get $::redis::state($id) bulk] 441 | set buflen [string length [dict get $::redis::state($id) buf]] 442 | set toread [expr {$totlen-$buflen}] 443 | set data [read $fd $toread] 444 | set nread [string length $data] 445 | dict append ::redis::state($id) buf $data 446 | # Check if we read a complete bulk reply 447 | if {[string length [dict get $::redis::state($id) buf]] == 448 | [dict get $::redis::state($id) bulk]} { 449 | if {[dict get $::redis::state($id) mbulk] == -1} { 450 | redis_call_callback $id reply \ 451 | [string range [dict get $::redis::state($id) buf] 0 end-2] 452 | } else { 453 | dict with ::redis::state($id) { 454 | lappend reply [string range $buf 0 end-2] 455 | incr mbulk -1 456 | set bulk -1 457 | } 458 | if {[dict get $::redis::state($id) mbulk] == 0} { 459 | redis_call_callback $id reply \ 460 | [dict get $::redis::state($id) reply] 461 | } 462 | } 463 | } 464 | } 465 | } 466 | 467 | # when forcing resp3 some tests that rely on resp2 can fail, so we have to translate the resp3 response to resp2 468 | proc ::redis::should_transform_to_resp2 {id} { 469 | return [expr {$::force_resp3 && !$::redis::testing_resp3($id)}] 470 | } 471 | -------------------------------------------------------------------------------- /tcltests/unit/keyspace.tcl: -------------------------------------------------------------------------------- 1 | start_server {tags {"keyspace"}} { 2 | test {DEL against a single item} { 3 | r set x foo 4 | assert {[r get x] eq "foo"} 5 | r del x 6 | r get x 7 | } {} 8 | 9 | test {Vararg DEL} { 10 | r set foo1{t} a 11 | r set foo2{t} b 12 | r set foo3{t} c 13 | list [r del foo1{t} foo2{t} foo3{t} foo4{t}] [r mget foo1{t} foo2{t} foo3{t}] 14 | } {3 {{} {} {}}} 15 | 16 | test {Untagged multi-key commands} { 17 | r mset foo1 a foo2 b foo3 c 18 | assert_equal {a b c {}} [r mget foo1 foo2 foo3 foo4] 19 | r del foo1 foo2 foo3 foo4 20 | } {3} {cluster:skip} 21 | 22 | test {KEYS with pattern} { 23 | foreach key {key_x key_y key_z foo_a foo_b foo_c} { 24 | r set $key hello 25 | } 26 | lsort [r keys foo*] 27 | } {foo_a foo_b foo_c} 28 | 29 | test {KEYS to get all keys} { 30 | lsort [r keys *] 31 | } {foo_a foo_b foo_c key_x key_y key_z} 32 | 33 | test {DBSIZE} { 34 | r dbsize 35 | } {6} 36 | 37 | test {KEYS with hashtag} { 38 | foreach key {"{a}x" "{a}y" "{a}z" "{b}a" "{b}b" "{b}c"} { 39 | r set $key hello 40 | } 41 | assert_equal [lsort [r keys "{a}*"]] [list "{a}x" "{a}y" "{a}z"] 42 | assert_equal [lsort [r keys "*{b}*"]] [list "{b}a" "{b}b" "{b}c"] 43 | } 44 | 45 | test {DEL all keys} { 46 | foreach key [r keys *] {r del $key} 47 | r dbsize 48 | } {0} 49 | 50 | test "DEL against expired key" { 51 | r debug set-active-expire 0 52 | r setex keyExpire 1 valExpire 53 | after 1100 54 | assert_equal 0 [r del keyExpire] 55 | r debug set-active-expire 1 56 | } {OK} {needs:debug} 57 | 58 | test {EXISTS} { 59 | set res {} 60 | r set newkey test 61 | append res [r exists newkey] 62 | r del newkey 63 | append res [r exists newkey] 64 | } {10} 65 | 66 | test {Zero length value in key. SET/GET/EXISTS} { 67 | r set emptykey {} 68 | set res [r get emptykey] 69 | append res [r exists emptykey] 70 | r del emptykey 71 | append res [r exists emptykey] 72 | } {10} 73 | 74 | test {Non existing command} { 75 | catch {r foobaredcommand} err 76 | string match ERR* $err 77 | } {1} 78 | 79 | test {RENAME basic usage} { 80 | r set mykey{t} hello 81 | r rename mykey{t} mykey1{t} 82 | r rename mykey1{t} mykey2{t} 83 | r get mykey2{t} 84 | } {hello} 85 | 86 | test {RENAME source key should no longer exist} { 87 | r exists mykey 88 | } {0} 89 | 90 | test {RENAME against already existing key} { 91 | r set mykey{t} a 92 | r set mykey2{t} b 93 | r rename mykey2{t} mykey{t} 94 | set res [r get mykey{t}] 95 | append res [r exists mykey2{t}] 96 | } {b0} 97 | 98 | test {RENAME against non existing source key} { 99 | catch {r rename nokey{t} foobar{t}} err 100 | format $err 101 | } {ERR*} 102 | 103 | test {RENAME where source and dest key are the same (existing)} { 104 | r set mykey foo 105 | r rename mykey mykey 106 | } {OK} 107 | 108 | test {RENAME where source and dest key are the same (non existing)} { 109 | r del mykey 110 | catch {r rename mykey mykey} err 111 | format $err 112 | } {ERR*} 113 | 114 | test {RENAME with volatile key, should move the TTL as well} { 115 | r del mykey{t} mykey2{t} 116 | r set mykey{t} foo 117 | r expire mykey{t} 100 118 | assert {[r ttl mykey{t}] > 95 && [r ttl mykey{t}] <= 100} 119 | r rename mykey{t} mykey2{t} 120 | assert {[r ttl mykey2{t}] > 95 && [r ttl mykey2{t}] <= 100} 121 | } 122 | 123 | test {RENAME with volatile key, should not inherit TTL of target key} { 124 | r del mykey{t} mykey2{t} 125 | r set mykey{t} foo 126 | r set mykey2{t} bar 127 | r expire mykey2{t} 100 128 | assert {[r ttl mykey{t}] == -1 && [r ttl mykey2{t}] > 0} 129 | r rename mykey{t} mykey2{t} 130 | r ttl mykey2{t} 131 | } {-1} 132 | 133 | test {DEL all keys again (DB 1)} { 134 | r select 10 135 | foreach key [r keys *] { 136 | r del $key 137 | } 138 | set res [r dbsize] 139 | r select 9 140 | format $res 141 | } {0} {singledb:skip} 142 | 143 | array set largevalue [generate_largevalue_test_array] 144 | foreach {type large} [array get largevalue] { 145 | set origin_config [config_get_set list-max-listpack-size -1] 146 | test "COPY basic usage for list - $type" { 147 | after 1000 148 | r del mylist{t} mynewlist{t} 149 | catch {r lpush mylist{t} a b $large c d} err 150 | format $err 151 | assert_encoding $type mylist{t} 152 | r copy mylist{t} mynewlist{t} 153 | assert_encoding $type mynewlist{t} 154 | set digest [debug_digest_value mylist{t}] 155 | assert_equal $digest [debug_digest_value mynewlist{t}] 156 | assert_refcount 1 mylist{t} 157 | assert_refcount 1 mynewlist{t} 158 | r del mylist{t} 159 | assert_equal $digest [debug_digest_value mynewlist{t}] 160 | } 161 | config_set list-max-listpack-size $origin_config 162 | } 163 | 164 | foreach type {intset listpack hashtable} { 165 | test {COPY basic usage for $type set} { 166 | r del set1{t} newset1{t} 167 | r sadd set1{t} 1 2 3 168 | if {$type ne "intset"} { 169 | r sadd set1{t} a 170 | } 171 | if {$type eq "hashtable"} { 172 | for {set i 4} {$i < 200} {incr i} { 173 | r sadd set1{t} $i 174 | } 175 | } 176 | assert_encoding $type set1{t} 177 | r copy set1{t} newset1{t} 178 | set digest [debug_digest_value set1{t}] 179 | assert_equal $digest [debug_digest_value newset1{t}] 180 | assert_refcount 1 set1{t} 181 | assert_refcount 1 newset1{t} 182 | r del set1{t} 183 | assert_equal $digest [debug_digest_value newset1{t}] 184 | } 185 | } 186 | 187 | test {COPY basic usage for listpack sorted set} { 188 | r del zset1{t} newzset1{t} 189 | r zadd zset1{t} 123 foobar 190 | assert_encoding listpack zset1{t} 191 | r copy zset1{t} newzset1{t} 192 | set digest [debug_digest_value zset1{t}] 193 | assert_equal $digest [debug_digest_value newzset1{t}] 194 | assert_refcount 1 zset1{t} 195 | assert_refcount 1 newzset1{t} 196 | r del zset1{t} 197 | assert_equal $digest [debug_digest_value newzset1{t}] 198 | } 199 | 200 | test {COPY basic usage for skiplist sorted set} { 201 | r del zset2{t} newzset2{t} 202 | set original_max [lindex [r config get zset-max-ziplist-entries] 1] 203 | r config set zset-max-ziplist-entries 0 204 | for {set j 0} {$j < 130} {incr j} { 205 | r zadd zset2{t} [randomInt 50] ele-[randomInt 10] 206 | } 207 | assert_encoding skiplist zset2{t} 208 | r copy zset2{t} newzset2{t} 209 | set digest [debug_digest_value zset2{t}] 210 | assert_equal $digest [debug_digest_value newzset2{t}] 211 | assert_refcount 1 zset2{t} 212 | assert_refcount 1 newzset2{t} 213 | r del zset2{t} 214 | assert_equal $digest [debug_digest_value newzset2{t}] 215 | r config set zset-max-ziplist-entries $original_max 216 | } 217 | 218 | test {COPY basic usage for listpack hash} { 219 | r config set hash-max-listpack-entries 512 220 | r del hash1{t} newhash1{t} 221 | r hset hash1{t} tmp 17179869184 222 | assert_encoding listpack hash1{t} 223 | r copy hash1{t} newhash1{t} 224 | set digest [debug_digest_value hash1{t}] 225 | assert_equal $digest [debug_digest_value newhash1{t}] 226 | assert_refcount 1 hash1{t} 227 | assert_refcount 1 newhash1{t} 228 | r del hash1{t} 229 | assert_equal $digest [debug_digest_value newhash1{t}] 230 | } 231 | 232 | test {COPY basic usage for hashtable hash} { 233 | r del hash2{t} newhash2{t} 234 | set original_max [lindex [r config get hash-max-ziplist-entries] 1] 235 | r config set hash-max-ziplist-entries 0 236 | for {set i 0} {$i < 64} {incr i} { 237 | r hset hash2{t} [randomValue] [randomValue] 238 | } 239 | assert_encoding hashtable hash2{t} 240 | r copy hash2{t} newhash2{t} 241 | set digest [debug_digest_value hash2{t}] 242 | assert_equal $digest [debug_digest_value newhash2{t}] 243 | assert_refcount 1 hash2{t} 244 | assert_refcount 1 newhash2{t} 245 | r del hash2{t} 246 | assert_equal $digest [debug_digest_value newhash2{t}] 247 | r config set hash-max-ziplist-entries $original_max 248 | } 249 | 250 | test {COPY for string does not replace an existing key without REPLACE option} { 251 | r set mykey2{t} hello 252 | catch {r copy mykey2{t} mynewkey{t} DB 10} e 253 | set e 254 | } {0} {singledb:skip} 255 | 256 | test {COPY for string can replace an existing key with REPLACE option} { 257 | r copy mykey2{t} mynewkey{t} DB 10 REPLACE 258 | r select 10 259 | r get mynewkey{t} 260 | } {hello} {singledb:skip} 261 | 262 | test {COPY for string ensures that copied data is independent of copying data} { 263 | r flushdb 264 | r select 9 265 | r set mykey{t} foobar 266 | set res {} 267 | r copy mykey{t} mynewkey{t} DB 10 268 | r select 10 269 | lappend res [r get mynewkey{t}] 270 | r set mynewkey{t} hoge 271 | lappend res [r get mynewkey{t}] 272 | r select 9 273 | lappend res [r get mykey{t}] 274 | r select 10 275 | r flushdb 276 | r select 9 277 | format $res 278 | } [list foobar hoge foobar] {singledb:skip} 279 | 280 | test {COPY can copy key expire metadata as well} { 281 | r set mykey{t} foobar ex 100 282 | r copy mykey{t} mynewkey{t} REPLACE 283 | assert {[r ttl mynewkey{t}] > 0 && [r ttl mynewkey{t}] <= 100} 284 | assert {[r get mynewkey{t}] eq "foobar"} 285 | } 286 | 287 | test {COPY does not create an expire if it does not exist} { 288 | r set mykey{t} foobar 289 | assert {[r ttl mykey{t}] == -1} 290 | r copy mykey{t} mynewkey{t} REPLACE 291 | assert {[r ttl mynewkey{t}] == -1} 292 | assert {[r get mynewkey{t}] eq "foobar"} 293 | } 294 | 295 | test {MOVE basic usage} { 296 | r set mykey foobar 297 | r move mykey 10 298 | set res {} 299 | lappend res [r exists mykey] 300 | lappend res [r dbsize] 301 | r select 10 302 | lappend res [r get mykey] 303 | lappend res [r dbsize] 304 | r select 9 305 | format $res 306 | } [list 0 0 foobar 1] {singledb:skip} 307 | 308 | test {MOVE against key existing in the target DB} { 309 | r set mykey hello 310 | r move mykey 10 311 | } {0} {singledb:skip} 312 | 313 | test {MOVE against non-integer DB (#1428)} { 314 | r set mykey hello 315 | catch {r move mykey notanumber} e 316 | set e 317 | } {ERR value is not an integer or out of range} {singledb:skip} 318 | 319 | test {MOVE can move key expire metadata as well} { 320 | r select 10 321 | r flushdb 322 | r select 9 323 | r set mykey foo ex 100 324 | r move mykey 10 325 | assert {[r ttl mykey] == -2} 326 | r select 10 327 | assert {[r ttl mykey] > 0 && [r ttl mykey] <= 100} 328 | assert {[r get mykey] eq "foo"} 329 | r select 9 330 | } {OK} {singledb:skip} 331 | 332 | test {MOVE does not create an expire if it does not exist} { 333 | r select 10 334 | r flushdb 335 | r select 9 336 | r set mykey foo 337 | r move mykey 10 338 | assert {[r ttl mykey] == -2} 339 | r select 10 340 | assert {[r ttl mykey] == -1} 341 | assert {[r get mykey] eq "foo"} 342 | r select 9 343 | } {OK} {singledb:skip} 344 | 345 | test {SET/GET keys in different DBs} { 346 | r set a hello 347 | r set b world 348 | r select 10 349 | r set a foo 350 | r set b bared 351 | r select 9 352 | set res {} 353 | lappend res [r get a] 354 | lappend res [r get b] 355 | r select 10 356 | lappend res [r get a] 357 | lappend res [r get b] 358 | r select 9 359 | format $res 360 | } {hello world foo bared} {singledb:skip} 361 | 362 | test {KEYS * two times with long key, Github issue #1208} { 363 | r flushdb 364 | r set dlskeriewrioeuwqoirueioqwrueoqwrueqw test 365 | r keys * 366 | r keys * 367 | } {dlskeriewrioeuwqoirueioqwrueoqwrueqw} 368 | 369 | test {Regression for pattern matching long nested loops} { 370 | r flushdb 371 | r SET aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa 1 372 | r KEYS "a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*b" 373 | } {} 374 | 375 | test {Coverage: basic SWAPDB test and unhappy path} { 376 | r flushall 377 | r select 0 378 | r set swapkey v1 379 | r select 1 380 | assert_match 0 [r dbsize] ;#verify DB[1] has 0 keys 381 | r swapdb 0 1 382 | assert_match 1 [r dbsize] 383 | r select 0 384 | assert_match 0 [r dbsize] ;#verify DB[0] has 0 keys 385 | r flushall 386 | assert_error "ERR DB index is out of range*" {r swapdb 44 55} 387 | assert_error "ERR invalid second DB index*" {r swapdb 44 a} 388 | assert_error "ERR invalid first DB index*" {r swapdb a 55} 389 | assert_error "ERR invalid first DB index*" {r swapdb a b} 390 | assert_match "OK" [r swapdb 0 0] 391 | } {} {singledb:skip} 392 | 393 | test {Coverage: SWAPDB and FLUSHDB} { 394 | # set a key in each db and swapdb one of 2 with different db 395 | # and flushdb on swapped db. 396 | r flushall 397 | r select 0 398 | r set swapkey v1 399 | r select 1 400 | r set swapkey1 v1 401 | assert_no_match "*db2:keys=*" [r info keyspace] 402 | r swapdb 0 2 403 | r select 0 404 | assert_match 0 [r dbsize] 405 | assert_no_match "*db0:keys=*" [r info keyspace] 406 | r select 2 407 | r flushdb 408 | assert_match 0 [r dbsize] 409 | assert_match "*db1:keys=*" [r info keyspace] 410 | assert_no_match "*db0:keys=*" [r info keyspace] 411 | assert_no_match "*db2:keys=*" [r info keyspace] 412 | r flushall 413 | } {OK} {singledb:skip} 414 | 415 | # ************************************************************************** 416 | # --------- TODO::: TESTS below are waiting to be fixed ---------- 417 | # ************************************************************************** 418 | # test {Commands pipelining} { 419 | # set fd [r channel] 420 | # puts -nonewline $fd "SET k1 xyzk\r\nGET k1\r\nPING\r\n" 421 | # flush $fd 422 | # set res {} 423 | # append res [string match OK* [r read]] 424 | # append res [r read] 425 | # append res [string match PONG* [r read]] 426 | # format $res 427 | # } {1xyzk1} 428 | 429 | # test {DEL all keys again (DB 0)} { 430 | # foreach key [r keys *] { 431 | # r del $key 432 | # } 433 | # r dbsize 434 | # } {0} 435 | 436 | # ************************************************************************** 437 | # --------- TESTS below are waiting to commands to be implemented ---------- 438 | # ************************************************************************** 439 | # --------- RENAMENX COMMAND ---------- 440 | # test {RENAMENX basic usage} { 441 | # r del mykey{t} 442 | # r del mykey2{t} 443 | # r set mykey{t} foobar 444 | # r renamenx mykey{t} mykey2{t} 445 | # set res [r get mykey2{t}] 446 | # append res [r exists mykey{t}] 447 | # } {foobar0} 448 | 449 | # test {RENAMENX against already existing key} { 450 | # r set mykey{t} foo 451 | # r set mykey2{t} bar 452 | # r renamenx mykey{t} mykey2{t} 453 | # } {0} 454 | 455 | # test {RENAMENX against already existing key (2)} { 456 | # set res [r get mykey{t}] 457 | # append res [r get mykey2{t}] 458 | # } {foobar} 459 | 460 | # test {RENAMENX where source and dest key are the same (existing)} { 461 | # r set mykey foo 462 | # r renamenx mykey mykey 463 | # } {0} 464 | 465 | # --------- COPY WITH DB arg support COMMAND ---------- 466 | # test {COPY for string does not copy data to no-integer DB} { 467 | # r set mykey{t} foobar 468 | # catch {r copy mykey{t} mynewkey{t} DB notanumber} e 469 | # set e 470 | # } {ERR value is not an integer or out of range} 471 | 472 | # --------- COPY/XADD/XGROUP/XREADGROUP/XDEL COMMAND ---------- 473 | # test {COPY basic usage for stream-cgroups} { 474 | # r del x{t} 475 | # r XADD x{t} 100 a 1 476 | # set id [r XADD x{t} 101 b 1] 477 | # r XADD x{t} 102 c 1 478 | # r XADD x{t} 103 e 1 479 | # r XADD x{t} 104 f 1 480 | # r XADD x{t} 105 g 1 481 | # r XGROUP CREATE x{t} g1 0 482 | # r XGROUP CREATE x{t} g2 0 483 | # r XREADGROUP GROUP g1 Alice COUNT 1 STREAMS x{t} > 484 | # r XREADGROUP GROUP g1 Bob COUNT 1 STREAMS x{t} > 485 | # r XREADGROUP GROUP g1 Bob NOACK COUNT 1 STREAMS x{t} > 486 | # r XREADGROUP GROUP g2 Charlie COUNT 4 STREAMS x{t} > 487 | # r XGROUP SETID x{t} g1 $id 488 | # r XREADGROUP GROUP g1 Dave COUNT 3 STREAMS x{t} > 489 | # r XDEL x{t} 103 490 | 491 | # r copy x{t} newx{t} 492 | # set info [r xinfo stream x{t} full] 493 | # assert_equal $info [r xinfo stream newx{t} full] 494 | # assert_refcount 1 x{t} 495 | # assert_refcount 1 newx{t} 496 | # r del x{t} 497 | # assert_equal $info [r xinfo stream newx{t} full] 498 | # r flushdb 499 | # } 500 | 501 | # test {COPY basic usage for stream} { 502 | # r del mystream{t} mynewstream{t} 503 | # for {set i 0} {$i < 1000} {incr i} { 504 | # r XADD mystream{t} * item 2 value b 505 | # } 506 | # r copy mystream{t} mynewstream{t} 507 | # set digest [debug_digest_value mystream{t}] 508 | # assert_equal $digest [debug_digest_value mynewstream{t}] 509 | # assert_refcount 1 mystream{t} 510 | # assert_refcount 1 mynewstream{t} 511 | # r del mystream{t} 512 | # assert_equal $digest [debug_digest_value mynewstream{t}] 513 | # } 514 | 515 | # --------- RANDOMKEY COMMAND ---------- 516 | # test {RANDOMKEY} { 517 | # r flushdb 518 | # r set foo x 519 | # r set bar y 520 | # set foo_seen 0 521 | # set bar_seen 0 522 | # for {set i 0} {$i < 100} {incr i} { 523 | # set rkey [r randomkey] 524 | # if {$rkey eq {foo}} { 525 | # set foo_seen 1 526 | # } 527 | # if {$rkey eq {bar}} { 528 | # set bar_seen 1 529 | # } 530 | # } 531 | # list $foo_seen $bar_seen 532 | # } {1 1} 533 | 534 | # test {RANDOMKEY against empty DB} { 535 | # r flushdb 536 | # r randomkey 537 | # } {} 538 | 539 | # test {RANDOMKEY regression 1} { 540 | # r flushdb 541 | # r set x 10 542 | # r del x 543 | # r randomkey 544 | # } {} 545 | } 546 | -------------------------------------------------------------------------------- /tcltests/integration/redis-cli.tcl: -------------------------------------------------------------------------------- 1 | source tcltests/support/cli.tcl 2 | 3 | if {$::singledb} { 4 | set ::dbnum 0 5 | } else { 6 | set ::dbnum 9 7 | } 8 | 9 | start_server {tags {"cli"}} { 10 | proc open_cli {{opts ""} {infile ""}} { 11 | if { $opts == "" } { 12 | set opts "-n $::dbnum" 13 | } 14 | set ::env(TERM) dumb 15 | set cmdline [rediscli [srv host] [srv port] $opts] 16 | if {$infile ne ""} { 17 | set cmdline "$cmdline < $infile" 18 | set mode "r" 19 | } else { 20 | set mode "r+" 21 | } 22 | set fd [open "|$cmdline" $mode] 23 | fconfigure $fd -buffering none 24 | fconfigure $fd -blocking false 25 | fconfigure $fd -translation binary 26 | set _ $fd 27 | } 28 | 29 | proc close_cli {fd} { 30 | close $fd 31 | } 32 | 33 | proc read_cli {fd} { 34 | set ret [read $fd] 35 | while {[string length $ret] == 0} { 36 | after 10 37 | set ret [read $fd] 38 | } 39 | 40 | # We may have a short read, try to read some more. 41 | set empty_reads 0 42 | while {$empty_reads < 5} { 43 | set buf [read $fd] 44 | if {[string length $buf] == 0} { 45 | after 10 46 | incr empty_reads 47 | } else { 48 | append ret $buf 49 | set empty_reads 0 50 | } 51 | } 52 | return $ret 53 | } 54 | 55 | proc write_cli {fd buf} { 56 | puts $fd $buf 57 | flush $fd 58 | } 59 | 60 | # Helpers to run tests in interactive mode 61 | 62 | proc format_output {output} { 63 | set _ [string trimright $output "\n"] 64 | } 65 | 66 | proc run_command {fd cmd} { 67 | write_cli $fd $cmd 68 | set _ [format_output [read_cli $fd]] 69 | } 70 | 71 | file delete ./.rediscli_history_test 72 | proc test_interactive_cli_with_prompt {name code} { 73 | set ::env(FAKETTY_WITH_PROMPT) 1 74 | set ::env(REDISCLI_HISTFILE) ".rediscli_history_test" 75 | test_interactive_cli $name $code 76 | unset ::env(FAKETTY_WITH_PROMPT) 77 | } 78 | 79 | proc test_interactive_cli {name code} { 80 | set ::env(FAKETTY) 1 81 | set fd [open_cli] 82 | test "Interactive CLI: $name" $code 83 | close_cli $fd 84 | unset ::env(FAKETTY) 85 | } 86 | 87 | proc test_interactive_nontty_cli {name code} { 88 | set fd [open_cli] 89 | test "Interactive non-TTY CLI: $name" $code 90 | close_cli $fd 91 | } 92 | 93 | # Helpers to run tests where stdout is not a tty 94 | proc write_tmpfile {contents} { 95 | set tmp [tmpfile "cli"] 96 | set tmpfd [open $tmp "w"] 97 | puts -nonewline $tmpfd $contents 98 | close $tmpfd 99 | set _ $tmp 100 | } 101 | 102 | proc _run_cli {host port db opts args} { 103 | set cmd [rediscli $host $port [list -n $db {*}$args]] 104 | foreach {key value} $opts { 105 | if {$key eq "pipe"} { 106 | set cmd "sh -c \"$value | $cmd\"" 107 | } 108 | if {$key eq "path"} { 109 | set cmd "$cmd < $value" 110 | } 111 | } 112 | 113 | set fd [open "|$cmd" "r"] 114 | fconfigure $fd -buffering none 115 | fconfigure $fd -translation binary 116 | set resp [read $fd 1048576] 117 | close $fd 118 | set _ [format_output $resp] 119 | } 120 | 121 | proc run_cli {args} { 122 | _run_cli [srv host] [srv port] $::dbnum {} {*}$args 123 | } 124 | 125 | proc run_cli_with_input_pipe {mode cmd args} { 126 | if {$mode == "x" } { 127 | _run_cli [srv host] [srv port] $::dbnum [list pipe $cmd] -x {*}$args 128 | } elseif {$mode == "X"} { 129 | _run_cli [srv host] [srv port] $::dbnum [list pipe $cmd] -X tag {*}$args 130 | } 131 | } 132 | 133 | proc run_cli_with_input_file {mode path args} { 134 | if {$mode == "x" } { 135 | _run_cli [srv host] [srv port] $::dbnum [list path $path] -x {*}$args 136 | } elseif {$mode == "X"} { 137 | _run_cli [srv host] [srv port] $::dbnum [list path $path] -X tag {*}$args 138 | } 139 | } 140 | 141 | proc run_cli_host_port_db {host port db args} { 142 | _run_cli $host $port $db {} {*}$args 143 | } 144 | 145 | proc test_nontty_cli {name code} { 146 | test "Non-interactive non-TTY CLI: $name" $code 147 | } 148 | 149 | # Helpers to run tests where stdout is a tty (fake it) 150 | proc test_tty_cli {name code} { 151 | set ::env(FAKETTY) 1 152 | test "Non-interactive TTY CLI: $name" $code 153 | unset ::env(FAKETTY) 154 | } 155 | 156 | test_interactive_cli_with_prompt "should find first search result" { 157 | run_command $fd "keys one\x0D" 158 | run_command $fd "keys two\x0D" 159 | 160 | puts $fd "\x12" ;# CTRL+R 161 | read_cli $fd 162 | 163 | puts -nonewline $fd "ey" 164 | set result [read_cli $fd] 165 | assert_equal 1 [regexp {\(reverse-i-search\): \x1B\[0mk\x1B\[1mey\x1B\[0ms two} $result] 166 | } 167 | 168 | test_interactive_cli_with_prompt "should find and use the first search result" { 169 | set now [clock seconds] 170 | run_command $fd "SET blah \"myvalue\"\x0D" 171 | run_command $fd "GET blah\x0D" 172 | 173 | puts $fd "\x12" ;# CTRL+R 174 | read_cli $fd 175 | 176 | puts -nonewline $fd "ET b" 177 | set result [read_cli $fd] 178 | assert_equal 1 [regexp {\(reverse-i-search\): \x1B\[0mG\x1B\[1mET b\x1B\[0mlah} $result] 179 | 180 | puts $fd "\x0D" ;# ENTER 181 | set result2 [read_cli $fd] 182 | assert_equal 1 [regexp {.*"myvalue"\n} $result2] 183 | } 184 | 185 | test_interactive_cli_with_prompt "should be ok if there is no result" { 186 | puts $fd "\x12" ;# CTRL+R 187 | 188 | set now [clock seconds] 189 | puts $fd "\x12" ;# CTRL+R 190 | set result [read_cli $fd] 191 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 192 | 193 | set result2 [run_command $fd "keys \"$now\"\x0D"] 194 | assert_equal 1 [regexp {.*(empty array).*} $result2] 195 | } 196 | 197 | test_interactive_cli_with_prompt "upon submitting search, (reverse-i-search) prompt should go away" { 198 | puts $fd "\x12" ;# CTRL+R 199 | 200 | set now [clock seconds] 201 | set result [read_cli $fd] 202 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 203 | 204 | set result2 [run_command $fd "keys \"$now\"\x0D"] 205 | 206 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 207 | } 208 | 209 | test_interactive_cli_with_prompt "should find second search result if user presses ctrl+r again" { 210 | run_command $fd "keys one\x0D" 211 | run_command $fd "keys two\x0D" 212 | 213 | puts $fd "\x12" ;# CTRL+R 214 | read_cli $fd 215 | 216 | puts -nonewline $fd "ey" 217 | set result [read_cli $fd] 218 | assert_equal 1 [regexp {\(reverse-i-search\): \x1B\[0mk\x1B\[1mey\x1B\[0ms two} $result] 219 | 220 | puts $fd "\x12" ;# CTRL+R 221 | set result [read_cli $fd] 222 | assert_equal 1 [regexp {\(reverse-i-search\): \x1B\[0mk\x1B\[1mey\x1B\[0ms one} $result] 223 | } 224 | 225 | test_interactive_cli_with_prompt "should find second search result if user presses ctrl+s" { 226 | run_command $fd "keys one\x0D" 227 | run_command $fd "keys two\x0D" 228 | 229 | puts $fd "\x13" ;# CTRL+S 230 | read_cli $fd 231 | 232 | puts -nonewline $fd "ey" 233 | set result [read_cli $fd] 234 | assert_equal 1 [regexp {\(i-search\): \x1B\[0mk\x1B\[1mey\x1B\[0ms one} $result] 235 | 236 | puts $fd "\x13" ;# CTRL+S 237 | set result [read_cli $fd] 238 | assert_equal 1 [regexp {\(i-search\): \x1B\[0mk\x1B\[1mey\x1B\[0ms two} $result] 239 | } 240 | 241 | test_interactive_cli_with_prompt "should exit reverse search if user presses ctrl+g" { 242 | run_command $fd "" 243 | 244 | puts $fd "\x12" ;# CTRL+R 245 | set result [read_cli $fd] 246 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 247 | 248 | puts $fd "\x07" ;# CTRL+G 249 | set result2 [read_cli $fd] 250 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 251 | } 252 | 253 | test_interactive_cli_with_prompt "should exit reverse search if user presses up arrow" { 254 | run_command $fd "" 255 | 256 | puts $fd "\x12" ;# CTRL+R 257 | set result [read_cli $fd] 258 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 259 | 260 | puts $fd "\x1B\x5B\x41" ;# up arrow 261 | set result2 [read_cli $fd] 262 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 263 | } 264 | 265 | test_interactive_cli_with_prompt "should exit reverse search if user presses right arrow" { 266 | run_command $fd "" 267 | 268 | puts $fd "\x12" ;# CTRL+R 269 | set result [read_cli $fd] 270 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 271 | 272 | puts $fd "\x1B\x5B\x42" ;# right arrow 273 | set result2 [read_cli $fd] 274 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 275 | } 276 | 277 | test_interactive_cli_with_prompt "should exit reverse search if user presses down arrow" { 278 | run_command $fd "" 279 | 280 | puts $fd "\x12" ;# CTRL+R 281 | set result [read_cli $fd] 282 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 283 | 284 | puts $fd "\x1B\x5B\x43" ;# down arrow 285 | set result2 [read_cli $fd] 286 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 287 | } 288 | 289 | test_interactive_cli_with_prompt "should exit reverse search if user presses left arrow" { 290 | run_command $fd "" 291 | 292 | puts $fd "\x12" ;# CTRL+R 293 | set result [read_cli $fd] 294 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 295 | 296 | puts $fd "\x1B\x5B\x44" ;# left arrow 297 | set result2 [read_cli $fd] 298 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?>} $result2] 299 | } 300 | 301 | test_interactive_cli_with_prompt "should disable and persist line if user presses tab" { 302 | run_command $fd "" 303 | 304 | puts $fd "\x12" ;# CTRL+R 305 | set result [read_cli $fd] 306 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 307 | 308 | puts -nonewline $fd "GET blah" 309 | read_cli $fd 310 | 311 | puts -nonewline $fd "\x09" ;# TAB 312 | set result2 [read_cli $fd] 313 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?> GET blah} $result2] 314 | } 315 | 316 | test_interactive_cli_with_prompt "should disable and persist search result if user presses tab" { 317 | run_command $fd "GET one\x0D" 318 | 319 | puts $fd "\x12" ;# CTRL+R 320 | set result [read_cli $fd] 321 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 322 | 323 | puts -nonewline $fd "one" 324 | read_cli $fd 325 | 326 | puts -nonewline $fd "\x09" ;# TAB 327 | set result2 [read_cli $fd] 328 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?> GET one} $result2] 329 | } 330 | 331 | test_interactive_cli_with_prompt "should disable and persist line and move the cursor if user presses tab" { 332 | run_command $fd "" 333 | 334 | puts $fd "\x12" ;# CTRL+R 335 | set result [read_cli $fd] 336 | assert_equal 1 [regexp {\(reverse-i-search\):} $result] 337 | 338 | puts -nonewline $fd "GET blah" 339 | read_cli $fd 340 | 341 | puts -nonewline $fd "\x09" ;# TAB 342 | set result2 [read_cli $fd] 343 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?> GET blah} $result2] 344 | 345 | puts -nonewline $fd "suffix" 346 | set result3 [read_cli $fd] 347 | assert_equal 1 [regexp {127\.0\.0\.1:[0-9]*(\[[0-9]])?> GET blahsuffix} $result3] 348 | } 349 | 350 | test_interactive_cli "INFO response should be printed raw" { 351 | set lines [split [run_command $fd info] "\n"] 352 | foreach line $lines { 353 | # Info lines end in \r\n, so they now end in \r. 354 | if {![regexp {^\r$|^#|^[^#:]+:} $line]} { 355 | fail "Malformed info line: $line" 356 | } 357 | } 358 | } 359 | 360 | test_interactive_cli "Status reply" { 361 | assert_equal "OK" [run_command $fd "set key foo"] 362 | } 363 | 364 | test_interactive_cli "Integer reply" { 365 | assert_equal "(integer) 1" [run_command $fd "incr counter"] 366 | } 367 | 368 | test_interactive_cli "Bulk reply" { 369 | r set key foo 370 | assert_equal "\"foo\"" [run_command $fd "get key"] 371 | } 372 | 373 | test_interactive_cli "Parsing quotes" { 374 | assert_equal "OK" [run_command $fd "set key \"bar\""] 375 | assert_equal "bar" [r get key] 376 | assert_equal "OK" [run_command $fd "set key \" bar \""] 377 | assert_equal " bar " [r get key] 378 | assert_equal "OK" [run_command $fd "set key \"\\\"bar\\\"\""] 379 | assert_equal "\"bar\"" [r get key] 380 | assert_equal "OK" [run_command $fd "set key \"\tbar\t\""] 381 | assert_equal "\tbar\t" [r get key] 382 | 383 | # invalid quotation 384 | assert_equal "Invalid argument(s)" [run_command $fd "get \"\"key"] 385 | assert_equal "Invalid argument(s)" [run_command $fd "get \"key\"x"] 386 | 387 | # quotes after the argument are weird, but should be allowed 388 | assert_equal "OK" [run_command $fd "set key\"\" bar"] 389 | assert_equal "bar" [r get key] 390 | } 391 | 392 | test_tty_cli "Status reply" { 393 | assert_equal "OK" [run_cli set key bar] 394 | assert_equal "bar" [r get key] 395 | } 396 | 397 | test_tty_cli "Integer reply" { 398 | r del counter 399 | assert_equal "(integer) 1" [run_cli incr counter] 400 | } 401 | 402 | test_tty_cli "Bulk reply" { 403 | r set key "tab\tnewline\n" 404 | assert_equal "\"tab\\tnewline\\n\"" [run_cli get key] 405 | } 406 | 407 | test_tty_cli "Read last argument from pipe" { 408 | assert_equal "OK" [run_cli_with_input_pipe x "echo foo" set key] 409 | assert_equal "foo\n" [r get key] 410 | 411 | assert_equal "OK" [run_cli_with_input_pipe X "echo foo" set key2 tag] 412 | assert_equal "foo\n" [r get key2] 413 | } 414 | 415 | test_tty_cli "Read last argument from file" { 416 | set tmpfile [write_tmpfile "from file"] 417 | 418 | assert_equal "OK" [run_cli_with_input_file x $tmpfile set key] 419 | assert_equal "from file" [r get key] 420 | 421 | assert_equal "OK" [run_cli_with_input_file X $tmpfile set key2 tag] 422 | assert_equal "from file" [r get key2] 423 | 424 | file delete $tmpfile 425 | } 426 | 427 | test_nontty_cli "Status reply" { 428 | assert_equal "OK" [run_cli set key bar] 429 | assert_equal "bar" [r get key] 430 | } 431 | 432 | test_nontty_cli "Integer reply" { 433 | r del counter 434 | assert_equal "1" [run_cli incr counter] 435 | } 436 | 437 | test_nontty_cli "Bulk reply" { 438 | r set key "tab\tnewline\n" 439 | assert_equal "tab\tnewline" [run_cli get key] 440 | } 441 | 442 | if {!$::tls} { ;# fake_redis_node doesn't support TLS 443 | test_nontty_cli "ASK redirect test" { 444 | # Set up two fake Redis nodes. 445 | set tclsh [info nameofexecutable] 446 | set script "tcltests/helpers/fake_redis_node.tcl" 447 | set port1 [find_available_port $::baseport $::portcount] 448 | set port2 [find_available_port $::baseport $::portcount] 449 | set p1 [exec $tclsh $script $port1 \ 450 | "SET foo bar" "-ASK 12182 127.0.0.1:$port2" &] 451 | set p2 [exec $tclsh $script $port2 \ 452 | "ASKING" "+OK" \ 453 | "SET foo bar" "+OK" &] 454 | # Make sure both fake nodes have started listening 455 | wait_for_condition 50 50 { 456 | [catch {close [socket "127.0.0.1" $port1]}] == 0 && \ 457 | [catch {close [socket "127.0.0.1" $port2]}] == 0 458 | } else { 459 | fail "Failed to start fake Redis nodes" 460 | } 461 | # Run the cli 462 | assert_equal "OK" [run_cli_host_port_db "127.0.0.1" $port1 0 -c SET foo bar] 463 | } 464 | } 465 | 466 | test_nontty_cli "Quoted input arguments" { 467 | r set "\x00\x00" "value" 468 | assert_equal "value" [run_cli --quoted-input get {"\x00\x00"}] 469 | } 470 | 471 | test_nontty_cli "No accidental unquoting of input arguments" { 472 | run_cli --quoted-input set {"\x41\x41"} quoted-val 473 | run_cli set {"\x41\x41"} unquoted-val 474 | assert_equal "quoted-val" [r get AA] 475 | assert_equal "unquoted-val" [r get {"\x41\x41"}] 476 | } 477 | 478 | test_nontty_cli "Read last argument from pipe" { 479 | assert_equal "OK" [run_cli_with_input_pipe x "echo foo" set key] 480 | assert_equal "foo\n" [r get key] 481 | 482 | assert_equal "OK" [run_cli_with_input_pipe X "echo foo" set key2 tag] 483 | assert_equal "foo\n" [r get key2] 484 | } 485 | 486 | test_nontty_cli "Read last argument from file" { 487 | set tmpfile [write_tmpfile "from file"] 488 | 489 | assert_equal "OK" [run_cli_with_input_file x $tmpfile set key] 490 | assert_equal "from file" [r get key] 491 | 492 | assert_equal "OK" [run_cli_with_input_file X $tmpfile set key2 tag] 493 | assert_equal "from file" [r get key2] 494 | 495 | file delete $tmpfile 496 | } 497 | 498 | test "DUMP RESTORE with -x option" { 499 | set cmdline [rediscli [srv host] [srv port]] 500 | 501 | # Delete any existing set 502 | exec {*}$cmdline DEL set 503 | # Add elements to the original set 504 | exec {*}$cmdline SADD set 1 2 3 4 5 6 505 | 506 | 507 | # Verify the members of the new set 508 | set smembers_output [exec {*}$cmdline SMEMBERS set] 509 | puts "SMEMBERS new_set output: $smembers_output" 510 | set expected_output "1\n2\n3\n4\n5\n6" 511 | # Since the order is not maintained in SMEMBERS need to sort them and then compare 512 | set smembers_list [split $smembers_output "\n"] 513 | set expected_list [split $expected_output "\n"] 514 | # Sort both lists and store the result 515 | set smembers_list [lsort $smembers_list] 516 | set expected_list [lsort $expected_list] 517 | # Assert that the sorted lists are equal 518 | assert_equal $expected_list $smembers_list 519 | } 520 | 521 | # ************************************************************************** 522 | # --------- TESTS below are waiting to commands to be implemented ---------- 523 | # ************************************************************************** 524 | # --------- LRANGE COMMAND ---------- 525 | # test_nontty_cli "Multi-bulk reply" { 526 | # r del list 527 | # r rpush list foo 528 | # r rpush list bar 529 | # assert_equal "foo\nbar" [run_cli lrange list 0 -1] 530 | # } 531 | # --------- LRANGE COMMAND ---------- 532 | # test_tty_cli "Multi-bulk reply" { 533 | # r del list 534 | # r rpush list foo 535 | # r rpush list bar 536 | # assert_equal "1) \"foo\"\n2) \"bar\"" [run_cli lrange list 0 -1] 537 | # } 538 | # --------- LRANGE COMMAND ---------- 539 | # test_interactive_cli "Multi-bulk reply" { 540 | # r rpush list foo 541 | # r rpush list bar 542 | # assert_equal "1) \"foo\"\n2) \"bar\"" [run_command $fd "lrange list 0 -1"] 543 | # } 544 | # --------- HGET COMMAND ---------- 545 | # test_tty_cli "Escape character in JSON mode" { 546 | # # reverse solidus 547 | # r hset solidus \/ \/ 548 | # assert_equal \/ \/ [run_cli hgetall solidus] 549 | # set escaped_reverse_solidus \"\\" 550 | # assert_equal $escaped_reverse_solidus $escaped_reverse_solidus [run_cli --json hgetall \/] 551 | # # non printable (0xF0 in ISO-8859-1, not UTF-8(0xC3 0xB0)) 552 | # set eth "\u00f0\u0065" 553 | # r hset eth test $eth 554 | # assert_equal \"\\xf0e\" [run_cli hget eth test] 555 | # assert_equal \"\u00f0e\" [run_cli --json hget eth test] 556 | # assert_equal \"\\\\xf0e\" [run_cli --quoted-json hget eth test] 557 | # # control characters 558 | # r hset control test "Hello\x00\x01\x02\x03World" 559 | # assert_equal \"Hello\\u0000\\u0001\\u0002\\u0003World" [run_cli --json hget control test] 560 | # # non-string keys 561 | # r hset numkey 1 One 562 | # assert_equal \{\"1\":\"One\"\} [run_cli --json hgetall numkey] 563 | # # non-string, non-printable keys 564 | # r hset npkey "K\u0000\u0001ey" "V\u0000\u0001alue" 565 | # assert_equal \{\"K\\u0000\\u0001ey\":\"V\\u0000\\u0001alue\"\} [run_cli --json hgetall npkey] 566 | # assert_equal \{\"K\\\\x00\\\\x01ey\":\"V\\\\x00\\\\x01alue\"\} [run_cli --quoted-json hgetall npkey] 567 | # } 568 | # --------- REDIS SUBSCRIBE/PUBLISH/UNSUBSCRIBE COMMAND ---------- 569 | # TODO: These can be replace by QWATCH commands for dice. 570 | # test_interactive_cli "Subscribed mode" { 571 | # if {$::force_resp3} { 572 | # run_command $fd "hello 3" 573 | # } 574 | 575 | # set reading "Reading messages... (press Ctrl-C to quit or any key to type command)\r" 576 | # set erase "\033\[K"; # Erases the "Reading messages..." line. 577 | 578 | # # Subscribe to some channels. 579 | # set sub1 "1) \"subscribe\"\n2) \"ch1\"\n3) (integer) 1\n" 580 | # set sub2 "1) \"subscribe\"\n2) \"ch2\"\n3) (integer) 2\n" 581 | # set sub3 "1) \"subscribe\"\n2) \"ch3\"\n3) (integer) 3\n" 582 | # assert_equal $sub1$sub2$sub3$reading \ 583 | # [run_command $fd "subscribe ch1 ch2 ch3"] 584 | 585 | # # Receive pubsub message. 586 | # r publish ch2 hello 587 | # set message "1) \"message\"\n2) \"ch2\"\n3) \"hello\"\n" 588 | # assert_equal $erase$message$reading [read_cli $fd] 589 | 590 | # # Unsubscribe some. 591 | # set unsub1 "1) \"unsubscribe\"\n2) \"ch1\"\n3) (integer) 2\n" 592 | # set unsub2 "1) \"unsubscribe\"\n2) \"ch2\"\n3) (integer) 1\n" 593 | # assert_equal $erase$unsub1$unsub2$reading \ 594 | # [run_command $fd "unsubscribe ch1 ch2"] 595 | 596 | # run_command $fd "hello 2" 597 | 598 | # # Command forbidden in subscribed mode (RESP2). 599 | # set err "(error) ERR Can't execute 'get': only (P|S)SUBSCRIBE / (P|S)UNSUBSCRIBE / PING / QUIT / RESET are allowed in this context\n" 600 | # assert_equal $erase$err$reading [run_command $fd "get k"] 601 | 602 | # # Command allowed in subscribed mode. 603 | # set pong "1) \"pong\"\n2) \"\"\n" 604 | # assert_equal $erase$pong$reading [run_command $fd "ping"] 605 | 606 | # # Reset exits subscribed mode. 607 | # assert_equal ${erase}RESET [run_command $fd "reset"] 608 | # assert_equal PONG [run_command $fd "ping"] 609 | 610 | # # Check TTY output of push messages in RESP3 has ")" prefix (to be changed to ">" in the future). 611 | # assert_match "1#*" [run_command $fd "hello 3"] 612 | # set sub1 "1) \"subscribe\"\n2) \"ch1\"\n3) (integer) 1\n" 613 | # assert_equal $sub1$reading \ 614 | # [run_command $fd "subscribe ch1"] 615 | # } 616 | 617 | # test_interactive_nontty_cli "Subscribed mode" { 618 | # # Raw output and no "Reading messages..." info message. 619 | # # Use RESP3 in this test case. 620 | # assert_match {*proto 3*} [run_command $fd "hello 3"] 621 | 622 | # # Subscribe to some channels. 623 | # set sub1 "subscribe\nch1\n1" 624 | # set sub2 "subscribe\nch2\n2" 625 | # assert_equal $sub1\n$sub2 \ 626 | # [run_command $fd "subscribe ch1 ch2"] 627 | 628 | # assert_equal OK [run_command $fd "client tracking on"] 629 | # assert_equal OK [run_command $fd "set k 42"] 630 | # assert_equal 42 [run_command $fd "get k"] 631 | 632 | # # Interleaving invalidate and pubsub messages. 633 | # r publish ch1 hello 634 | # r del k 635 | # r publish ch2 world 636 | # set message1 "message\nch1\nhello" 637 | # set invalidate "invalidate\nk" 638 | # set message2 "message\nch2\nworld" 639 | # assert_equal $message1\n$invalidate\n$message2\n [read_cli $fd] 640 | 641 | # # Unsubscribe all. 642 | # set unsub1 "unsubscribe\nch1\n1" 643 | # set unsub2 "unsubscribe\nch2\n0" 644 | # assert_equal $unsub1\n$unsub2 [run_command $fd "unsubscribe ch1 ch2"] 645 | # } 646 | 647 | # ************************************************************************** 648 | # --------- TESTS below are specific to redis-cli test we can ignore ------- 649 | # ************************************************************************** 650 | # test_nontty_cli "Test command-line hinting - latest server" { 651 | # # cli will connect to the running server and will use COMMAND DOCS 652 | # catch {run_cli --test_hint_file tcltests/assets/test_cli_hint_suite.txt} output 653 | # assert_match "*SUCCESS*" $output 654 | # } 655 | 656 | # test_nontty_cli "Test command-line hinting - no server" { 657 | # # cli will fail to connect to the server and will use the cached commands.c 658 | # catch {run_cli -p 123 --test_hint_file tcltests/assets/test_cli_hint_suite.txt} output 659 | # assert_match "*SUCCESS*" $output 660 | # } 661 | 662 | # test "Options -X with illegal argument" { 663 | # assert_error "*-x and -X are mutually exclusive*" {run_cli -x -X tag} 664 | # assert_error "*Unrecognized option or bad number*" {run_cli -X} 665 | # assert_error "*tag not match*" {run_cli_with_input_pipe X "echo foo" set key wrong_tag} 666 | # } 667 | 668 | # test_nontty_cli "Invalid quoted input arguments" { 669 | # catch {run_cli --quoted-input set {"Unterminated"}} err 670 | # assert_match {*exited abnormally*} $err 671 | # 672 | # # A single arg that unquotes to two arguments is also not expected 673 | # catch {run_cli --quoted-input set {"arg1" "arg2"}} err 674 | # assert_match {*exited abnormally*} $err 675 | # } 676 | } 677 | 678 | -------------------------------------------------------------------------------- /tcltests/support/server.tcl: -------------------------------------------------------------------------------- 1 | set ::global_overrides {} 2 | set ::tags {} 3 | set ::valgrind_errors {} 4 | 5 | proc start_server_error {config_file error} { 6 | set err {} 7 | append err "Can't start the Redis server\n" 8 | append err "CONFIGURATION:\n" 9 | append err [exec cat $config_file] 10 | append err "\nERROR:\n" 11 | append err [string trim $error] 12 | send_data_packet $::test_server_fd err $err 13 | } 14 | 15 | proc check_valgrind_errors stderr { 16 | set res [find_valgrind_errors $stderr true] 17 | if {$res != ""} { 18 | send_data_packet $::test_server_fd err "Valgrind error: $res\n" 19 | } 20 | } 21 | 22 | proc check_sanitizer_errors stderr { 23 | set res [sanitizer_errors_from_file $stderr] 24 | if {$res != ""} { 25 | send_data_packet $::test_server_fd err "Sanitizer error: $res\n" 26 | } 27 | } 28 | 29 | proc clean_persistence config { 30 | # we may wanna keep the logs for later, but let's clean the persistence 31 | # files right away, since they can accumulate and take up a lot of space 32 | set config [dict get $config "config"] 33 | set dir [dict get $config "dir"] 34 | set rdb [format "%s/%s" $dir "dump.rdb"] 35 | if {[dict exists $config "appenddirname"]} { 36 | set aofdir [dict get $config "appenddirname"] 37 | } else { 38 | set aofdir "appendonlydir" 39 | } 40 | set aof_dirpath [format "%s/%s" $dir $aofdir] 41 | clean_aof_persistence $aof_dirpath 42 | catch {exec rm -rf $rdb} 43 | } 44 | 45 | proc kill_server config { 46 | # nothing to kill when running against external server 47 | if {$::external} return 48 | 49 | # Close client connection if exists 50 | if {[dict exists $config "client"]} { 51 | [dict get $config "client"] close 52 | } 53 | 54 | # nevermind if its already dead 55 | set pid [dict get $config pid] 56 | if {![is_alive $pid]} { 57 | # Check valgrind errors if needed 58 | if {$::valgrind} { 59 | check_valgrind_errors [dict get $config stderr] 60 | } 61 | 62 | check_sanitizer_errors [dict get $config stderr] 63 | 64 | # Remove this pid from the set of active pids in the test server. 65 | send_data_packet $::test_server_fd server-killed $pid 66 | 67 | return 68 | } 69 | 70 | # check for leaks 71 | if {![dict exists $config "skipleaks"]} { 72 | catch { 73 | if {[string match {*Darwin*} [exec uname -a]]} { 74 | tags {"leaks"} { 75 | test "Check for memory leaks (pid $pid)" { 76 | set output {0 leaks} 77 | catch {exec leaks $pid} output option 78 | # In a few tests we kill the server process, so leaks will not find it. 79 | # It'll exits with exit code >1 on error, so we ignore these. 80 | if {[dict exists $option -errorcode]} { 81 | set details [dict get $option -errorcode] 82 | if {[lindex $details 0] eq "CHILDSTATUS"} { 83 | set status [lindex $details 2] 84 | if {$status > 1} { 85 | set output "0 leaks" 86 | } 87 | } 88 | } 89 | set output 90 | } {*0 leaks*} 91 | } 92 | } 93 | } 94 | } 95 | 96 | # kill server and wait for the process to be totally exited 97 | send_data_packet $::test_server_fd server-killing $pid 98 | catch {exec kill $pid} 99 | # Node might have been stopped in the test 100 | catch {exec kill -SIGCONT $pid} 101 | if {$::valgrind} { 102 | set max_wait 120000 103 | } else { 104 | set max_wait 10000 105 | } 106 | while {[is_alive $pid]} { 107 | incr wait 10 108 | 109 | if {$wait == $max_wait} { 110 | puts "Forcing process $pid to crash..." 111 | catch {exec kill -SEGV $pid} 112 | } elseif {$wait >= $max_wait * 2} { 113 | puts "Forcing process $pid to exit..." 114 | catch {exec kill -KILL $pid} 115 | } elseif {$wait % 1000 == 0} { 116 | puts "Waiting for process $pid to exit..." 117 | } 118 | after 10 119 | } 120 | 121 | # Check valgrind errors if needed 122 | if {$::valgrind} { 123 | check_valgrind_errors [dict get $config stderr] 124 | } 125 | 126 | check_sanitizer_errors [dict get $config stderr] 127 | 128 | # Remove this pid from the set of active pids in the test server. 129 | send_data_packet $::test_server_fd server-killed $pid 130 | } 131 | 132 | proc is_alive pid { 133 | if {[catch {exec kill -0 $pid} err]} { 134 | return 0 135 | } else { 136 | return 1 137 | } 138 | } 139 | 140 | proc ping_server {host port} { 141 | set retval 0 142 | if {[catch { 143 | if {$::tls} { 144 | set fd [::tls::socket $host $port] 145 | } else { 146 | set fd [socket $host $port] 147 | } 148 | fconfigure $fd -translation binary 149 | puts $fd "PING\r\n" 150 | flush $fd 151 | set reply [gets $fd] 152 | if {[string range $reply 0 0] eq {+} || 153 | [string range $reply 0 0] eq {-}} { 154 | set retval 1 155 | } 156 | close $fd 157 | } e]} { 158 | if {$::verbose} { 159 | puts -nonewline "." 160 | } 161 | } else { 162 | if {$::verbose} { 163 | puts -nonewline "ok" 164 | } 165 | } 166 | return $retval 167 | } 168 | 169 | # Return 1 if the server at the specified addr is reachable by PING, otherwise 170 | # returns 0. Performs a try every 50 milliseconds for the specified number 171 | # of retries. 172 | proc server_is_up {host port retrynum} { 173 | after 10 ;# Use a small delay to make likely a first-try success. 174 | set retval 0 175 | while {[incr retrynum -1]} { 176 | if {[catch {ping_server $host $port} ping]} { 177 | set ping 0 178 | } 179 | if {$ping} {return 1} 180 | after 50 181 | } 182 | return 0 183 | } 184 | 185 | # Check if current ::tags match requested tags. If ::allowtags are used, 186 | # there must be some intersection. If ::denytags are used, no intersection 187 | # is allowed. Returns 1 if tags are acceptable or 0 otherwise, in which 188 | # case err_return names a return variable for the message to be logged. 189 | proc tags_acceptable {tags err_return} { 190 | upvar $err_return err 191 | 192 | # If tags are whitelisted, make sure there's match 193 | if {[llength $::allowtags] > 0} { 194 | set matched 0 195 | foreach tag $::allowtags { 196 | if {[lsearch $tags $tag] >= 0} { 197 | incr matched 198 | } 199 | } 200 | if {$matched < 1} { 201 | set err "Tag: none of the tags allowed" 202 | return 0 203 | } 204 | } 205 | 206 | foreach tag $::denytags { 207 | if {[lsearch $tags $tag] >= 0} { 208 | set err "Tag: $tag denied" 209 | return 0 210 | } 211 | } 212 | 213 | # some units mess with the client output buffer so we can't really use the req-res logging mechanism. 214 | if {$::log_req_res && [lsearch $tags "logreqres:skip"] >= 0} { 215 | set err "Not supported when running in log-req-res mode" 216 | return 0 217 | } 218 | 219 | if {$::external && [lsearch $tags "external:skip"] >= 0} { 220 | set err "Not supported on external server" 221 | return 0 222 | } 223 | 224 | if {$::singledb && [lsearch $tags "singledb:skip"] >= 0} { 225 | set err "Not supported on singledb" 226 | return 0 227 | } 228 | 229 | if {$::cluster_mode && [lsearch $tags "cluster:skip"] >= 0} { 230 | set err "Not supported in cluster mode" 231 | return 0 232 | } 233 | 234 | if {$::tls && [lsearch $tags "tls:skip"] >= 0} { 235 | set err "Not supported in tls mode" 236 | return 0 237 | } 238 | 239 | if {!$::large_memory && [lsearch $tags "large-memory"] >= 0} { 240 | set err "large memory flag not provided" 241 | return 0 242 | } 243 | 244 | return 1 245 | } 246 | 247 | # doesn't really belong here, but highly coupled to code in start_server 248 | proc tags {tags code} { 249 | # If we 'tags' contain multiple tags, quoted and separated by spaces, 250 | # we want to get rid of the quotes in order to have a proper list 251 | set tags [string map { \" "" } $tags] 252 | set ::tags [concat $::tags $tags] 253 | if {![tags_acceptable $::tags err]} { 254 | incr ::num_aborted 255 | send_data_packet $::test_server_fd ignore $err 256 | set ::tags [lrange $::tags 0 end-[llength $tags]] 257 | return 258 | } 259 | uplevel 1 $code 260 | set ::tags [lrange $::tags 0 end-[llength $tags]] 261 | } 262 | 263 | # Write the configuration in the dictionary 'config' in the specified 264 | # file name. 265 | proc create_server_config_file {filename config config_lines} { 266 | set fp [open $filename w+] 267 | foreach directive [dict keys $config] { 268 | puts -nonewline $fp "$directive " 269 | puts $fp [dict get $config $directive] 270 | } 271 | foreach {config_line_directive config_line_args} $config_lines { 272 | puts $fp "$config_line_directive $config_line_args" 273 | } 274 | close $fp 275 | } 276 | 277 | proc spawn_server {config_file stdout stderr args} { 278 | set cmd [list src/redis-server $config_file] 279 | set args {*}$args 280 | if {[llength $args] > 0} { 281 | lappend cmd {*}$args 282 | } 283 | 284 | if {$::valgrind} { 285 | set pid [exec valgrind --track-origins=yes --trace-children=yes --suppressions=[pwd]/src/valgrind.sup --show-reachable=no --show-possibly-lost=no --leak-check=full {*}$cmd >> $stdout 2>> $stderr &] 286 | } elseif ($::stack_logging) { 287 | set pid [exec /usr/bin/env MallocStackLogging=1 MallocLogFile=/tmp/malloc_log.txt {*}$cmd >> $stdout 2>> $stderr &] 288 | } else { 289 | # ASAN_OPTIONS environment variable is for address sanitizer. If a test 290 | # tries to allocate huge memory area and expects allocator to return 291 | # NULL, address sanitizer throws an error without this setting. 292 | set pid [exec /usr/bin/env ASAN_OPTIONS=allocator_may_return_null=1 {*}$cmd >> $stdout 2>> $stderr &] 293 | } 294 | 295 | if {$::wait_server} { 296 | set msg "server started PID: $pid. press any key to continue..." 297 | puts $msg 298 | read stdin 1 299 | } 300 | 301 | # Tell the test server about this new instance. 302 | send_data_packet $::test_server_fd server-spawned $pid 303 | return $pid 304 | } 305 | 306 | # Wait for actual startup, return 1 if port is busy, 0 otherwise 307 | proc wait_server_started {config_file stdout pid} { 308 | set checkperiod 100; # Milliseconds 309 | set maxiter [expr {120*1000/$checkperiod}] ; # Wait up to 2 minutes. 310 | set port_busy 0 311 | while 1 { 312 | if {[regexp -- " PID: $pid.*Server initialized" [exec cat $stdout]]} { 313 | break 314 | } 315 | after $checkperiod 316 | incr maxiter -1 317 | if {$maxiter == 0} { 318 | start_server_error $config_file "No PID detected in log $stdout" 319 | puts "--- LOG CONTENT ---" 320 | puts [exec cat $stdout] 321 | puts "-------------------" 322 | break 323 | } 324 | 325 | # Check if the port is actually busy and the server failed 326 | # for this reason. 327 | if {[regexp {Failed listening on port} [exec cat $stdout]]} { 328 | set port_busy 1 329 | break 330 | } 331 | } 332 | return $port_busy 333 | } 334 | 335 | proc dump_server_log {srv} { 336 | set pid [dict get $srv "pid"] 337 | puts "\n===== Start of server log (pid $pid) =====\n" 338 | puts [exec cat [dict get $srv "stdout"]] 339 | puts "===== End of server log (pid $pid) =====\n" 340 | 341 | puts "\n===== Start of server stderr log (pid $pid) =====\n" 342 | puts [exec cat [dict get $srv "stderr"]] 343 | puts "===== End of server stderr log (pid $pid) =====\n" 344 | } 345 | 346 | proc run_external_server_test {code overrides} { 347 | set srv {} 348 | dict set srv "host" $::host 349 | dict set srv "port" $::port 350 | set client [redis $::host $::port 0 $::tls] 351 | dict set srv "client" $client 352 | if {!$::singledb} { 353 | $client select 9 354 | } 355 | 356 | set config {} 357 | dict set config "port" $::port 358 | dict set srv "config" $config 359 | 360 | # append the server to the stack 361 | lappend ::servers $srv 362 | 363 | if {[llength $::servers] > 1} { 364 | if {$::verbose} { 365 | puts "Notice: nested start_server statements in external server mode, test must be aware of that!" 366 | } 367 | } 368 | 369 | r flushall 370 | r function flush 371 | 372 | # store configs 373 | set saved_config {} 374 | foreach {param val} [r config get *] { 375 | dict set saved_config $param $val 376 | } 377 | 378 | # apply overrides 379 | foreach {param val} $overrides { 380 | r config set $param $val 381 | 382 | # If we enable appendonly, wait for for rewrite to complete. This is 383 | # required for tests that begin with a bg* command which will fail if 384 | # the rewriteaof operation is not completed at this point. 385 | if {$param == "appendonly" && $val == "yes"} { 386 | waitForBgrewriteaof r 387 | } 388 | } 389 | 390 | if {[catch {set retval [uplevel 2 $code]} error]} { 391 | if {$::durable} { 392 | set msg [string range $error 10 end] 393 | lappend details $msg 394 | lappend details $::errorInfo 395 | lappend ::tests_failed $details 396 | 397 | incr ::num_failed 398 | send_data_packet $::test_server_fd err [join $details "\n"] 399 | } else { 400 | # Re-raise, let handler up the stack take care of this. 401 | error $error $::errorInfo 402 | } 403 | } 404 | 405 | # restore overrides 406 | dict for {param val} $saved_config { 407 | # some may fail, specifically immutable ones. 408 | catch {r config set $param $val} 409 | } 410 | 411 | set srv [lpop ::servers] 412 | 413 | if {[dict exists $srv "client"]} { 414 | [dict get $srv "client"] close 415 | } 416 | } 417 | 418 | proc start_server {options {code undefined}} { 419 | # setup defaults 420 | set baseconfig "default.conf" 421 | set overrides {} 422 | set omit {} 423 | set tags {} 424 | set args {} 425 | set keep_persistence false 426 | set config_lines {} 427 | 428 | # Wait for the server to be ready and check for server liveness/client connectivity before starting the test. 429 | set wait_ready true 430 | 431 | # parse options 432 | foreach {option value} $options { 433 | switch $option { 434 | "config" { 435 | set baseconfig $value 436 | } 437 | "overrides" { 438 | set overrides [concat $overrides $value] 439 | } 440 | "config_lines" { 441 | set config_lines $value 442 | } 443 | "args" { 444 | set args $value 445 | } 446 | "omit" { 447 | set omit $value 448 | } 449 | "tags" { 450 | # If we 'tags' contain multiple tags, quoted and separated by spaces, 451 | # we want to get rid of the quotes in order to have a proper list 452 | set tags [string map { \" "" } $value] 453 | set ::tags [concat $::tags $tags] 454 | } 455 | "keep_persistence" { 456 | set keep_persistence $value 457 | } 458 | "wait_ready" { 459 | set wait_ready $value 460 | } 461 | default { 462 | error "Unknown option $option" 463 | } 464 | } 465 | } 466 | 467 | # We skip unwanted tags 468 | if {![tags_acceptable $::tags err]} { 469 | incr ::num_aborted 470 | send_data_packet $::test_server_fd ignore $err 471 | set ::tags [lrange $::tags 0 end-[llength $tags]] 472 | return 473 | } 474 | 475 | # If we are running against an external server, we just push the 476 | # host/port pair in the stack the first time 477 | if {$::external} { 478 | run_external_server_test $code $overrides 479 | 480 | set ::tags [lrange $::tags 0 end-[llength $tags]] 481 | return 482 | } 483 | 484 | set data [split [exec cat "tests/assets/$baseconfig"] "\n"] 485 | set config {} 486 | if {$::tls} { 487 | if {$::tls_module} { 488 | lappend config_lines [list "loadmodule" [format "%s/src/redis-tls.so" [pwd]]] 489 | } 490 | dict set config "tls-cert-file" [format "%s/tests/tls/server.crt" [pwd]] 491 | dict set config "tls-key-file" [format "%s/tests/tls/server.key" [pwd]] 492 | dict set config "tls-client-cert-file" [format "%s/tests/tls/client.crt" [pwd]] 493 | dict set config "tls-client-key-file" [format "%s/tests/tls/client.key" [pwd]] 494 | dict set config "tls-dh-params-file" [format "%s/tests/tls/redis.dh" [pwd]] 495 | dict set config "tls-ca-cert-file" [format "%s/tests/tls/ca.crt" [pwd]] 496 | dict set config "loglevel" "debug" 497 | } 498 | foreach line $data { 499 | if {[string length $line] > 0 && [string index $line 0] ne "#"} { 500 | set elements [split $line " "] 501 | set directive [lrange $elements 0 0] 502 | set arguments [lrange $elements 1 end] 503 | dict set config $directive $arguments 504 | } 505 | } 506 | 507 | # use a different directory every time a server is started 508 | dict set config dir [tmpdir server] 509 | 510 | # start every server on a different port 511 | set port [find_available_port $::baseport $::portcount] 512 | if {$::tls} { 513 | set pport [find_available_port $::baseport $::portcount] 514 | dict set config "port" $pport 515 | dict set config "tls-port" $port 516 | dict set config "tls-cluster" "yes" 517 | dict set config "tls-replication" "yes" 518 | } else { 519 | dict set config port $port 520 | } 521 | 522 | set unixsocket [file normalize [format "%s/%s" [dict get $config "dir"] "socket"]] 523 | dict set config "unixsocket" $unixsocket 524 | 525 | # apply overrides from global space and arguments 526 | foreach {directive arguments} [concat $::global_overrides $overrides] { 527 | dict set config $directive $arguments 528 | } 529 | 530 | # remove directives that are marked to be omitted 531 | foreach directive $omit { 532 | dict unset config $directive 533 | } 534 | 535 | if {$::log_req_res} { 536 | dict set config "req-res-logfile" "stdout.reqres" 537 | } 538 | 539 | if {$::force_resp3} { 540 | dict set config "client-default-resp" "3" 541 | } 542 | 543 | # write new configuration to temporary file 544 | set config_file [tmpfile redis.conf] 545 | create_server_config_file $config_file $config $config_lines 546 | 547 | set stdout [format "%s/%s" [dict get $config "dir"] "stdout"] 548 | set stderr [format "%s/%s" [dict get $config "dir"] "stderr"] 549 | 550 | # if we're inside a test, write the test name to the server log file 551 | if {[info exists ::cur_test]} { 552 | set fd [open $stdout "a+"] 553 | puts $fd "### Starting server for test $::cur_test" 554 | close $fd 555 | if {$::verbose > 1} { 556 | puts "### Starting server $stdout for test - $::cur_test" 557 | } 558 | } 559 | 560 | # We may have a stdout left over from the previous tests, so we need 561 | # to get the current count of ready logs 562 | set previous_ready_count [count_message_lines $stdout "Ready to accept"] 563 | 564 | # We need a loop here to retry with different ports. 565 | set server_started 0 566 | while {$server_started == 0} { 567 | if {$::verbose} { 568 | puts -nonewline "=== ($tags) Starting server ${::host}:${port} " 569 | } 570 | 571 | send_data_packet $::test_server_fd "server-spawning" "port $port" 572 | 573 | set pid [spawn_server $config_file $stdout $stderr $args] 574 | 575 | # check that the server actually started 576 | set port_busy [wait_server_started $config_file $stdout $pid] 577 | 578 | # Sometimes we have to try a different port, even if we checked 579 | # for availability. Other test clients may grab the port before we 580 | # are able to do it for example. 581 | if {$port_busy} { 582 | puts "Port $port was already busy, trying another port..." 583 | set port [find_available_port $::baseport $::portcount] 584 | if {$::tls} { 585 | set pport [find_available_port $::baseport $::portcount] 586 | dict set config port $pport 587 | dict set config "tls-port" $port 588 | } else { 589 | dict set config port $port 590 | } 591 | create_server_config_file $config_file $config $config_lines 592 | 593 | # Truncate log so wait_server_started will not be looking at 594 | # output of the failed server. 595 | close [open $stdout "w"] 596 | 597 | continue; # Try again 598 | } 599 | 600 | if {$::valgrind} {set retrynum 1000} else {set retrynum 100} 601 | if {$code ne "undefined" && $wait_ready} { 602 | set serverisup [server_is_up $::host $port $retrynum] 603 | } else { 604 | set serverisup 1 605 | } 606 | 607 | if {$::verbose} { 608 | puts "" 609 | } 610 | 611 | if {!$serverisup} { 612 | set err {} 613 | append err [exec cat $stdout] "\n" [exec cat $stderr] 614 | start_server_error $config_file $err 615 | return 616 | } 617 | set server_started 1 618 | } 619 | 620 | # setup properties to be able to initialize a client object 621 | set port_param [expr $::tls ? {"tls-port"} : {"port"}] 622 | set host $::host 623 | if {[dict exists $config bind]} { set host [dict get $config bind] } 624 | if {[dict exists $config $port_param]} { set port [dict get $config $port_param] } 625 | 626 | # setup config dict 627 | dict set srv "config_file" $config_file 628 | dict set srv "config" $config 629 | dict set srv "pid" $pid 630 | dict set srv "host" $host 631 | dict set srv "port" $port 632 | dict set srv "stdout" $stdout 633 | dict set srv "stderr" $stderr 634 | dict set srv "unixsocket" $unixsocket 635 | if {$::tls} { 636 | dict set srv "pport" $pport 637 | } 638 | 639 | # if a block of code is supplied, we wait for the server to become 640 | # available, create a client object and kill the server afterwards 641 | if {$code ne "undefined"} { 642 | set line [exec head -n1 $stdout] 643 | if {[string match {*already in use*} $line]} { 644 | error_and_quit $config_file $line 645 | } 646 | 647 | # append the server to the stack 648 | lappend ::servers $srv 649 | 650 | if {$wait_ready} { 651 | while 1 { 652 | # check that the server actually started and is ready for connections 653 | if {[count_message_lines $stdout "Ready to accept"] > $previous_ready_count} { 654 | break 655 | } 656 | after 10 657 | } 658 | 659 | # connect client (after server dict is put on the stack) 660 | reconnect 661 | } 662 | 663 | # remember previous num_failed to catch new errors 664 | set prev_num_failed $::num_failed 665 | 666 | # execute provided block 667 | set num_tests $::num_tests 668 | if {[catch { uplevel 1 $code } error]} { 669 | set backtrace $::errorInfo 670 | set assertion [string match "assertion:*" $error] 671 | 672 | # fetch srv back from the server list, in case it was restarted by restart_server (new PID) 673 | set srv [lindex $::servers end] 674 | 675 | # pop the server object 676 | set ::servers [lrange $::servers 0 end-1] 677 | 678 | # Kill the server without checking for leaks 679 | dict set srv "skipleaks" 1 680 | kill_server $srv 681 | 682 | if {$::dump_logs && $assertion} { 683 | # if we caught an assertion ($::num_failed isn't incremented yet) 684 | # this happens when the test spawns a server and not the other way around 685 | dump_server_log $srv 686 | } else { 687 | # Print crash report from log 688 | set crashlog [crashlog_from_file [dict get $srv "stdout"]] 689 | if {[string length $crashlog] > 0} { 690 | puts [format "\nLogged crash report (pid %d):" [dict get $srv "pid"]] 691 | puts "$crashlog" 692 | puts "" 693 | } 694 | 695 | set sanitizerlog [sanitizer_errors_from_file [dict get $srv "stderr"]] 696 | if {[string length $sanitizerlog] > 0} { 697 | puts [format "\nLogged sanitizer errors (pid %d):" [dict get $srv "pid"]] 698 | puts "$sanitizerlog" 699 | puts "" 700 | } 701 | } 702 | 703 | if {!$assertion && $::durable} { 704 | # durable is meant to prevent the whole tcl test from exiting on 705 | # an exception. an assertion will be caught by the test proc. 706 | set msg [string range $error 10 end] 707 | lappend details $msg 708 | lappend details $backtrace 709 | lappend ::tests_failed $details 710 | 711 | incr ::num_failed 712 | send_data_packet $::test_server_fd err [join $details "\n"] 713 | } else { 714 | # Re-raise, let handler up the stack take care of this. 715 | error $error $backtrace 716 | } 717 | } else { 718 | if {$::dump_logs && $prev_num_failed != $::num_failed} { 719 | dump_server_log $srv 720 | } 721 | } 722 | 723 | # fetch srv back from the server list, in case it was restarted by restart_server (new PID) 724 | set srv [lindex $::servers end] 725 | 726 | # Don't do the leak check when no tests were run 727 | if {$num_tests == $::num_tests} { 728 | dict set srv "skipleaks" 1 729 | } 730 | 731 | # pop the server object 732 | set ::servers [lrange $::servers 0 end-1] 733 | 734 | set ::tags [lrange $::tags 0 end-[llength $tags]] 735 | kill_server $srv 736 | if {!$keep_persistence} { 737 | clean_persistence $srv 738 | } 739 | set _ "" 740 | } else { 741 | set ::tags [lrange $::tags 0 end-[llength $tags]] 742 | set _ $srv 743 | } 744 | } 745 | 746 | # Start multiple servers with the same options, run code, then stop them. 747 | proc start_multiple_servers {num options code} { 748 | for {set i 0} {$i < $num} {incr i} { 749 | set code [list start_server $options $code] 750 | } 751 | uplevel 1 $code 752 | } 753 | 754 | proc restart_server {level wait_ready rotate_logs {reconnect 1} {shutdown sigterm}} { 755 | set srv [lindex $::servers end+$level] 756 | if {$shutdown ne {sigterm}} { 757 | catch {[dict get $srv "client"] shutdown $shutdown} 758 | } 759 | # Kill server doesn't mind if the server is already dead 760 | kill_server $srv 761 | # Remove the default client from the server 762 | dict unset srv "client" 763 | 764 | set pid [dict get $srv "pid"] 765 | set stdout [dict get $srv "stdout"] 766 | set stderr [dict get $srv "stderr"] 767 | if {$rotate_logs} { 768 | set ts [clock format [clock seconds] -format %y%m%d%H%M%S] 769 | file rename $stdout $stdout.$ts.$pid 770 | file rename $stderr $stderr.$ts.$pid 771 | } 772 | set prev_ready_count [count_message_lines $stdout "Ready to accept"] 773 | 774 | # if we're inside a test, write the test name to the server log file 775 | if {[info exists ::cur_test]} { 776 | set fd [open $stdout "a+"] 777 | puts $fd "### Restarting server for test $::cur_test" 778 | close $fd 779 | } 780 | 781 | set config_file [dict get $srv "config_file"] 782 | 783 | set pid [spawn_server $config_file $stdout $stderr {}] 784 | 785 | # check that the server actually started 786 | wait_server_started $config_file $stdout $pid 787 | 788 | # update the pid in the servers list 789 | dict set srv "pid" $pid 790 | # re-set $srv in the servers list 791 | lset ::servers end+$level $srv 792 | 793 | if {$wait_ready} { 794 | while 1 { 795 | # check that the server actually started and is ready for connections 796 | if {[count_message_lines $stdout "Ready to accept"] > $prev_ready_count} { 797 | break 798 | } 799 | after 10 800 | } 801 | } 802 | if {$reconnect} { 803 | reconnect $level 804 | } 805 | } 806 | -------------------------------------------------------------------------------- /tcltests/test_helper.tcl: -------------------------------------------------------------------------------- 1 | # Redis test suite. 2 | # 3 | # Copyright (C) 2014-Present, Redis Ltd. 4 | # All Rights reserved. 5 | # 6 | # Licensed under your choice of the Redis Source Available License 2.0 7 | # (RSALv2) or the Server Side Public License v1 (SSPLv1). 8 | 9 | package require Tcl 8.5 10 | 11 | set tcl_precision 17 12 | source tcltests/support/redis.tcl 13 | source tcltests/support/aofmanifest.tcl 14 | source tcltests/support/server.tcl 15 | source tcltests/support/cluster_util.tcl 16 | source tcltests/support/tmpfile.tcl 17 | source tcltests/support/test.tcl 18 | source tcltests/support/util.tcl 19 | 20 | set dir [pwd] 21 | set ::all_tests [] 22 | 23 | set test_dirs { 24 | unit 25 | integration 26 | } 27 | 28 | foreach test_dir $test_dirs { 29 | set files [glob -nocomplain $dir/tcltests/$test_dir/*.tcl] 30 | 31 | foreach file [lsort $files] { 32 | lappend ::all_tests $test_dir/[file root [file tail $file]] 33 | } 34 | } 35 | # Index to the next test to run in the ::all_tests list. 36 | set ::next_test 0 37 | 38 | set ::host 127.0.0.1 39 | set ::port 7379; # port for external server 40 | set ::baseport 21111; # initial port for spawned redis servers 41 | set ::portcount 8000; # we don't wanna use more than 10000 to avoid collision with cluster bus ports 42 | set ::traceleaks 0 43 | set ::valgrind 0 44 | set ::durable 0 45 | set ::tls 0 46 | set ::tls_module 0 47 | set ::stack_logging 0 48 | set ::verbose 0 49 | set ::quiet 0 50 | set ::denytags {} 51 | set ::skiptests {} 52 | set ::skipunits {} 53 | set ::no_latency 0 54 | set ::allowtags {} 55 | set ::only_tests {} 56 | set ::single_tests {} 57 | set ::run_solo_tests {} 58 | set ::skip_till "" 59 | set ::external 0; # If "1" this means, we are running against external instance 60 | set ::file ""; # If set, runs only the tests in this comma separated list 61 | set ::curfile ""; # Hold the filename of the current suite 62 | set ::accurate 0; # If true runs fuzz tests with more iterations 63 | set ::force_failure 0 64 | set ::timeout 1200; # 20 minutes without progresses will quit the test. 65 | set ::last_progress [clock seconds] 66 | set ::active_servers {} ; # Pids of active Redis instances. 67 | set ::dont_clean 0 68 | set ::dont_pre_clean 0 69 | set ::wait_server 0 70 | set ::stop_on_failure 0 71 | set ::dump_logs 0 72 | set ::loop 0 73 | set ::tlsdir "tcltests/tls" 74 | set ::singledb 0 75 | set ::cluster_mode 0 76 | set ::ignoreencoding 0 77 | set ::ignoredigest 0 78 | set ::large_memory 0 79 | set ::log_req_res 0 80 | set ::force_resp3 0 81 | 82 | # Set to 1 when we are running in client mode. The Redis test uses a 83 | # server-client model to run tests simultaneously. The server instance 84 | # runs the specified number of client instances that will actually run tests. 85 | # The server is responsible of showing the result to the user, and exit with 86 | # the appropriate exit code depending on the test outcome. 87 | set ::client 0 88 | set ::numclients 16 89 | 90 | # This function is called by one of the test clients when it receives 91 | # a "run" command from the server, with a filename as data. 92 | # It will run the specified test source file and signal it to the 93 | # test server when finished. 94 | proc execute_test_file __testname { 95 | set path "tcltests/$__testname.tcl" 96 | set ::curfile $path 97 | source $path 98 | send_data_packet $::test_server_fd done "$__testname" 99 | } 100 | 101 | # This function is called by one of the test clients when it receives 102 | # a "run_code" command from the server, with a verbatim test source code 103 | # as argument, and an associated name. 104 | # It will run the specified code and signal it to the test server when 105 | # finished. 106 | proc execute_test_code {__testname filename code} { 107 | set ::curfile $filename 108 | eval $code 109 | send_data_packet $::test_server_fd done "$__testname" 110 | } 111 | 112 | # Setup a list to hold a stack of server configs. When calls to start_server 113 | # are nested, use "srv 0 pid" to get the pid of the inner server. To access 114 | # outer servers, use "srv -1 pid" etcetera. 115 | set ::servers {} 116 | proc srv {args} { 117 | set level 0 118 | if {[string is integer [lindex $args 0]]} { 119 | set level [lindex $args 0] 120 | set property [lindex $args 1] 121 | } else { 122 | set property [lindex $args 0] 123 | } 124 | set srv [lindex $::servers end+$level] 125 | dict get $srv $property 126 | } 127 | 128 | # Take an index to get a srv. 129 | proc get_srv {level} { 130 | set srv [lindex $::servers end+$level] 131 | return $srv 132 | } 133 | 134 | # Provide easy access to the client for the inner server. It's possible to 135 | # prepend the argument list with a negative level to access clients for 136 | # servers running in outer blocks. 137 | proc r {args} { 138 | set level 0 139 | if {[string is integer [lindex $args 0]]} { 140 | set level [lindex $args 0] 141 | set args [lrange $args 1 end] 142 | } 143 | [srv $level "client"] {*}$args 144 | } 145 | 146 | # Returns a Redis instance by index. 147 | proc Rn {n} { 148 | set level [expr -1*$n] 149 | return [srv $level "client"] 150 | } 151 | 152 | # Provide easy access to a client for an inner server. Requires a positive 153 | # index, unlike r which uses an optional negative index. 154 | proc R {n args} { 155 | [Rn $n] {*}$args 156 | } 157 | 158 | proc reconnect {args} { 159 | set level [lindex $args 0] 160 | if {[string length $level] == 0 || ![string is integer $level]} { 161 | set level 0 162 | } 163 | 164 | set srv [lindex $::servers end+$level] 165 | set host [dict get $srv "host"] 166 | set port [dict get $srv "port"] 167 | set config [dict get $srv "config"] 168 | set client [redis $host $port 0 $::tls] 169 | if {[dict exists $srv "client"]} { 170 | set old [dict get $srv "client"] 171 | $old close 172 | } 173 | dict set srv "client" $client 174 | 175 | # select the right db when we don't have to authenticate 176 | if {![dict exists $config "requirepass"] && !$::singledb} { 177 | $client select 9 178 | } 179 | 180 | # re-set $srv in the servers list 181 | lset ::servers end+$level $srv 182 | } 183 | 184 | proc redis_deferring_client {args} { 185 | set level 0 186 | if {[llength $args] > 0 && [string is integer [lindex $args 0]]} { 187 | set level [lindex $args 0] 188 | set args [lrange $args 1 end] 189 | } 190 | 191 | # create client that defers reading reply 192 | set client [redis [srv $level "host"] [srv $level "port"] 1 $::tls] 193 | 194 | # select the right db and read the response (OK) 195 | if {!$::singledb} { 196 | $client select 9 197 | $client read 198 | } else { 199 | # For timing/symmetry with the above select 200 | $client ping 201 | $client read 202 | } 203 | return $client 204 | } 205 | 206 | proc redis_client {args} { 207 | set level 0 208 | if {[llength $args] > 0 && [string is integer [lindex $args 0]]} { 209 | set level [lindex $args 0] 210 | set args [lrange $args 1 end] 211 | } 212 | 213 | # create client that won't defers reading reply 214 | set client [redis [srv $level "host"] [srv $level "port"] 0 $::tls] 215 | 216 | # select the right db and read the response (OK), or at least ping 217 | # the server if we're in a singledb mode. 218 | if {$::singledb} { 219 | $client ping 220 | } else { 221 | $client select 9 222 | } 223 | return $client 224 | } 225 | 226 | # Provide easy access to INFO properties. Same semantic as "proc r". 227 | proc s {args} { 228 | set level 0 229 | if {[string is integer [lindex $args 0]]} { 230 | set level [lindex $args 0] 231 | set args [lrange $args 1 end] 232 | } 233 | status [srv $level "client"] [lindex $args 0] 234 | } 235 | 236 | # Get the specified field from the givens instances cluster info output. 237 | proc CI {index field} { 238 | getInfoProperty [R $index cluster info] $field 239 | } 240 | 241 | # Test wrapped into run_solo are sent back from the client to the 242 | # test server, so that the test server will send them again to 243 | # clients once the clients are idle. 244 | proc run_solo {name code} { 245 | if {$::numclients == 1 || $::loop || $::external} { 246 | # run_solo is not supported in these scenarios, just run the code. 247 | eval $code 248 | return 249 | } 250 | send_data_packet $::test_server_fd run_solo [list $name $::curfile $code] 251 | } 252 | 253 | proc cleanup {} { 254 | if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "} 255 | flush stdout 256 | catch {exec rm -rf {*}[glob tcltests/tmp/redis.conf.*]} 257 | catch {exec rm -rf {*}[glob tcltests/tmp/server.*]} 258 | if {!$::quiet} {puts "OK"} 259 | } 260 | 261 | proc test_server_main {} { 262 | if {!$::dont_pre_clean} cleanup 263 | set tclsh [info nameofexecutable] 264 | # Open a listening socket, trying different ports in order to find a 265 | # non busy one. 266 | set clientport [find_available_port [expr {$::baseport - 32}] 32] 267 | if {!$::quiet} { 268 | puts "Starting test server at port $clientport" 269 | } 270 | socket -server accept_test_clients -myaddr 127.0.0.1 $clientport 271 | 272 | # Start the client instances 273 | set ::clients_pids {} 274 | if {$::external} { 275 | set p [exec $tclsh [info script] {*}$::argv \ 276 | --client $clientport &] 277 | lappend ::clients_pids $p 278 | } else { 279 | set start_port $::baseport 280 | set port_count [expr {$::portcount / $::numclients}] 281 | for {set j 0} {$j < $::numclients} {incr j} { 282 | set p [exec $tclsh [info script] {*}$::argv \ 283 | --client $clientport --baseport $start_port --portcount $port_count &] 284 | lappend ::clients_pids $p 285 | incr start_port $port_count 286 | } 287 | } 288 | 289 | # Setup global state for the test server 290 | set ::idle_clients {} 291 | set ::active_clients {} 292 | array set ::active_clients_task {} 293 | array set ::clients_start_time {} 294 | set ::clients_time_history {} 295 | set ::failed_tests {} 296 | 297 | # Enter the event loop to handle clients I/O 298 | after 100 test_server_cron 299 | vwait forever 300 | } 301 | 302 | # This function gets called 10 times per second. 303 | proc test_server_cron {} { 304 | set elapsed [expr {[clock seconds]-$::last_progress}] 305 | 306 | if {$elapsed > $::timeout} { 307 | set err "\[[colorstr red TIMEOUT]\]: clients state report follows." 308 | puts $err 309 | lappend ::failed_tests $err 310 | show_clients_state 311 | kill_clients 312 | force_kill_all_servers 313 | the_end 314 | } 315 | 316 | after 100 test_server_cron 317 | } 318 | 319 | proc accept_test_clients {fd addr port} { 320 | fconfigure $fd -encoding binary 321 | fileevent $fd readable [list read_from_test_client $fd] 322 | } 323 | 324 | # This is the readable handler of our test server. Clients send us messages 325 | # in the form of a status code such and additional data. Supported 326 | # status types are: 327 | # 328 | # ready: the client is ready to execute the command. Only sent at client 329 | # startup. The server will queue the client FD in the list of idle 330 | # clients. 331 | # testing: just used to signal that a given test started. 332 | # ok: a test was executed with success. 333 | # err: a test was executed with an error. 334 | # skip: a test was skipped by skipfile or individual test options. 335 | # ignore: a test was skipped by a group tag. 336 | # exception: there was a runtime exception while executing the test. 337 | # done: all the specified test file was processed, this test client is 338 | # ready to accept a new task. 339 | proc read_from_test_client fd { 340 | set bytes [gets $fd] 341 | set payload [read $fd $bytes] 342 | foreach {status data elapsed} $payload break 343 | set ::last_progress [clock seconds] 344 | 345 | if {$status eq {ready}} { 346 | if {!$::quiet} { 347 | puts "\[$status\]: $data" 348 | } 349 | signal_idle_client $fd 350 | } elseif {$status eq {done}} { 351 | set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}] 352 | set all_tests_count [llength $::all_tests] 353 | set running_tests_count [expr {[llength $::active_clients]-1}] 354 | set completed_tests_count [expr {$::next_test-$running_tests_count}] 355 | puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)" 356 | lappend ::clients_time_history $elapsed $data 357 | signal_idle_client $fd 358 | set ::active_clients_task($fd) "(DONE) $data" 359 | } elseif {$status eq {ok}} { 360 | if {!$::quiet} { 361 | puts "\[[colorstr green $status]\]: $data ($elapsed ms)" 362 | } 363 | set ::active_clients_task($fd) "(OK) $data" 364 | } elseif {$status eq {skip}} { 365 | if {!$::quiet} { 366 | puts "\[[colorstr yellow $status]\]: $data" 367 | } 368 | } elseif {$status eq {ignore}} { 369 | if {!$::quiet} { 370 | puts "\[[colorstr cyan $status]\]: $data" 371 | } 372 | } elseif {$status eq {err}} { 373 | set err "\[[colorstr red $status]\]: $data" 374 | puts $err 375 | lappend ::failed_tests $err 376 | set ::active_clients_task($fd) "(ERR) $data" 377 | if {$::stop_on_failure} { 378 | puts -nonewline "(Test stopped, press enter to resume the tests)" 379 | flush stdout 380 | gets stdin 381 | } 382 | } elseif {$status eq {exception}} { 383 | puts "\[[colorstr red $status]\]: $data" 384 | kill_clients 385 | force_kill_all_servers 386 | exit 1 387 | } elseif {$status eq {testing}} { 388 | set ::active_clients_task($fd) "(IN PROGRESS) $data" 389 | } elseif {$status eq {server-spawning}} { 390 | set ::active_clients_task($fd) "(SPAWNING SERVER) $data" 391 | } elseif {$status eq {server-spawned}} { 392 | lappend ::active_servers $data 393 | set ::active_clients_task($fd) "(SPAWNED SERVER) pid:$data" 394 | } elseif {$status eq {server-killing}} { 395 | set ::active_clients_task($fd) "(KILLING SERVER) pid:$data" 396 | } elseif {$status eq {server-killed}} { 397 | set ::active_servers [lsearch -all -inline -not -exact $::active_servers $data] 398 | set ::active_clients_task($fd) "(KILLED SERVER) pid:$data" 399 | } elseif {$status eq {run_solo}} { 400 | lappend ::run_solo_tests $data 401 | } else { 402 | if {!$::quiet} { 403 | puts "\[$status\]: $data" 404 | } 405 | } 406 | } 407 | 408 | proc show_clients_state {} { 409 | # The following loop is only useful for debugging tests that may 410 | # enter an infinite loop. 411 | foreach x $::active_clients { 412 | if {[info exist ::active_clients_task($x)]} { 413 | puts "$x => $::active_clients_task($x)" 414 | } else { 415 | puts "$x => ???" 416 | } 417 | } 418 | } 419 | 420 | proc kill_clients {} { 421 | foreach p $::clients_pids { 422 | catch {exec kill $p} 423 | } 424 | } 425 | 426 | proc force_kill_all_servers {} { 427 | foreach p $::active_servers { 428 | puts "Killing still running Redis server $p" 429 | catch {exec kill -9 $p} 430 | } 431 | } 432 | 433 | proc lpop {listVar {count 1}} { 434 | upvar 1 $listVar l 435 | set ele [lindex $l 0] 436 | set l [lrange $l 1 end] 437 | set ele 438 | } 439 | 440 | proc lremove {listVar value} { 441 | upvar 1 $listVar var 442 | set idx [lsearch -exact $var $value] 443 | set var [lreplace $var $idx $idx] 444 | } 445 | 446 | # A new client is idle. Remove it from the list of active clients and 447 | # if there are still test units to run, launch them. 448 | proc signal_idle_client fd { 449 | # Remove this fd from the list of active clients. 450 | set ::active_clients \ 451 | [lsearch -all -inline -not -exact $::active_clients $fd] 452 | 453 | # New unit to process? 454 | if {$::next_test != [llength $::all_tests]} { 455 | if {!$::quiet} { 456 | puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"] 457 | set ::active_clients_task($fd) "ASSIGNED: $fd ([lindex $::all_tests $::next_test])" 458 | } 459 | set ::clients_start_time($fd) [clock seconds] 460 | send_data_packet $fd run [lindex $::all_tests $::next_test] 461 | lappend ::active_clients $fd 462 | incr ::next_test 463 | if {$::loop && $::next_test == [llength $::all_tests]} { 464 | set ::next_test 0 465 | incr ::loop -1 466 | } 467 | } elseif {[llength $::run_solo_tests] != 0 && [llength $::active_clients] == 0} { 468 | if {!$::quiet} { 469 | puts [colorstr bold-white "Testing solo test"] 470 | set ::active_clients_task($fd) "ASSIGNED: $fd solo test" 471 | } 472 | set ::clients_start_time($fd) [clock seconds] 473 | send_data_packet $fd run_code [lpop ::run_solo_tests] 474 | lappend ::active_clients $fd 475 | } else { 476 | lappend ::idle_clients $fd 477 | set ::active_clients_task($fd) "SLEEPING, no more units to assign" 478 | if {[llength $::active_clients] == 0} { 479 | the_end 480 | } 481 | } 482 | } 483 | 484 | # The the_end function gets called when all the test units were already 485 | # executed, so the test finished. 486 | proc the_end {} { 487 | # TODO: print the status, exit with the right exit code. 488 | puts "\n The End\n" 489 | puts "Execution time of different units:" 490 | foreach {time name} $::clients_time_history { 491 | puts " $time seconds - $name" 492 | } 493 | if {[llength $::failed_tests]} { 494 | puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n" 495 | foreach failed $::failed_tests { 496 | puts "*** $failed" 497 | } 498 | if {!$::dont_clean} cleanup 499 | exit 1 500 | } else { 501 | puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n" 502 | if {!$::dont_clean} cleanup 503 | exit 0 504 | } 505 | } 506 | 507 | # The client is not even driven (the test server is instead) as we just need 508 | # to read the command, execute, reply... all this in a loop. 509 | proc test_client_main server_port { 510 | set ::test_server_fd [socket localhost $server_port] 511 | fconfigure $::test_server_fd -encoding binary 512 | send_data_packet $::test_server_fd ready [pid] 513 | while 1 { 514 | set bytes [gets $::test_server_fd] 515 | set payload [read $::test_server_fd $bytes] 516 | foreach {cmd data} $payload break 517 | if {$cmd eq {run}} { 518 | execute_test_file $data 519 | } elseif {$cmd eq {run_code}} { 520 | foreach {name filename code} $data break 521 | execute_test_code $name $filename $code 522 | } else { 523 | error "Unknown test client command: $cmd" 524 | } 525 | } 526 | } 527 | 528 | proc send_data_packet {fd status data {elapsed 0}} { 529 | set payload [list $status $data $elapsed] 530 | puts $fd [string length $payload] 531 | puts -nonewline $fd $payload 532 | flush $fd 533 | } 534 | 535 | proc print_help_screen {} { 536 | puts [join { 537 | "--valgrind Run the test over valgrind." 538 | "--durable suppress test crashes and keep running" 539 | "--stack-logging Enable OSX leaks/malloc stack logging." 540 | "--accurate Run slow randomized tests for more iterations." 541 | "--quiet Don't show individual tests." 542 | "--single Just execute the specified unit (see next option). This option can be repeated." 543 | "--verbose Increases verbosity." 544 | "--list-tests List all the available test units." 545 | "--only Just execute the specified test by test name or tests that match regexp (if starts with '/'). This option can be repeated." 546 | "--skip-till Skip all units until (and including) the specified one." 547 | "--skipunit Skip one unit." 548 | "--clients Number of test clients (default 16)." 549 | "--timeout Test timeout in seconds (default 20 min)." 550 | "--force-failure Force the execution of a test that always fails." 551 | "--config Extra config file argument." 552 | "--skipfile Name of a file containing test names or regexp patterns (if starts with '/') that should be skipped (one per line). This option can be repeated." 553 | "--skiptest Test name or regexp pattern (if starts with '/') to skip. This option can be repeated." 554 | "--tags Run only tests having specified tags or not having '-' prefixed tags." 555 | "--dont-clean Don't delete redis log files after the run." 556 | "--dont-pre-clean Don't delete existing redis log files before the run." 557 | "--no-latency Skip latency measurements and validation by some tests." 558 | "--stop Blocks once the first test fails." 559 | "--loop Execute the specified set of tests forever." 560 | "--loops Execute the specified set of tests several times." 561 | "--wait-server Wait after server is started (so that you can attach a debugger)." 562 | "--dump-logs Dump server log on test failure." 563 | "--tls Run tests in TLS mode." 564 | "--tls-module Run tests in TLS mode with Redis module." 565 | "--host Run tests against an external host." 566 | "--port TCP port to use against external host." 567 | "--baseport Initial port number for spawned redis servers." 568 | "--portcount Port range for spawned redis servers." 569 | "--singledb Use a single database, avoid SELECT." 570 | "--cluster-mode Run tests in cluster protocol compatible mode." 571 | "--ignore-encoding Don't validate object encoding." 572 | "--ignore-digest Don't use debug digest validations." 573 | "--large-memory Run tests using over 100mb." 574 | "--help Print this help screen." 575 | } "\n"] 576 | } 577 | 578 | # parse arguments 579 | for {set j 0} {$j < [llength $argv]} {incr j} { 580 | set opt [lindex $argv $j] 581 | set arg [lindex $argv [expr $j+1]] 582 | if {$opt eq {--tags}} { 583 | foreach tag $arg { 584 | if {[string index $tag 0] eq "-"} { 585 | lappend ::denytags [string range $tag 1 end] 586 | } else { 587 | lappend ::allowtags $tag 588 | } 589 | } 590 | incr j 591 | } elseif {$opt eq {--config}} { 592 | set arg2 [lindex $argv [expr $j+2]] 593 | lappend ::global_overrides $arg 594 | lappend ::global_overrides $arg2 595 | incr j 2 596 | } elseif {$opt eq {--log-req-res}} { 597 | set ::log_req_res 1 598 | } elseif {$opt eq {--force-resp3}} { 599 | set ::force_resp3 1 600 | } elseif {$opt eq {--skipfile}} { 601 | incr j 602 | set fp [open $arg r] 603 | set file_data [read $fp] 604 | close $fp 605 | set ::skiptests [concat $::skiptests [split $file_data "\n"]] 606 | } elseif {$opt eq {--skiptest}} { 607 | lappend ::skiptests $arg 608 | incr j 609 | } elseif {$opt eq {--valgrind}} { 610 | set ::valgrind 1 611 | } elseif {$opt eq {--stack-logging}} { 612 | if {[string match {*Darwin*} [exec uname -a]]} { 613 | set ::stack_logging 1 614 | } 615 | } elseif {$opt eq {--quiet}} { 616 | set ::quiet 1 617 | } elseif {$opt eq {--tls} || $opt eq {--tls-module}} { 618 | package require tls 1.6 619 | set ::tls 1 620 | ::tls::init \ 621 | -cafile "$::tlsdir/ca.crt" \ 622 | -certfile "$::tlsdir/client.crt" \ 623 | -keyfile "$::tlsdir/client.key" 624 | if {$opt eq {--tls-module}} { 625 | set ::tls_module 1 626 | } 627 | } elseif {$opt eq {--host}} { 628 | set ::external 1 629 | set ::host $arg 630 | incr j 631 | } elseif {$opt eq {--port}} { 632 | set ::port $arg 633 | incr j 634 | } elseif {$opt eq {--baseport}} { 635 | set ::baseport $arg 636 | incr j 637 | } elseif {$opt eq {--portcount}} { 638 | set ::portcount $arg 639 | incr j 640 | } elseif {$opt eq {--accurate}} { 641 | set ::accurate 1 642 | } elseif {$opt eq {--force-failure}} { 643 | set ::force_failure 1 644 | } elseif {$opt eq {--single}} { 645 | lappend ::single_tests $arg 646 | incr j 647 | } elseif {$opt eq {--only}} { 648 | lappend ::only_tests $arg 649 | incr j 650 | } elseif {$opt eq {--skipunit}} { 651 | lappend ::skipunits $arg 652 | incr j 653 | } elseif {$opt eq {--skip-till}} { 654 | set ::skip_till $arg 655 | incr j 656 | } elseif {$opt eq {--list-tests}} { 657 | foreach t $::all_tests { 658 | puts $t 659 | } 660 | exit 0 661 | } elseif {$opt eq {--verbose}} { 662 | incr ::verbose 663 | } elseif {$opt eq {--client}} { 664 | set ::client 1 665 | set ::test_server_port $arg 666 | incr j 667 | } elseif {$opt eq {--clients}} { 668 | set ::numclients $arg 669 | incr j 670 | } elseif {$opt eq {--durable}} { 671 | set ::durable 1 672 | } elseif {$opt eq {--dont-clean}} { 673 | set ::dont_clean 1 674 | } elseif {$opt eq {--dont-pre-clean}} { 675 | set ::dont_pre_clean 1 676 | } elseif {$opt eq {--no-latency}} { 677 | set ::no_latency 1 678 | } elseif {$opt eq {--wait-server}} { 679 | set ::wait_server 1 680 | } elseif {$opt eq {--dump-logs}} { 681 | set ::dump_logs 1 682 | } elseif {$opt eq {--stop}} { 683 | set ::stop_on_failure 1 684 | } elseif {$opt eq {--loop}} { 685 | set ::loop 2147483647 686 | } elseif {$opt eq {--loops}} { 687 | set ::loop $arg 688 | incr j 689 | } elseif {$opt eq {--timeout}} { 690 | set ::timeout $arg 691 | incr j 692 | } elseif {$opt eq {--singledb}} { 693 | set ::singledb 1 694 | } elseif {$opt eq {--cluster-mode}} { 695 | set ::cluster_mode 1 696 | set ::singledb 1 697 | } elseif {$opt eq {--large-memory}} { 698 | set ::large_memory 1 699 | } elseif {$opt eq {--ignore-encoding}} { 700 | set ::ignoreencoding 1 701 | } elseif {$opt eq {--ignore-digest}} { 702 | set ::ignoredigest 1 703 | } elseif {$opt eq {--help}} { 704 | print_help_screen 705 | exit 0 706 | } else { 707 | puts "Wrong argument: $opt" 708 | exit 1 709 | } 710 | } 711 | 712 | set filtered_tests {} 713 | 714 | # Set the filtered tests to be the short list (single_tests) if exists. 715 | # Otherwise, we start filtering all_tests 716 | if {[llength $::single_tests] > 0} { 717 | set filtered_tests $::single_tests 718 | } else { 719 | set filtered_tests $::all_tests 720 | } 721 | 722 | # If --skip-till option was given, we populate the list of single tests 723 | # to run with everything *after* the specified unit. 724 | if {$::skip_till != ""} { 725 | set skipping 1 726 | foreach t $::all_tests { 727 | if {$skipping == 1} { 728 | lremove filtered_tests $t 729 | } 730 | if {$t == $::skip_till} { 731 | set skipping 0 732 | } 733 | } 734 | if {$skipping} { 735 | puts "test $::skip_till not found" 736 | exit 0 737 | } 738 | } 739 | 740 | # If --skipunits option was given, we populate the list of single tests 741 | # to run with everything *not* in the skipunits list. 742 | if {[llength $::skipunits] > 0} { 743 | foreach t $::all_tests { 744 | if {[lsearch $::skipunits $t] != -1} { 745 | lremove filtered_tests $t 746 | } 747 | } 748 | } 749 | 750 | # Override the list of tests with the specific tests we want to run 751 | # in case there was some filter, that is --single, -skipunit or --skip-till options. 752 | if {[llength $filtered_tests] < [llength $::all_tests]} { 753 | set ::all_tests $filtered_tests 754 | } 755 | 756 | proc attach_to_replication_stream_on_connection {conn} { 757 | r config set repl-ping-replica-period 3600 758 | if {$::tls} { 759 | set s [::tls::socket [srv $conn "host"] [srv $conn "port"]] 760 | } else { 761 | set s [socket [srv $conn "host"] [srv $conn "port"]] 762 | } 763 | fconfigure $s -translation binary 764 | puts -nonewline $s "SYNC\r\n" 765 | flush $s 766 | 767 | # Get the count 768 | while 1 { 769 | set count [gets $s] 770 | set prefix [string range $count 0 0] 771 | if {$prefix ne {}} break; # Newlines are allowed as PINGs. 772 | } 773 | if {$prefix ne {$}} { 774 | error "attach_to_replication_stream error. Received '$count' as count." 775 | } 776 | set count [string range $count 1 end] 777 | 778 | # Consume the bulk payload 779 | while {$count} { 780 | set buf [read $s $count] 781 | set count [expr {$count-[string length $buf]}] 782 | } 783 | return $s 784 | } 785 | 786 | proc attach_to_replication_stream {} { 787 | return [attach_to_replication_stream_on_connection 0] 788 | } 789 | 790 | proc read_from_replication_stream {s} { 791 | fconfigure $s -blocking 0 792 | set attempt 0 793 | while {[gets $s count] == -1} { 794 | if {[incr attempt] == 10} return "" 795 | after 100 796 | } 797 | fconfigure $s -blocking 1 798 | set count [string range $count 1 end] 799 | 800 | # Return a list of arguments for the command. 801 | set res {} 802 | for {set j 0} {$j < $count} {incr j} { 803 | read $s 1 804 | set arg [::redis::redis_bulk_read $s] 805 | if {$j == 0} {set arg [string tolower $arg]} 806 | lappend res $arg 807 | } 808 | return $res 809 | } 810 | 811 | proc assert_replication_stream {s patterns} { 812 | set errors 0 813 | set values_list {} 814 | set patterns_list {} 815 | for {set j 0} {$j < [llength $patterns]} {incr j} { 816 | set pattern [lindex $patterns $j] 817 | lappend patterns_list $pattern 818 | set value [read_from_replication_stream $s] 819 | lappend values_list $value 820 | if {![string match $pattern $value]} { incr errors } 821 | } 822 | 823 | if {$errors == 0} { return } 824 | 825 | set context [info frame -1] 826 | close_replication_stream $s ;# for fast exit 827 | assert_match $patterns_list $values_list "" $context 828 | } 829 | 830 | proc close_replication_stream {s} { 831 | close $s 832 | r config set repl-ping-replica-period 10 833 | return 834 | } 835 | 836 | # With the parallel test running multiple Redis instances at the same time 837 | # we need a fast enough computer, otherwise a lot of tests may generate 838 | # false positives. 839 | # If the computer is too slow we revert the sequential test without any 840 | # parallelism, that is, clients == 1. 841 | proc is_a_slow_computer {} { 842 | set start [clock milliseconds] 843 | for {set j 0} {$j < 1000000} {incr j} {} 844 | set elapsed [expr [clock milliseconds]-$start] 845 | expr {$elapsed > 200} 846 | } 847 | 848 | if {$::client} { 849 | if {[catch { test_client_main $::test_server_port } err]} { 850 | set estr "Executing test client: $err.\n$::errorInfo" 851 | if {[catch {send_data_packet $::test_server_fd exception $estr}]} { 852 | puts $estr 853 | } 854 | exit 1 855 | } 856 | } else { 857 | if {[is_a_slow_computer]} { 858 | puts "** SLOW COMPUTER ** Using a single client to avoid false positives." 859 | set ::numclients 1 860 | } 861 | 862 | if {[catch { test_server_main } err]} { 863 | if {[string length $err] > 0} { 864 | # only display error when not generated by the test suite 865 | if {$err ne "exception"} { 866 | puts $::errorInfo 867 | } 868 | exit 1 869 | } 870 | } 871 | } 872 | -------------------------------------------------------------------------------- /tcltests/support/util.tcl: -------------------------------------------------------------------------------- 1 | proc randstring {min max {type binary}} { 2 | set len [expr {$min+int(rand()*($max-$min+1))}] 3 | set output {} 4 | if {$type eq {binary}} { 5 | set minval 0 6 | set maxval 255 7 | } elseif {$type eq {alpha} || $type eq {simplealpha}} { 8 | set minval 48 9 | set maxval 122 10 | } elseif {$type eq {compr}} { 11 | set minval 48 12 | set maxval 52 13 | } 14 | while {$len} { 15 | set num [expr {$minval+int(rand()*($maxval-$minval+1))}] 16 | set rr [format "%c" $num] 17 | if {$type eq {simplealpha} && ![string is alnum $rr]} {continue} 18 | if {$type eq {alpha} && $num eq 92} {continue} ;# avoid putting '\' char in the string, it can mess up TCL processing 19 | append output $rr 20 | incr len -1 21 | } 22 | return $output 23 | } 24 | 25 | # Useful for some test 26 | proc zlistAlikeSort {a b} { 27 | if {[lindex $a 0] > [lindex $b 0]} {return 1} 28 | if {[lindex $a 0] < [lindex $b 0]} {return -1} 29 | string compare [lindex $a 1] [lindex $b 1] 30 | } 31 | 32 | # Return all log lines starting with the first line that contains a warning. 33 | # Generally, this will be an assertion error with a stack trace. 34 | proc crashlog_from_file {filename} { 35 | set lines [split [exec cat $filename] "\n"] 36 | set matched 0 37 | set logall 0 38 | set result {} 39 | foreach line $lines { 40 | if {[string match {*REDIS BUG REPORT START*} $line]} { 41 | set logall 1 42 | } 43 | if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} { 44 | set matched 1 45 | } 46 | if {$logall || $matched} { 47 | lappend result $line 48 | } 49 | } 50 | join $result "\n" 51 | } 52 | 53 | # Return sanitizer log lines 54 | proc sanitizer_errors_from_file {filename} { 55 | set log [exec cat $filename] 56 | set lines [split [exec cat $filename] "\n"] 57 | 58 | foreach line $lines { 59 | # Ignore huge allocation warnings 60 | if ([string match {*WARNING: AddressSanitizer failed to allocate*} $line]) { 61 | continue 62 | } 63 | 64 | # GCC UBSAN output does not contain 'Sanitizer' but 'runtime error'. 65 | if {[string match {*runtime error*} $line] || 66 | [string match {*Sanitizer*} $line]} { 67 | return $log 68 | } 69 | } 70 | 71 | return "" 72 | } 73 | 74 | proc getInfoProperty {infostr property} { 75 | if {[regexp -lineanchor "^$property:(.*?)\r\n" $infostr _ value]} { 76 | return $value 77 | } 78 | } 79 | 80 | # Return value for INFO property 81 | proc status {r property} { 82 | set _ [getInfoProperty [{*}$r info] $property] 83 | } 84 | 85 | proc waitForBgsave r { 86 | while 1 { 87 | if {[status $r rdb_bgsave_in_progress] eq 1} { 88 | if {$::verbose} { 89 | puts -nonewline "\nWaiting for background save to finish... " 90 | flush stdout 91 | } 92 | after 50 93 | } else { 94 | break 95 | } 96 | } 97 | } 98 | 99 | proc waitForBgrewriteaof r { 100 | while 1 { 101 | if {[status $r aof_rewrite_in_progress] eq 1} { 102 | if {$::verbose} { 103 | puts -nonewline "\nWaiting for background AOF rewrite to finish... " 104 | flush stdout 105 | } 106 | after 50 107 | } else { 108 | break 109 | } 110 | } 111 | } 112 | 113 | proc wait_for_sync r { 114 | wait_for_condition 50 100 { 115 | [status $r master_link_status] eq "up" 116 | } else { 117 | fail "replica didn't sync in time" 118 | } 119 | } 120 | 121 | proc wait_replica_online r { 122 | wait_for_condition 50 100 { 123 | [string match "*slave0:*,state=online*" [$r info replication]] 124 | } else { 125 | fail "replica didn't online in time" 126 | } 127 | } 128 | 129 | proc wait_for_ofs_sync {r1 r2} { 130 | wait_for_condition 50 100 { 131 | [status $r1 master_repl_offset] eq [status $r2 master_repl_offset] 132 | } else { 133 | fail "replica offset didn't match in time" 134 | } 135 | } 136 | 137 | proc wait_done_loading r { 138 | wait_for_condition 50 100 { 139 | [catch {$r ping} e] == 0 140 | } else { 141 | fail "Loading DB is taking too much time." 142 | } 143 | } 144 | 145 | proc wait_lazyfree_done r { 146 | wait_for_condition 50 100 { 147 | [status $r lazyfree_pending_objects] == 0 148 | } else { 149 | fail "lazyfree isn't done" 150 | } 151 | } 152 | 153 | # count current log lines in server's stdout 154 | proc count_log_lines {srv_idx} { 155 | set _ [string trim [exec wc -l < [srv $srv_idx stdout]]] 156 | } 157 | 158 | # returns the number of times a line with that pattern appears in a file 159 | proc count_message_lines {file pattern} { 160 | set res 0 161 | # exec fails when grep exists with status other than 0 (when the pattern wasn't found) 162 | catch { 163 | set res [string trim [exec grep $pattern $file 2> /dev/null | wc -l]] 164 | } 165 | return $res 166 | } 167 | 168 | # returns the number of times a line with that pattern appears in the log 169 | proc count_log_message {srv_idx pattern} { 170 | set stdout [srv $srv_idx stdout] 171 | return [count_message_lines $stdout $pattern] 172 | } 173 | 174 | # verify pattern exists in server's sdtout after a certain line number 175 | proc verify_log_message {srv_idx pattern from_line} { 176 | incr from_line 177 | set result [exec tail -n +$from_line < [srv $srv_idx stdout]] 178 | if {![string match $pattern $result]} { 179 | error "assertion:expected message not found in log file: $pattern" 180 | } 181 | } 182 | 183 | # wait for pattern to be found in server's stdout after certain line number 184 | # return value is a list containing the line that matched the pattern and the line number 185 | proc wait_for_log_messages {srv_idx patterns from_line maxtries delay} { 186 | set retry $maxtries 187 | set next_line [expr $from_line + 1] ;# searching form the line after 188 | set stdout [srv $srv_idx stdout] 189 | while {$retry} { 190 | # re-read the last line (unless it's before to our first), last time we read it, it might have been incomplete 191 | set next_line [expr $next_line - 1 > $from_line + 1 ? $next_line - 1 : $from_line + 1] 192 | set result [exec tail -n +$next_line < $stdout] 193 | set result [split $result "\n"] 194 | foreach line $result { 195 | foreach pattern $patterns { 196 | if {[string match $pattern $line]} { 197 | return [list $line $next_line] 198 | } 199 | } 200 | incr next_line 201 | } 202 | incr retry -1 203 | after $delay 204 | } 205 | if {$retry == 0} { 206 | if {$::verbose} { 207 | puts "content of $stdout from line: $from_line:" 208 | puts [exec tail -n +$from_line < $stdout] 209 | } 210 | fail "log message of '$patterns' not found in $stdout after line: $from_line till line: [expr $next_line -1]" 211 | } 212 | } 213 | 214 | # write line to server log file 215 | proc write_log_line {srv_idx msg} { 216 | set logfile [srv $srv_idx stdout] 217 | set fd [open $logfile "a+"] 218 | puts $fd "### $msg" 219 | close $fd 220 | } 221 | 222 | # Random integer between 0 and max (excluded). 223 | proc randomInt {max} { 224 | expr {int(rand()*$max)} 225 | } 226 | 227 | # Random integer between min and max (excluded). 228 | proc randomRange {min max} { 229 | expr {int(rand()*[expr $max - $min]) + $min} 230 | } 231 | 232 | # Random signed integer between -max and max (both extremes excluded). 233 | proc randomSignedInt {max} { 234 | set i [randomInt $max] 235 | if {rand() > 0.5} { 236 | set i -$i 237 | } 238 | return $i 239 | } 240 | 241 | proc randpath args { 242 | set path [expr {int(rand()*[llength $args])}] 243 | uplevel 1 [lindex $args $path] 244 | } 245 | 246 | proc randomValue {} { 247 | randpath { 248 | # Small enough to likely collide 249 | randomSignedInt 1000 250 | } { 251 | # 32 bit compressible signed/unsigned 252 | randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000} 253 | } { 254 | # 64 bit 255 | randpath {randomSignedInt 1000000000000} 256 | } { 257 | # Random string 258 | randpath {randstring 0 256 alpha} \ 259 | {randstring 0 256 compr} \ 260 | {randstring 0 256 binary} 261 | } 262 | } 263 | 264 | proc randomKey {} { 265 | randpath { 266 | # Small enough to likely collide 267 | randomInt 1000 268 | } { 269 | # 32 bit compressible signed/unsigned 270 | randpath {randomInt 2000000000} {randomInt 4000000000} 271 | } { 272 | # 64 bit 273 | randpath {randomInt 1000000000000} 274 | } { 275 | # Random string 276 | randpath {randstring 1 256 alpha} \ 277 | {randstring 1 256 compr} 278 | } 279 | } 280 | 281 | proc findKeyWithType {r type} { 282 | for {set j 0} {$j < 20} {incr j} { 283 | set k [{*}$r randomkey] 284 | if {$k eq {}} { 285 | return {} 286 | } 287 | if {[{*}$r type $k] eq $type} { 288 | return $k 289 | } 290 | } 291 | return {} 292 | } 293 | 294 | proc createComplexDataset {r ops {opt {}}} { 295 | set useexpire [expr {[lsearch -exact $opt useexpire] != -1}] 296 | set usehexpire [expr {[lsearch -exact $opt usehexpire] != -1}] 297 | 298 | if {[lsearch -exact $opt usetag] != -1} { 299 | set tag "{t}" 300 | } else { 301 | set tag "" 302 | } 303 | for {set j 0} {$j < $ops} {incr j} { 304 | set k [randomKey]$tag 305 | set k2 [randomKey]$tag 306 | set f [randomValue] 307 | set v [randomValue] 308 | 309 | if {$useexpire} { 310 | if {rand() < 0.1} { 311 | {*}$r expire [randomKey] [randomInt 2] 312 | } 313 | } 314 | 315 | randpath { 316 | set d [expr {rand()}] 317 | } { 318 | set d [expr {rand()}] 319 | } { 320 | set d [expr {rand()}] 321 | } { 322 | set d [expr {rand()}] 323 | } { 324 | set d [expr {rand()}] 325 | } { 326 | randpath {set d +inf} {set d -inf} 327 | } 328 | set t [{*}$r type $k] 329 | 330 | if {$t eq {none}} { 331 | randpath { 332 | {*}$r set $k $v 333 | } { 334 | {*}$r lpush $k $v 335 | } { 336 | {*}$r sadd $k $v 337 | } { 338 | {*}$r zadd $k $d $v 339 | } { 340 | {*}$r hset $k $f $v 341 | } { 342 | {*}$r del $k 343 | } 344 | set t [{*}$r type $k] 345 | } 346 | 347 | switch $t { 348 | {string} { 349 | # Nothing to do 350 | } 351 | {list} { 352 | randpath {{*}$r lpush $k $v} \ 353 | {{*}$r rpush $k $v} \ 354 | {{*}$r lrem $k 0 $v} \ 355 | {{*}$r rpop $k} \ 356 | {{*}$r lpop $k} 357 | } 358 | {set} { 359 | randpath {{*}$r sadd $k $v} \ 360 | {{*}$r srem $k $v} \ 361 | { 362 | set otherset [findKeyWithType {*}$r set] 363 | if {$otherset ne {}} { 364 | randpath { 365 | {*}$r sunionstore $k2 $k $otherset 366 | } { 367 | {*}$r sinterstore $k2 $k $otherset 368 | } { 369 | {*}$r sdiffstore $k2 $k $otherset 370 | } 371 | } 372 | } 373 | } 374 | {zset} { 375 | randpath {{*}$r zadd $k $d $v} \ 376 | {{*}$r zrem $k $v} \ 377 | { 378 | set otherzset [findKeyWithType {*}$r zset] 379 | if {$otherzset ne {}} { 380 | randpath { 381 | {*}$r zunionstore $k2 2 $k $otherzset 382 | } { 383 | {*}$r zinterstore $k2 2 $k $otherzset 384 | } 385 | } 386 | } 387 | } 388 | {hash} { 389 | randpath {{*}$r hset $k $f $v} \ 390 | {{*}$r hdel $k $f} 391 | 392 | if { [{*}$r hexists $k $f] && $usehexpire && rand() < 0.5} { 393 | {*}$r hexpire $k 1000 FIELDS 1 $f 394 | } 395 | } 396 | } 397 | } 398 | } 399 | 400 | proc formatCommand {args} { 401 | set cmd "*[llength $args]\r\n" 402 | foreach a $args { 403 | append cmd "$[string length $a]\r\n$a\r\n" 404 | } 405 | set _ $cmd 406 | } 407 | 408 | proc csvdump r { 409 | set o {} 410 | if {$::singledb} { 411 | set maxdb 1 412 | } else { 413 | set maxdb 16 414 | } 415 | for {set db 0} {$db < $maxdb} {incr db} { 416 | if {!$::singledb} { 417 | {*}$r select $db 418 | } 419 | foreach k [lsort [{*}$r keys *]] { 420 | set type [{*}$r type $k] 421 | append o [csvstring $db] , [csvstring $k] , [csvstring $type] , 422 | switch $type { 423 | string { 424 | append o [csvstring [{*}$r get $k]] "\n" 425 | } 426 | list { 427 | foreach e [{*}$r lrange $k 0 -1] { 428 | append o [csvstring $e] , 429 | } 430 | append o "\n" 431 | } 432 | set { 433 | foreach e [lsort [{*}$r smembers $k]] { 434 | append o [csvstring $e] , 435 | } 436 | append o "\n" 437 | } 438 | zset { 439 | foreach e [{*}$r zrange $k 0 -1 withscores] { 440 | append o [csvstring $e] , 441 | } 442 | append o "\n" 443 | } 444 | hash { 445 | set fields [{*}$r hgetall $k] 446 | set newfields {} 447 | foreach {f v} $fields { 448 | set expirylist [{*}$r hexpiretime $k FIELDS 1 $f] 449 | if {$expirylist eq (-1)} { 450 | lappend newfields [list $f $v] 451 | } else { 452 | set e [lindex $expirylist 0] 453 | lappend newfields [list $f $e $v] # TODO: extract the actual ttl value from the list in $e 454 | } 455 | } 456 | set fields [lsort -index 0 $newfields] 457 | foreach kv $fields { 458 | append o [csvstring [lindex $kv 0]] , 459 | append o [csvstring [lindex $kv 1]] , 460 | } 461 | append o "\n" 462 | } 463 | } 464 | } 465 | } 466 | if {!$::singledb} { 467 | {*}$r select 9 468 | } 469 | return $o 470 | } 471 | 472 | proc csvstring s { 473 | return "\"$s\"" 474 | } 475 | 476 | proc roundFloat f { 477 | format "%.10g" $f 478 | } 479 | 480 | set ::last_port_attempted 0 481 | proc find_available_port {start count} { 482 | set port [expr $::last_port_attempted + 1] 483 | for {set attempts 0} {$attempts < $count} {incr attempts} { 484 | if {$port < $start || $port >= $start+$count} { 485 | set port $start 486 | } 487 | set fd1 -1 488 | proc dummy_accept {chan addr port} {} 489 | if {[catch {set fd1 [socket -server dummy_accept -myaddr 127.0.0.1 $port]}] || 490 | [catch {set fd2 [socket -server dummy_accept -myaddr 127.0.0.1 [expr $port+10000]]}]} { 491 | if {$fd1 != -1} { 492 | close $fd1 493 | } 494 | } else { 495 | close $fd1 496 | close $fd2 497 | set ::last_port_attempted $port 498 | return $port 499 | } 500 | incr port 501 | } 502 | error "Can't find a non busy port in the $start-[expr {$start+$count-1}] range." 503 | } 504 | 505 | # Test if TERM looks like to support colors 506 | proc color_term {} { 507 | expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]} 508 | } 509 | 510 | proc colorstr {color str} { 511 | if {[color_term]} { 512 | set b 0 513 | if {[string range $color 0 4] eq {bold-}} { 514 | set b 1 515 | set color [string range $color 5 end] 516 | } 517 | switch $color { 518 | red {set colorcode {31}} 519 | green {set colorcode {32}} 520 | yellow {set colorcode {33}} 521 | blue {set colorcode {34}} 522 | magenta {set colorcode {35}} 523 | cyan {set colorcode {36}} 524 | white {set colorcode {37}} 525 | default {set colorcode {37}} 526 | } 527 | if {$colorcode ne {}} { 528 | return "\033\[$b;${colorcode};49m$str\033\[0m" 529 | } 530 | } else { 531 | return $str 532 | } 533 | } 534 | 535 | proc find_valgrind_errors {stderr on_termination} { 536 | set fd [open $stderr] 537 | set buf [read $fd] 538 | close $fd 539 | 540 | # Look for stack trace (" at 0x") and other errors (Invalid, Mismatched, etc). 541 | # Look for "Warnings", but not the "set address range perms". These don't indicate any real concern. 542 | # corrupt-dump unit, not sure why but it seems they don't indicate any real concern. 543 | if {[regexp -- { at 0x} $buf] || 544 | [regexp -- {^(?=.*Warning)(?:(?!set address range perms).)*$} $buf] || 545 | [regexp -- {Invalid} $buf] || 546 | [regexp -- {Mismatched} $buf] || 547 | [regexp -- {uninitialized} $buf] || 548 | [regexp -- {has a fishy} $buf] || 549 | [regexp -- {overlap} $buf]} { 550 | return $buf 551 | } 552 | 553 | # If the process didn't terminate yet, we can't look for the summary report 554 | if {!$on_termination} { 555 | return "" 556 | } 557 | 558 | # Look for the absence of a leak free summary (happens when redis isn't terminated properly). 559 | if {(![regexp -- {definitely lost: 0 bytes} $buf] && 560 | ![regexp -- {no leaks are possible} $buf])} { 561 | return $buf 562 | } 563 | 564 | return "" 565 | } 566 | 567 | # Execute a background process writing random data for the specified number 568 | # of seconds to the specified Redis instance. 569 | proc start_write_load {host port seconds} { 570 | set tclsh [info nameofexecutable] 571 | exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds $::tls & 572 | } 573 | 574 | # Stop a process generating write load executed with start_write_load. 575 | proc stop_write_load {handle} { 576 | catch {exec /bin/kill -9 $handle} 577 | } 578 | 579 | proc wait_load_handlers_disconnected {{level 0}} { 580 | wait_for_condition 50 100 { 581 | ![string match {*name=LOAD_HANDLER*} [r $level client list]] 582 | } else { 583 | fail "load_handler(s) still connected after too long time." 584 | } 585 | } 586 | 587 | proc K { x y } { set x } 588 | 589 | # Shuffle a list with Fisher-Yates algorithm. 590 | proc lshuffle {list} { 591 | set n [llength $list] 592 | while {$n>1} { 593 | set j [expr {int(rand()*$n)}] 594 | incr n -1 595 | if {$n==$j} continue 596 | set v [lindex $list $j] 597 | lset list $j [lindex $list $n] 598 | lset list $n $v 599 | } 600 | return $list 601 | } 602 | 603 | # Execute a background process writing complex data for the specified number 604 | # of ops to the specified Redis instance. 605 | proc start_bg_complex_data {host port db ops} { 606 | set tclsh [info nameofexecutable] 607 | exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops $::tls & 608 | } 609 | 610 | # Stop a process generating write load executed with start_bg_complex_data. 611 | proc stop_bg_complex_data {handle} { 612 | catch {exec /bin/kill -9 $handle} 613 | } 614 | 615 | # Write num keys with the given key prefix and value size (in bytes). If idx is 616 | # given, it's the index (AKA level) used with the srv procedure and it specifies 617 | # to which Redis instance to write the keys. 618 | proc populate {num {prefix key:} {size 3} {idx 0} {prints false} {expires 0}} { 619 | r $idx deferred 1 620 | if {$num > 16} {set pipeline 16} else {set pipeline $num} 621 | set val [string repeat A $size] 622 | for {set j 0} {$j < $pipeline} {incr j} { 623 | if {$expires > 0} { 624 | r $idx set $prefix$j $val ex $expires 625 | } else { 626 | r $idx set $prefix$j $val 627 | } 628 | if {$prints} {puts $j} 629 | } 630 | for {} {$j < $num} {incr j} { 631 | if {$expires > 0} { 632 | r $idx set $prefix$j $val ex $expires 633 | } else { 634 | r $idx set $prefix$j $val 635 | } 636 | r $idx read 637 | if {$prints} {puts $j} 638 | } 639 | for {set j 0} {$j < $pipeline} {incr j} { 640 | r $idx read 641 | if {$prints} {puts $j} 642 | } 643 | r $idx deferred 0 644 | } 645 | 646 | proc get_child_pid {idx} { 647 | set pid [srv $idx pid] 648 | if {[file exists "/usr/bin/pgrep"]} { 649 | set fd [open "|pgrep -P $pid" "r"] 650 | set child_pid [string trim [lindex [split [read $fd] \n] 0]] 651 | } else { 652 | set fd [open "|ps --ppid $pid -o pid" "r"] 653 | set child_pid [string trim [lindex [split [read $fd] \n] 1]] 654 | } 655 | close $fd 656 | 657 | return $child_pid 658 | } 659 | 660 | proc process_is_alive pid { 661 | if {[catch {exec ps -p $pid -f} err]} { 662 | return 0 663 | } else { 664 | if {[string match "**" $err]} { return 0 } 665 | return 1 666 | } 667 | } 668 | 669 | proc pause_process pid { 670 | exec kill -SIGSTOP $pid 671 | wait_for_condition 50 100 { 672 | [string match {*T*} [lindex [exec ps j $pid] 16]] 673 | } else { 674 | puts [exec ps j $pid] 675 | fail "process didn't stop" 676 | } 677 | } 678 | 679 | proc resume_process pid { 680 | exec kill -SIGCONT $pid 681 | } 682 | 683 | proc cmdrstat {cmd r} { 684 | if {[regexp "\r\ncmdstat_$cmd:(.*?)\r\n" [$r info commandstats] _ value]} { 685 | set _ $value 686 | } 687 | } 688 | 689 | proc errorrstat {cmd r} { 690 | if {[regexp "\r\nerrorstat_$cmd:(.*?)\r\n" [$r info errorstats] _ value]} { 691 | set _ $value 692 | } 693 | } 694 | 695 | proc latencyrstat_percentiles {cmd r} { 696 | if {[regexp "\r\nlatency_percentiles_usec_$cmd:(.*?)\r\n" [$r info latencystats] _ value]} { 697 | set _ $value 698 | } 699 | } 700 | 701 | proc generate_fuzzy_traffic_on_key {key type duration} { 702 | # Commands per type, blocking commands removed 703 | # TODO: extract these from COMMAND DOCS, and improve to include other types 704 | set string_commands {APPEND BITCOUNT BITFIELD BITOP BITPOS DECR DECRBY GET GETBIT GETRANGE GETSET INCR INCRBY INCRBYFLOAT MGET MSET MSETNX PSETEX SET SETBIT SETEX SETNX SETRANGE LCS STRLEN} 705 | set hash_commands {HDEL HEXISTS HGET HGETALL HINCRBY HINCRBYFLOAT HKEYS HLEN HMGET HMSET HSCAN HSET HSETNX HSTRLEN HVALS HRANDFIELD} 706 | set zset_commands {ZADD ZCARD ZCOUNT ZINCRBY ZINTERSTORE ZLEXCOUNT ZPOPMAX ZPOPMIN ZRANGE ZRANGEBYLEX ZRANGEBYSCORE ZRANK ZREM ZREMRANGEBYLEX ZREMRANGEBYRANK ZREMRANGEBYSCORE ZREVRANGE ZREVRANGEBYLEX ZREVRANGEBYSCORE ZREVRANK ZSCAN ZSCORE ZUNIONSTORE ZRANDMEMBER} 707 | set list_commands {LINDEX LINSERT LLEN LPOP LPOS LPUSH LPUSHX LRANGE LREM LSET LTRIM RPOP RPOPLPUSH RPUSH RPUSHX} 708 | set set_commands {SADD SCARD SDIFF SDIFFSTORE SINTER SINTERSTORE SISMEMBER SMEMBERS SMOVE SPOP SRANDMEMBER SREM SSCAN SUNION SUNIONSTORE} 709 | set stream_commands {XACK XADD XCLAIM XDEL XGROUP XINFO XLEN XPENDING XRANGE XREAD XREADGROUP XREVRANGE XTRIM} 710 | set commands [dict create string $string_commands hash $hash_commands zset $zset_commands list $list_commands set $set_commands stream $stream_commands] 711 | 712 | set cmds [dict get $commands $type] 713 | set start_time [clock seconds] 714 | set sent {} 715 | set succeeded 0 716 | while {([clock seconds]-$start_time) < $duration} { 717 | # find a random command for our key type 718 | set cmd_idx [expr {int(rand()*[llength $cmds])}] 719 | set cmd [lindex $cmds $cmd_idx] 720 | # get the command details from redis 721 | if { [ catch { 722 | set cmd_info [lindex [r command info $cmd] 0] 723 | } err ] } { 724 | # if we failed, it means redis crashed after the previous command 725 | return $sent 726 | } 727 | # try to build a valid command argument 728 | set arity [lindex $cmd_info 1] 729 | set arity [expr $arity < 0 ? - $arity: $arity] 730 | set firstkey [lindex $cmd_info 3] 731 | set lastkey [lindex $cmd_info 4] 732 | set i 1 733 | if {$cmd == "XINFO"} { 734 | lappend cmd "STREAM" 735 | lappend cmd $key 736 | lappend cmd "FULL" 737 | incr i 3 738 | } 739 | if {$cmd == "XREAD"} { 740 | lappend cmd "STREAMS" 741 | lappend cmd $key 742 | randpath { 743 | lappend cmd \$ 744 | } { 745 | lappend cmd [randomValue] 746 | } 747 | incr i 3 748 | } 749 | if {$cmd == "XADD"} { 750 | lappend cmd $key 751 | randpath { 752 | lappend cmd "*" 753 | } { 754 | lappend cmd [randomValue] 755 | } 756 | lappend cmd [randomValue] 757 | lappend cmd [randomValue] 758 | incr i 4 759 | } 760 | for {} {$i < $arity} {incr i} { 761 | if {$i == $firstkey || $i == $lastkey} { 762 | lappend cmd $key 763 | } else { 764 | lappend cmd [randomValue] 765 | } 766 | } 767 | # execute the command, we expect commands to fail on syntax errors 768 | lappend sent $cmd 769 | if { ! [ catch { 770 | r {*}$cmd 771 | } err ] } { 772 | incr succeeded 773 | } else { 774 | set err [format "%s" $err] ;# convert to string for pattern matching 775 | if {[string match "*SIGTERM*" $err]} { 776 | puts "commands caused test to hang:" 777 | foreach cmd $sent { 778 | foreach arg $cmd { 779 | puts -nonewline "[string2printable $arg] " 780 | } 781 | puts "" 782 | } 783 | # Re-raise, let handler up the stack take care of this. 784 | error $err $::errorInfo 785 | } 786 | } 787 | } 788 | 789 | # print stats so that we know if we managed to generate commands that actually made sense 790 | #if {$::verbose} { 791 | # set count [llength $sent] 792 | # puts "Fuzzy traffic sent: $count, succeeded: $succeeded" 793 | #} 794 | 795 | # return the list of commands we sent 796 | return $sent 797 | } 798 | 799 | proc string2printable s { 800 | set res {} 801 | set has_special_chars false 802 | foreach i [split $s {}] { 803 | scan $i %c int 804 | # non printable characters, including space and excluding: " \ $ { } 805 | if {$int < 32 || $int > 122 || $int == 34 || $int == 36 || $int == 92} { 806 | set has_special_chars true 807 | } 808 | # TCL8.5 has issues mixing \x notation and normal chars in the same 809 | # source code string, so we'll convert the entire string. 810 | append res \\x[format %02X $int] 811 | } 812 | if {!$has_special_chars} { 813 | return $s 814 | } 815 | set res "\"$res\"" 816 | return $res 817 | } 818 | 819 | # Calculation value of Chi-Square Distribution. By this value 820 | # we can verify the random distribution sample confidence. 821 | # Based on the following wiki: 822 | # https://en.wikipedia.org/wiki/Chi-square_distribution 823 | # 824 | # param res Random sample list 825 | # return Value of Chi-Square Distribution 826 | # 827 | # x2_value: return of chi_square_value function 828 | # df: Degrees of freedom, Number of independent values minus 1 829 | # 830 | # By using x2_value and df to back check the cardinality table, 831 | # we can know the confidence of the random sample. 832 | proc chi_square_value {res} { 833 | unset -nocomplain mydict 834 | foreach key $res { 835 | dict incr mydict $key 1 836 | } 837 | 838 | set x2_value 0 839 | set p [expr [llength $res] / [dict size $mydict]] 840 | foreach key [dict keys $mydict] { 841 | set value [dict get $mydict $key] 842 | 843 | # Aggregate the chi-square value of each element 844 | set v [expr {pow($value - $p, 2) / $p}] 845 | set x2_value [expr {$x2_value + $v}] 846 | } 847 | 848 | return $x2_value 849 | } 850 | 851 | #subscribe to Pub/Sub channels 852 | proc consume_subscribe_messages {client type channels} { 853 | set numsub -1 854 | set counts {} 855 | 856 | for {set i [llength $channels]} {$i > 0} {incr i -1} { 857 | set msg [$client read] 858 | assert_equal $type [lindex $msg 0] 859 | 860 | # when receiving subscribe messages the channels names 861 | # are ordered. when receiving unsubscribe messages 862 | # they are unordered 863 | set idx [lsearch -exact $channels [lindex $msg 1]] 864 | if {[string match "*unsubscribe" $type]} { 865 | assert {$idx >= 0} 866 | } else { 867 | assert {$idx == 0} 868 | } 869 | set channels [lreplace $channels $idx $idx] 870 | 871 | # aggregate the subscription count to return to the caller 872 | lappend counts [lindex $msg 2] 873 | } 874 | 875 | # we should have received messages for channels 876 | assert {[llength $channels] == 0} 877 | return $counts 878 | } 879 | 880 | proc subscribe {client channels} { 881 | $client subscribe {*}$channels 882 | consume_subscribe_messages $client subscribe $channels 883 | } 884 | 885 | proc ssubscribe {client channels} { 886 | $client ssubscribe {*}$channels 887 | consume_subscribe_messages $client ssubscribe $channels 888 | } 889 | 890 | proc unsubscribe {client {channels {}}} { 891 | $client unsubscribe {*}$channels 892 | consume_subscribe_messages $client unsubscribe $channels 893 | } 894 | 895 | proc sunsubscribe {client {channels {}}} { 896 | $client sunsubscribe {*}$channels 897 | consume_subscribe_messages $client sunsubscribe $channels 898 | } 899 | 900 | proc psubscribe {client channels} { 901 | $client psubscribe {*}$channels 902 | consume_subscribe_messages $client psubscribe $channels 903 | } 904 | 905 | proc punsubscribe {client {channels {}}} { 906 | $client punsubscribe {*}$channels 907 | consume_subscribe_messages $client punsubscribe $channels 908 | } 909 | 910 | proc debug_digest_value {key} { 911 | if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} { 912 | return "dummy-digest-value" 913 | } 914 | r debug digest-value $key 915 | } 916 | 917 | proc debug_digest {{level 0}} { 918 | if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} { 919 | return "dummy-digest" 920 | } 921 | r $level debug digest 922 | } 923 | 924 | proc wait_for_blocked_client {{idx 0}} { 925 | wait_for_condition 50 100 { 926 | [s $idx blocked_clients] ne 0 927 | } else { 928 | fail "no blocked clients" 929 | } 930 | } 931 | 932 | proc wait_for_blocked_clients_count {count {maxtries 100} {delay 10} {idx 0}} { 933 | wait_for_condition $maxtries $delay { 934 | [s $idx blocked_clients] == $count 935 | } else { 936 | fail "Timeout waiting for blocked clients" 937 | } 938 | } 939 | 940 | proc wait_for_watched_clients_count {count {maxtries 100} {delay 10} {idx 0}} { 941 | wait_for_condition $maxtries $delay { 942 | [s $idx watching_clients] == $count 943 | } else { 944 | fail "Timeout waiting for watched clients" 945 | } 946 | } 947 | 948 | proc read_from_aof {fp} { 949 | # Input fp is a blocking binary file descriptor of an opened AOF file. 950 | if {[gets $fp count] == -1} return "" 951 | set count [string range $count 1 end] 952 | 953 | # Return a list of arguments for the command. 954 | set res {} 955 | for {set j 0} {$j < $count} {incr j} { 956 | read $fp 1 957 | set arg [::redis::redis_bulk_read $fp] 958 | if {$j == 0} {set arg [string tolower $arg]} 959 | lappend res $arg 960 | } 961 | return $res 962 | } 963 | 964 | proc assert_aof_content {aof_path patterns} { 965 | set fp [open $aof_path r] 966 | fconfigure $fp -translation binary 967 | fconfigure $fp -blocking 1 968 | 969 | for {set j 0} {$j < [llength $patterns]} {incr j} { 970 | assert_match [lindex $patterns $j] [read_from_aof $fp] 971 | } 972 | } 973 | 974 | proc config_set {param value {options {}}} { 975 | set mayfail 0 976 | foreach option $options { 977 | switch $option { 978 | "mayfail" { 979 | set mayfail 1 980 | } 981 | default { 982 | error "Unknown option $option" 983 | } 984 | } 985 | } 986 | 987 | if {[catch {r config set $param $value} err]} { 988 | if {!$mayfail} { 989 | error $err 990 | } else { 991 | if {$::verbose} { 992 | puts "Ignoring CONFIG SET $param $value failure: $err" 993 | } 994 | } 995 | } 996 | } 997 | 998 | proc config_get_set {param value {options {}}} { 999 | set config [lindex [r config get $param] 1] 1000 | config_set $param $value $options 1001 | return $config 1002 | } 1003 | 1004 | proc delete_lines_with_pattern {filename tmpfilename pattern} { 1005 | set fh_in [open $filename r] 1006 | set fh_out [open $tmpfilename w] 1007 | while {[gets $fh_in line] != -1} { 1008 | if {![regexp $pattern $line]} { 1009 | puts $fh_out $line 1010 | } 1011 | } 1012 | close $fh_in 1013 | close $fh_out 1014 | file rename -force $tmpfilename $filename 1015 | } 1016 | 1017 | proc get_nonloopback_addr {} { 1018 | set addrlist [list {}] 1019 | catch { set addrlist [exec hostname -I] } 1020 | return [lindex $addrlist 0] 1021 | } 1022 | 1023 | proc get_nonloopback_client {} { 1024 | return [redis [get_nonloopback_addr] [srv 0 "port"] 0 $::tls] 1025 | } 1026 | 1027 | # The following functions and variables are used only when running large-memory 1028 | # tests. We avoid defining them when not running large-memory tests because the 1029 | # global variables takes up lots of memory. 1030 | proc init_large_mem_vars {} { 1031 | if {![info exists ::str500]} { 1032 | set ::str500 [string repeat x 500000000] ;# 500mb 1033 | set ::str500_len [string length $::str500] 1034 | } 1035 | } 1036 | 1037 | # Utility function to write big argument into redis client connection 1038 | proc write_big_bulk {size {prefix ""} {skip_read no}} { 1039 | init_large_mem_vars 1040 | 1041 | assert {[string length prefix] <= $size} 1042 | r write "\$$size\r\n" 1043 | r write $prefix 1044 | incr size -[string length $prefix] 1045 | while {$size >= 500000000} { 1046 | r write $::str500 1047 | incr size -500000000 1048 | } 1049 | if {$size > 0} { 1050 | r write [string repeat x $size] 1051 | } 1052 | r write "\r\n" 1053 | if {!$skip_read} { 1054 | r flush 1055 | r read 1056 | } 1057 | } 1058 | 1059 | # Utility to read big bulk response (work around Tcl limitations) 1060 | proc read_big_bulk {code {compare no} {prefix ""}} { 1061 | init_large_mem_vars 1062 | 1063 | r readraw 1 1064 | set resp_len [uplevel 1 $code] ;# get the first line of the RESP response 1065 | assert_equal [string range $resp_len 0 0] "$" 1066 | set resp_len [string range $resp_len 1 end] 1067 | set prefix_len [string length $prefix] 1068 | if {$compare} { 1069 | assert {$prefix_len <= $resp_len} 1070 | assert {$prefix_len <= $::str500_len} 1071 | } 1072 | 1073 | set remaining $resp_len 1074 | while {$remaining > 0} { 1075 | set l $remaining 1076 | if {$l > $::str500_len} {set l $::str500_len} ; # can't read more than 2gb at a time, so read 500mb so we can easily verify read data 1077 | set read_data [r rawread $l] 1078 | set nbytes [string length $read_data] 1079 | if {$compare} { 1080 | set comp_len $nbytes 1081 | # Compare prefix part 1082 | if {$remaining == $resp_len} { 1083 | assert_equal $prefix [string range $read_data 0 [expr $prefix_len - 1]] 1084 | set read_data [string range $read_data $prefix_len $nbytes] 1085 | incr comp_len -$prefix_len 1086 | } 1087 | # Compare rest of data, evaluate and then assert to avoid huge print in case of failure 1088 | set data_equal [expr {$read_data == [string range $::str500 0 [expr $comp_len - 1]]}] 1089 | assert $data_equal 1090 | } 1091 | incr remaining -$nbytes 1092 | } 1093 | assert_equal [r rawread 2] "\r\n" 1094 | r readraw 0 1095 | return $resp_len 1096 | } 1097 | 1098 | proc prepare_value {size} { 1099 | set _v "c" 1100 | for {set i 1} {$i < $size} {incr i} { 1101 | append _v 0 1102 | } 1103 | return $_v 1104 | } 1105 | 1106 | proc memory_usage {key} { 1107 | set usage [r memory usage $key] 1108 | if {![string match {*jemalloc*} [s mem_allocator]]} { 1109 | # libc allocator can sometimes return a different size allocation for the same requested size 1110 | # this makes tests that rely on MEMORY USAGE unreliable, so instead we return a constant 1 1111 | set usage 1 1112 | } 1113 | return $usage 1114 | } 1115 | 1116 | # forward compatibility, lmap missing in TCL 8.5 1117 | proc lmap args { 1118 | set body [lindex $args end] 1119 | set args [lrange $args 0 end-1] 1120 | set n 0 1121 | set pairs [list] 1122 | foreach {varnames listval} $args { 1123 | set varlist [list] 1124 | foreach varname $varnames { 1125 | upvar 1 $varname var$n 1126 | lappend varlist var$n 1127 | incr n 1128 | } 1129 | lappend pairs $varlist $listval 1130 | } 1131 | set temp [list] 1132 | foreach {*}$pairs { 1133 | lappend temp [uplevel 1 $body] 1134 | } 1135 | set temp 1136 | } 1137 | 1138 | proc format_command {args} { 1139 | set cmd "*[llength $args]\r\n" 1140 | foreach a $args { 1141 | append cmd "$[string length $a]\r\n$a\r\n" 1142 | } 1143 | set _ $cmd 1144 | } 1145 | 1146 | # Returns whether or not the system supports stack traces 1147 | proc system_backtrace_supported {} { 1148 | set system_name [string tolower [exec uname -s]] 1149 | if {$system_name eq {darwin}} { 1150 | return 1 1151 | } elseif {$system_name ne {linux}} { 1152 | return 0 1153 | } 1154 | 1155 | # libmusl does not support backtrace. Also return 0 on 1156 | # static binaries (ldd exit code 1) where we can't detect libmusl 1157 | if {![catch {set ldd [exec ldd src/redis-server]}]} { 1158 | if {![string match {*libc.*musl*} $ldd]} { 1159 | return 1 1160 | } 1161 | } 1162 | return 0 1163 | } 1164 | 1165 | proc generate_largevalue_test_array {} { 1166 | array set largevalue {} 1167 | set largevalue(listpack) "hello" 1168 | set largevalue(quicklist) [string repeat "x" 8192] 1169 | return [array get largevalue] 1170 | } 1171 | --------------------------------------------------------------------------------