tests/support/server.tcl

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