tests/support/server.tcl

   1 set ::global_overrides {}
   2 set ::tags {}
   3 set ::valgrind_errors {}
   4
   5 proc error_and_quit {config_file error} {
   6     puts "!!COULD NOT START REDIS-SERVER\n"
   7     puts "CONFIGURATION:"
   8     puts [exec cat $config_file]
   9     puts "\nERROR:"
  10     puts [string trim $error]
  11     exit 1
  12 }
  13
  14 proc check_valgrind_errors stderr {
  15     set fd [open $stderr]
  16     set buf [read $fd]
  17     close $fd
  18
  19     if {![regexp -- {ERROR SUMMARY: 0 errors} $buf] ||
  20         (![regexp -- {definitely lost: 0 bytes} $buf] &&
  21          ![regexp -- {no leaks are possible} $buf])} {
  22         puts "*** VALGRIND ERRORS ***"
  23         puts $buf
  24         puts "-----------------------"
  25         append ::valgrind_errors "$buf\n\n"
  26     }
  27 }
  28
  29 proc kill_server config {
  30     # nothing to kill when running against external server
  31     if {$::external} return
  32
  33     # nevermind if its already dead
  34     if {![is_alive $config]} { return }
  35     set pid [dict get $config pid]
  36
  37     # check for leaks
  38     if {![dict exists $config "skipleaks"]} {
  39         catch {
  40             if {[string match {*Darwin*} [exec uname -a]]} {
  41                 tags {"leaks"} {
  42                     test "Check for memory leaks (pid $pid)" {
  43                         exec leaks $pid
  44                     } {*0 leaks*}
  45                 }
  46             }
  47         }
  48     }
  49
  50     # kill server and wait for the process to be totally exited
  51     while {[is_alive $config]} {
  52         if {[incr wait 10] % 1000 == 0} {
  53             puts "Waiting for process $pid to exit..."
  54         }
  55         catch {exec kill $pid}
  56         after 10
  57     }
  58
  59     # Check valgrind errors if needed
  60     if {$::valgrind} {
  61         check_valgrind_errors [dict get $config stderr]
  62     }
  63 }
  64
  65 proc is_alive config {
  66     set pid [dict get $config pid]
  67     if {[catch {exec ps -p $pid} err]} {
  68         return 0
  69     } else {
  70         return 1
  71     }
  72 }
  73
  74 proc ping_server {host port} {
  75     set retval 0
  76     if {[catch {
  77         set fd [socket $::host $::port]
  78         fconfigure $fd -translation binary
  79         puts $fd "PING\r\n"
  80         flush $fd
  81         set reply [gets $fd]
  82         if {[string range $reply 0 4] eq {+PONG} ||
  83             [string range $reply 0 3] eq {-ERR}} {
  84             set retval 1
  85         }
  86         close $fd
  87     } e]} {
  88         if {$::verbose} {
  89             puts -nonewline "."
  90         }
  91     } else {
  92         if {$::verbose} {
  93             puts -nonewline "ok"
  94         }
  95     }
  96     return $retval
  97 }
  98
  99 # doesn't really belong here, but highly coupled to code in start_server
 100 proc tags {tags code} {
 101     set ::tags [concat $::tags $tags]
 102     uplevel 1 $code
 103     set ::tags [lrange $::tags 0 end-[llength $tags]]
 104 }
 105
 106 proc start_server {options {code undefined}} {
 107     # If we are runnign against an external server, we just push the
 108     # host/port pair in the stack the first time
 109     if {$::external} {
 110         if {[llength $::servers] == 0} {
 111             set srv {}
 112             dict set srv "host" $::host
 113             dict set srv "port" $::port
 114             set client [redis $::host $::port]
 115             dict set srv "client" $client
 116             $client select 9
 117
 118             # append the server to the stack
 119             lappend ::servers $srv
 120         }
 121         uplevel 1 $code
 122         return
 123     }
 124
 125     # setup defaults
 126     set baseconfig "default.conf"
 127     set overrides {}
 128     set tags {}
 129
 130     # parse options
 131     foreach {option value} $options {
 132         switch $option {
 133             "config" {
 134                 set baseconfig $value }
 135             "overrides" {
 136                 set overrides $value }
 137             "tags" {
 138                 set tags $value
 139                 set ::tags [concat $::tags $value] }
 140             default {
 141                 error "Unknown option $option" }
 142         }
 143     }
 144
 145     set data [split [exec cat "tests/assets/$baseconfig"] "\n"]
 146     set config {}
 147     foreach line $data {
 148         if {[string length $line] > 0 && [string index $line 0] ne "#"} {
 149             set elements [split $line " "]
 150             set directive [lrange $elements 0 0]
 151             set arguments [lrange $elements 1 end]
 152             dict set config $directive $arguments
 153         }
 154     }
 155
 156     # use a different directory every time a server is started
 157     dict set config dir [tmpdir server]
 158
 159     # start every server on a different port
 160     dict set config port [incr ::port]
 161
 162     # apply overrides from global space and arguments
 163     foreach {directive arguments} [concat $::global_overrides $overrides] {
 164         dict set config $directive $arguments
 165     }
 166
 167     # write new configuration to temporary file
 168     set config_file [tmpfile redis.conf]
 169     set fp [open $config_file w+]
 170     foreach directive [dict keys $config] {
 171         puts -nonewline $fp "$directive "
 172         puts $fp [dict get $config $directive]
 173     }
 174     close $fp
 175
 176     set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
 177     set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
 178
 179     if {$::valgrind} {
 180         exec valgrind --suppressions=src/valgrind.sup src/redis-server $config_file > $stdout 2> $stderr &
 181     } else {
 182         exec src/redis-server $config_file > $stdout 2> $stderr &
 183     }
 184
 185     # check that the server actually started
 186     # ugly but tries to be as fast as possible...
 187     set retrynum 20
 188     set serverisup 0
 189
 190     if {$::verbose} {
 191         puts -nonewline "=== ($tags) Starting server ${::host}:${::port} "
 192     }
 193
 194     after 10
 195     if {$code ne "undefined"} {
 196         while {[incr retrynum -1]} {
 197             catch {
 198                 if {[ping_server $::host $::port]} {
 199                     set serverisup 1
 200                 }
 201             }
 202             if {$serverisup} break
 203             after 50
 204         }
 205     } else {
 206         set serverisup 1
 207     }
 208
 209     if {$::verbose} {
 210         puts ""
 211     }
 212
 213     if {!$serverisup} {
 214         error_and_quit $config_file [exec cat $stderr]
 215     }
 216
 217     # find out the pid
 218     while {![info exists pid]} {
 219         regexp {\[(\d+)\]} [exec cat $stdout] _ pid
 220         after 100
 221     }
 222
 223     # setup properties to be able to initialize a client object
 224     set host $::host
 225     set port $::port
 226     if {[dict exists $config bind]} { set host [dict get $config bind] }
 227     if {[dict exists $config port]} { set port [dict get $config port] }
 228
 229     # setup config dict
 230     dict set srv "config_file" $config_file
 231     dict set srv "config" $config
 232     dict set srv "pid" $pid
 233     dict set srv "host" $host
 234     dict set srv "port" $port
 235     dict set srv "stdout" $stdout
 236     dict set srv "stderr" $stderr
 237
 238     # if a block of code is supplied, we wait for the server to become
 239     # available, create a client object and kill the server afterwards
 240     if {$code ne "undefined"} {
 241         set line [exec head -n1 $stdout]
 242         if {[string match {*already in use*} $line]} {
 243             error_and_quit $config_file $line
 244         }
 245
 246         while 1 {
 247             # check that the server actually started and is ready for connections
 248             if {[exec cat $stdout | grep "ready to accept" | wc -l] > 0} {
 249                 break
 250             }
 251             after 10
 252         }
 253
 254         # append the server to the stack
 255         lappend ::servers $srv
 256
 257         # connect client (after server dict is put on the stack)
 258         reconnect
 259
 260         # execute provided block
 261         set num_tests $::num_tests
 262         if {[catch { uplevel 1 $code } error]} {
 263             set backtrace $::errorInfo
 264
 265             # Kill the server without checking for leaks
 266             dict set srv "skipleaks" 1
 267             kill_server $srv
 268
 269             # Print warnings from log
 270             puts [format "\nLogged warnings (pid %d):" [dict get $srv "pid"]]
 271             set warnings [warnings_from_file [dict get $srv "stdout"]]
 272             if {[string length $warnings] > 0} {
 273                 puts "$warnings"
 274             } else {
 275                 puts "(none)"
 276             }
 277             puts ""
 278
 279             error $error $backtrace
 280         }
 281
 282         # Don't do the leak check when no tests were run
 283         if {$num_tests == $::num_tests} {
 284             dict set srv "skipleaks" 1
 285         }
 286
 287         # pop the server object
 288         set ::servers [lrange $::servers 0 end-1]
 289
 290         set ::tags [lrange $::tags 0 end-[llength $tags]]
 291         kill_server $srv
 292     } else {
 293         set ::tags [lrange $::tags 0 end-[llength $tags]]
 294         set _ $srv
 295     }
 296 }