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