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