From 1c4114be4012250382e082f7821f163dca408ffd Mon Sep 17 00:00:00 2001
From: Pieter Noordhuis <pcnoordhuis@gmail.com>
Date: Fri, 14 May 2010 20:50:32 +0200
Subject: [PATCH] store entire server object on the stack instead of just the
 client

---
 tests/support/server.tcl | 24 +++++++++++++-----------
 tests/test_helper.tcl    | 33 ++++++++++++++++++++++++++++-----
 2 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/tests/support/server.tcl b/tests/support/server.tcl
index ead81e9ee..8adce3e87 100644
--- a/tests/support/server.tcl
+++ b/tests/support/server.tcl
@@ -103,23 +103,25 @@ proc start_server {filename overrides {code undefined}} {
     }
 
     # setup config dict
-    dict set ret "config" $config_file
-    dict set ret "pid" $pid
-    dict set ret "stdout" $stdout
-    dict set ret "stderr" $stderr
-    dict set ret "client" $client
+    dict set srv "config" $config_file
+    dict set srv "pid" $pid
+    dict set srv "host" $host
+    dict set srv "port" $port
+    dict set srv "stdout" $stdout
+    dict set srv "stderr" $stderr
+    dict set srv "client" $client
 
     if {$code ne "undefined"} {
-        # append the client to the client stack
-        lappend ::clients $client
+        # append the server to the stack
+        lappend ::servers $srv
         
         # execute provided block
         catch { uplevel 1 $code } err
 
-        # pop the client object
-        set ::clients [lrange $::clients 0 end-1]
+        # pop the server object
+        set ::servers [lrange $::servers 0 end-1]
         
-        kill_server $ret
+        kill_server $srv
 
         if {[string length $err] > 0} {
             puts "Error executing the suite, aborting..."
@@ -127,6 +129,6 @@ proc start_server {filename overrides {code undefined}} {
             exit 1
         }
     } else {
-        set _ $ret
+        set _ $srv
     }
 }
diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
index cd8d65a1c..49dfb1638 100644
--- a/tests/test_helper.tcl
+++ b/tests/test_helper.tcl
@@ -18,12 +18,35 @@ proc execute_tests name {
     source "tests/$name.tcl"
 }
 
-# setup a list to hold a stack of clients. the proc "r" provides easy
-# access to the client at the top of the stack
-set ::clients {}
+# Setup a list to hold a stack of server configs. When calls to start_server
+# are nested, use "srv 0 pid" to get the pid of the inner server. To access
+# outer servers, use "srv -1 pid" etcetera.
+set ::servers {}
+proc srv {level property} {
+    set srv [lindex $::servers end+$level]
+    dict get $srv $property
+}
+
+# Provide easy access to the client for the inner server. It's possible to
+# prepend the argument list with a negative level to access clients for
+# servers running in outer blocks.
 proc r {args} {
-    set client [lindex $::clients end]
-    $client {*}$args
+    set level 0
+    if {[string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+    [srv $level "client"] {*}$args
+}
+
+# Provide easy access to INFO properties. Same semantic as "proc r".
+proc s {args} {
+    set level 0
+    if {[string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+    status [srv $level "client"] [lindex $args 0]
 }
 
 proc main {} {