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 ::denytags {}
  17 set ::allowtags {}
  18 set ::external 0; # If "1" this means, we are running against external instance
  19 set ::file ""; # If set, runs only the tests in this comma separated list
  20
  21 proc execute_tests name {
  22     source "tests/$name.tcl"
  23 }
  24
  25 # Setup a list to hold a stack of server configs. When calls to start_server
  26 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
  27 # outer servers, use "srv -1 pid" etcetera.
  28 set ::servers {}
  29 proc srv {args} {
  30     set level 0
  31     if {[string is integer [lindex $args 0]]} {
  32         set level [lindex $args 0]
  33         set property [lindex $args 1]
  34     } else {
  35         set property [lindex $args 0]
  36     }
  37     set srv [lindex $::servers end+$level]
  38     dict get $srv $property
  39 }
  40
  41 # Provide easy access to the client for the inner server. It's possible to
  42 # prepend the argument list with a negative level to access clients for
  43 # servers running in outer blocks.
  44 proc r {args} {
  45     set level 0
  46     if {[string is integer [lindex $args 0]]} {
  47         set level [lindex $args 0]
  48         set args [lrange $args 1 end]
  49     }
  50     [srv $level "client"] {*}$args
  51 }
  52
  53 proc reconnect {args} {
  54     set level [lindex $args 0]
  55     if {[string length $level] == 0 || ![string is integer $level]} {
  56         set level 0
  57     }
  58
  59     set srv [lindex $::servers end+$level]
  60     set host [dict get $srv "host"]
  61     set port [dict get $srv "port"]
  62     set config [dict get $srv "config"]
  63     set client [redis $host $port]
  64     dict set srv "client" $client
  65
  66     # select the right db when we don't have to authenticate
  67     if {![dict exists $config "requirepass"]} {
  68         $client select 9
  69     }
  70
  71     # re-set $srv in the servers list
  72     set ::servers [lreplace $::servers end+$level 1 $srv]
  73 }
  74
  75 proc redis_deferring_client {args} {
  76     set level 0
  77     if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
  78         set level [lindex $args 0]
  79         set args [lrange $args 1 end]
  80     }
  81
  82     # create client that defers reading reply
  83     set client [redis [srv $level "host"] [srv $level "port"] 1]
  84
  85     # select the right db and read the response (OK)
  86     $client select 9
  87     $client read
  88     return $client
  89 }
  90
  91 # Provide easy access to INFO properties. Same semantic as "proc r".
  92 proc s {args} {
  93     set level 0
  94     if {[string is integer [lindex $args 0]]} {
  95         set level [lindex $args 0]
  96         set args [lrange $args 1 end]
  97     }
  98     status [srv $level "client"] [lindex $args 0]
  99 }
 100
 101 proc cleanup {} {
 102     catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
 103     catch {exec rm -rf {*}[glob tests/tmp/server.*]}
 104 }
 105
 106 proc execute_everything {} {
 107     execute_tests "unit/auth"
 108     execute_tests "unit/protocol"
 109     execute_tests "unit/basic"
 110     execute_tests "unit/type/list"
 111     execute_tests "unit/type/set"
 112     execute_tests "unit/type/zset"
 113     execute_tests "unit/type/hash"
 114     execute_tests "unit/sort"
 115     execute_tests "unit/expire"
 116     execute_tests "unit/other"
 117     execute_tests "unit/cas"
 118     execute_tests "unit/quit"
 119     execute_tests "integration/replication"
 120     execute_tests "integration/aof"
 121 #    execute_tests "integration/redis-cli"
 122     execute_tests "unit/pubsub"
 123
 124     # run tests with VM enabled
 125     set ::global_overrides {vm-enabled yes}
 126     execute_tests "unit/protocol"
 127     execute_tests "unit/basic"
 128     execute_tests "unit/type/list"
 129     execute_tests "unit/type/set"
 130     execute_tests "unit/type/zset"
 131     execute_tests "unit/type/hash"
 132     execute_tests "unit/sort"
 133     execute_tests "unit/expire"
 134     execute_tests "unit/other"
 135     execute_tests "unit/cas"
 136 }
 137
 138 proc main {} {
 139     cleanup
 140
 141     if {[string length $::file] > 0} {
 142         foreach {file} [split $::file ,] {
 143             execute_tests $file
 144         }
 145     } else {
 146         execute_everything
 147     }
 148
 149     cleanup
 150     puts "\n[expr $::passed+$::failed] tests, $::passed passed, $::failed failed"
 151     if {$::failed > 0} {
 152         puts "\n*** WARNING!!! $::failed FAILED TESTS ***\n"
 153         exit 1
 154     }
 155 }
 156
 157 # parse arguments
 158 for {set j 0} {$j < [llength $argv]} {incr j} {
 159     set opt [lindex $argv $j]
 160     set arg [lindex $argv [expr $j+1]]
 161     if {$opt eq {--tags}} {
 162         foreach tag $arg {
 163             if {[string index $tag 0] eq "-"} {
 164                 lappend ::denytags [string range $tag 1 end]
 165             } else {
 166                 lappend ::allowtags $tag
 167             }
 168         }
 169         incr j
 170     } elseif {$opt eq {--file}} {
 171         set ::file $arg
 172         incr j
 173     } elseif {$opt eq {--host}} {
 174         set ::external 1
 175         set ::host $arg
 176         incr j
 177     } elseif {$opt eq {--port}} {
 178         set ::port $arg
 179         incr j
 180     } else {
 181         puts "Wrong argument: $opt"
 182         exit 1
 183     }
 184 }
 185
 186 if {[catch { main } err]} {
 187     if {[string length $err] > 0} {
 188         # only display error when not generated by the test suite
 189         if {$err ne "exception"} {
 190             puts $err
 191         }
 192         exit 1
 193     }
 194 }