tests/test_helper.tcl

   1 # Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
   2 # This softare is released under the BSD License. See the COPYING file for
   3 # more information.
   4
   5 set tcl_precision 17
   6 source tests/support/redis.tcl
   7 source tests/support/server.tcl
   8 source tests/support/tmpfile.tcl
   9 source tests/support/test.tcl
  10 source tests/support/util.tcl
  11
  12 set ::host 127.0.0.1
  13 set ::port 16379
  14 set ::traceleaks 0
  15 set ::valgrind 0
  16 set ::verbose 0
  17 set ::denytags {}
  18 set ::allowtags {}
  19 set ::external 0; # If "1" this means, we are running against external instance
  20 set ::file ""; # If set, runs only the tests in this comma separated list
  21 set ::curfile ""; # Hold the filename of the current suite
  22 set ::diskstore 0; # Don't touch this by hand. The test itself will toggle it.
  23
  24 proc execute_tests name {
  25     set path "tests/$name.tcl"
  26     set ::curfile $path
  27     source $path
  28 }
  29
  30 # Setup a list to hold a stack of server configs. When calls to start_server
  31 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
  32 # outer servers, use "srv -1 pid" etcetera.
  33 set ::servers {}
  34 proc srv {args} {
  35     set level 0
  36     if {[string is integer [lindex $args 0]]} {
  37         set level [lindex $args 0]
  38         set property [lindex $args 1]
  39     } else {
  40         set property [lindex $args 0]
  41     }
  42     set srv [lindex $::servers end+$level]
  43     dict get $srv $property
  44 }
  45
  46 # Provide easy access to the client for the inner server. It's possible to
  47 # prepend the argument list with a negative level to access clients for
  48 # servers running in outer blocks.
  49 proc r {args} {
  50     set level 0
  51     if {[string is integer [lindex $args 0]]} {
  52         set level [lindex $args 0]
  53         set args [lrange $args 1 end]
  54     }
  55     [srv $level "client"] {*}$args
  56 }
  57
  58 proc reconnect {args} {
  59     set level [lindex $args 0]
  60     if {[string length $level] == 0 || ![string is integer $level]} {
  61         set level 0
  62     }
  63
  64     set srv [lindex $::servers end+$level]
  65     set host [dict get $srv "host"]
  66     set port [dict get $srv "port"]
  67     set config [dict get $srv "config"]
  68     set client [redis $host $port]
  69     dict set srv "client" $client
  70
  71     # select the right db when we don't have to authenticate
  72     if {![dict exists $config "requirepass"]} {
  73         $client select 9
  74     }
  75
  76     # re-set $srv in the servers list
  77     set ::servers [lreplace $::servers end+$level 1 $srv]
  78 }
  79
  80 proc redis_deferring_client {args} {
  81     set level 0
  82     if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
  83         set level [lindex $args 0]
  84         set args [lrange $args 1 end]
  85     }
  86
  87     # create client that defers reading reply
  88     set client [redis [srv $level "host"] [srv $level "port"] 1]
  89
  90     # select the right db and read the response (OK)
  91     $client select 9
  92     $client read
  93     return $client
  94 }
  95
  96 # Provide easy access to INFO properties. Same semantic as "proc r".
  97 proc s {args} {
  98     set level 0
  99     if {[string is integer [lindex $args 0]]} {
 100         set level [lindex $args 0]
 101         set args [lrange $args 1 end]
 102     }
 103     status [srv $level "client"] [lindex $args 0]
 104 }
 105
 106 proc cleanup {} {
 107     puts "Cleanup: warning may take some time..."
 108     catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
 109     catch {exec rm -rf {*}[glob tests/tmp/server.*]}
 110 }
 111
 112 proc execute_everything {} {
 113     if 0 {
 114         # Use this when hacking on new tests.
 115         set ::verbose 1
 116         execute_tests "unit/first"
 117         return
 118     }
 119
 120     execute_tests "unit/printver"
 121     execute_tests "unit/auth"
 122     execute_tests "unit/protocol"
 123     execute_tests "unit/basic"
 124     execute_tests "unit/type/list"
 125     execute_tests "unit/type/set"
 126     execute_tests "unit/type/zset"
 127     execute_tests "unit/type/hash"
 128     execute_tests "unit/sort"
 129     execute_tests "unit/expire"
 130     execute_tests "unit/other"
 131     execute_tests "unit/cas"
 132     execute_tests "unit/quit"
 133     execute_tests "integration/replication"
 134     execute_tests "integration/aof"
 135 #    execute_tests "integration/redis-cli"
 136     execute_tests "unit/pubsub"
 137
 138     return; # No diskstore tests for now...
 139     # run tests with diskstore enabled
 140     puts "\nRunning diskstore tests... this is slow, press Ctrl+C if not interested.."
 141     set ::diskstore 1
 142     lappend ::denytags nodiskstore
 143     set ::global_overrides {diskstore-enabled yes}
 144     execute_tests "unit/protocol"
 145     execute_tests "unit/basic"
 146     execute_tests "unit/type/list"
 147     execute_tests "unit/type/set"
 148     execute_tests "unit/type/zset"
 149     execute_tests "unit/type/hash"
 150     execute_tests "unit/sort"
 151     execute_tests "unit/expire"
 152     execute_tests "unit/other"
 153     execute_tests "unit/cas"
 154 }
 155
 156 proc main {} {
 157     cleanup
 158
 159     if {[string length $::file] > 0} {
 160         foreach {file} [split $::file ,] {
 161             execute_tests $file
 162         }
 163     } else {
 164         execute_everything
 165     }
 166
 167     cleanup
 168     puts "\n[expr $::num_tests] tests, $::num_passed passed, $::num_failed failed\n"
 169     if {$::num_failed > 0} {
 170         set curheader ""
 171         puts "Failures:"
 172         foreach {test} $::tests_failed {
 173             set header [lindex $test 0]
 174             append header " ("
 175             append header [join [lindex $test 1] ","]
 176             append header ")"
 177
 178             if {$curheader ne $header} {
 179                 set curheader $header
 180                 puts "\n$curheader:"
 181             }
 182
 183             set name [lindex $test 2]
 184             set msg [lindex $test 3]
 185             puts "- $name: $msg"
 186         }
 187
 188         puts ""
 189         exit 1
 190     }
 191 }
 192
 193 # parse arguments
 194 for {set j 0} {$j < [llength $argv]} {incr j} {
 195     set opt [lindex $argv $j]
 196     set arg [lindex $argv [expr $j+1]]
 197     if {$opt eq {--tags}} {
 198         foreach tag $arg {
 199             if {[string index $tag 0] eq "-"} {
 200                 lappend ::denytags [string range $tag 1 end]
 201             } else {
 202                 lappend ::allowtags $tag
 203             }
 204         }
 205         incr j
 206     } elseif {$opt eq {--valgrind}} {
 207         set ::valgrind 1
 208     } elseif {$opt eq {--file}} {
 209         set ::file $arg
 210         incr j
 211     } elseif {$opt eq {--host}} {
 212         set ::external 1
 213         set ::host $arg
 214         incr j
 215     } elseif {$opt eq {--port}} {
 216         set ::port $arg
 217         incr j
 218     } elseif {$opt eq {--verbose}} {
 219         set ::verbose 1
 220     } else {
 221         puts "Wrong argument: $opt"
 222         exit 1
 223     }
 224 }
 225
 226 if {[catch { main } err]} {
 227     if {[string length $err] > 0} {
 228         # only display error when not generated by the test suite
 229         if {$err ne "exception"} {
 230             puts $::errorInfo
 231         }
 232         exit 1
 233     }
 234 }