1 files changed, 44 insertions, 14 deletions
diff --git a/test/lock_common.tcl b/test/lock_common.tcl
index bc1eb86bd..a758e7af2 100644
--- a/test/lock_common.tcl
+++ b/test/lock_common.tcl
@@ -86,21 +86,51 @@ proc launch_testfixture {{prg ""}} {
 # Execute a command in a child testfixture process, connected by two-way
 # channel $chan. Return the result of the command, or an error message.
 #
-proc testfixture {chan cmd} {
-  puts $chan $cmd
-  puts $chan OVER
-  set r ""
-  while { 1 } {
-    set line [gets $chan]
-    if { $line == "OVER" } { 
-      set res [lindex $r 1]
-      if { [lindex $r 0] } { error $res }
-      return $res
-    }
-    if {[eof $chan]} {
-      return "ERROR: Child process hung up"
+proc testfixture {chan cmd args} {
+
+  if {[llength $args] == 0} {
+    fconfigure $chan -blocking 1
+    puts $chan $cmd
+    puts $chan OVER
+
+    set r ""
+    while { 1 } {
+      set line [gets $chan]
+      if { $line == "OVER" } { 
+        set res [lindex $r 1]
+        if { [lindex $r 0] } { error $res }
+        return $res
+      }
+      if {[eof $chan]} {
+        return "ERROR: Child process hung up"
+      }
+      append r $line
     }
-    append r $line
+    return $r
+  } else {
+    set ::tfnb($chan) ""
+    fconfigure $chan -blocking 0 -buffering none
+    puts $chan $cmd
+    puts $chan OVER
+    fileevent $chan readable [list testfixture_script_cb $chan [lindex $args 0]]
+    return ""
+  }
+}
+
+proc testfixture_script_cb {chan script} {
+  if {[eof $chan]} {
+    append ::tfnb($chan) "ERROR: Child process hung up"
+    set line "OVER"
+  } else {
+    set line [gets $chan]
+  }
+
+  if { $line == "OVER" } {
+    uplevel #0 $script [list [lindex $::tfnb($chan) 1]]
+    unset ::tfnb($chan)
+    fileevent $chan readable ""
+  } else {
+    append ::tfnb($chan) $line
   }
 }