tests/support/server.tcl

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