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