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 kill_server config {
  11     set pid [dict get $config pid]
  12
  13     # check for leaks
  14     catch {
  15         if {[string match {*Darwin*} [exec uname -a]]} {
  16             test {Check for memory leaks} {
  17                 exec leaks $pid
  18             } {*0 leaks*}
  19         }
  20     }
  21
  22     # kill server and wait for the process to be totally exited
  23     exec kill $pid
  24     while 1 {
  25         # with a non-zero exit status, the process is gone
  26         if {[catch {exec ps -p $pid | grep redis-server} result]} {
  27             break
  28         }
  29         after 10
  30     }
  31 }
  32
  33 proc start_server {filename overrides {code undefined}} {
  34     set data [split [exec cat "tests/assets/$filename"] "\n"]
  35     set config {}
  36     foreach line $data {
  37         if {[string length $line] > 0 && [string index $line 0] ne "#"} {
  38             set elements [split $line " "]
  39             set directive [lrange $elements 0 0]
  40             set arguments [lrange $elements 1 end]
  41             dict set config $directive $arguments
  42         }
  43     }
  44
  45     # use a different directory every time a server is started
  46     dict set config dir [tmpdir server]
  47
  48     # start every server on a different port
  49     dict set config port [incr ::port]
  50
  51     # apply overrides from arguments
  52     foreach override $overrides {
  53         set directive [lrange $override 0 0]
  54         set arguments [lrange $override 1 end]
  55         dict set config $directive $arguments
  56     }
  57
  58     # write new configuration to temporary file
  59     set config_file [tmpfile redis.conf]
  60     set fp [open $config_file w+]
  61     foreach directive [dict keys $config] {
  62         puts -nonewline $fp "$directive "
  63         puts $fp [dict get $config $directive]
  64     }
  65     close $fp
  66
  67     set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
  68     set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
  69     exec ./redis-server $config_file > $stdout 2> $stderr &
  70     after 500
  71
  72     # check that the server actually started
  73     if {[file size $stderr] > 0} {
  74         error_and_quit $config_file [exec cat $stderr]
  75     }
  76
  77     set line [exec head -n1 $stdout]
  78     if {[string match {*already in use*} $line]} {
  79         error_and_quit $config_file $line
  80     }
  81
  82     while 1 {
  83         # check that the server actually started and is ready for connections
  84         if {[exec cat $stdout | grep "ready to accept" | wc -l] > 0} {
  85             break
  86         }
  87         after 10
  88     }
  89
  90     # find out the pid
  91     regexp {^\[(\d+)\]} [exec head -n1 $stdout] _ pid
  92
  93     # create the client object
  94     set host $::host
  95     set port $::port
  96     if {[dict exists $config bind]} { set host [dict get $config bind] }
  97     if {[dict exists $config port]} { set port [dict get $config port] }
  98     set client [redis $host $port]
  99
 100     # select the right db when we don't have to authenticate
 101     if {![dict exists $config requirepass]} {
 102         $client select 9
 103     }
 104
 105     # setup config dict
 106     dict set srv "config" $config_file
 107     dict set srv "pid" $pid
 108     dict set srv "host" $host
 109     dict set srv "port" $port
 110     dict set srv "stdout" $stdout
 111     dict set srv "stderr" $stderr
 112     dict set srv "client" $client
 113
 114     if {$code ne "undefined"} {
 115         # append the server to the stack
 116         lappend ::servers $srv
 117
 118         # execute provided block
 119         catch { uplevel 1 $code } err
 120
 121         # pop the server object
 122         set ::servers [lrange $::servers 0 end-1]
 123
 124         kill_server $srv
 125
 126         if {[string length $err] > 0} {
 127             puts "Error executing the suite, aborting..."
 128             puts $err
 129             exit 1
 130         }
 131     } else {
 132         set _ $srv
 133     }
 134 }