Import SQLite 3.10.2.

third_party/sqlite/src/test/lock_common.tcl

 # 2010 April 14
 #
 # The author disclaims copyright to this source code.  In place of
 # a legal notice, here is a blessing:
 #
 #    May you do good and not evil.
 #    May you find forgiveness for yourself and forgive others.
 #    May you share freely, never taking more than you give.
 #
 #***********************************************************************
@@ skipping 68 matching lines @@
   }]
   if {$rc} {
     testfixture $chan "set ::sqlite_pending_byte $::sqlite_pending_byte"
   }
   return $chan
 }
 
 # 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
+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
     }
-    if {[eof $chan]} {
-      return "ERROR: Child process hung up"
-    }
-    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
+  }
+}
+
 proc testfixture_nb_cb {varname chan} {
   if {[eof $chan]} {
     append ::tfnb($chan) "ERROR: Child process hung up"
     set line "OVER"
   } else {
     set line [gets $chan]
   }
 
   if { $line == "OVER" } {
     set $varname [lindex $::tfnb($chan) 1]
@@ skipping 48 matching lines @@
       } else {
         append script $line
         append script "\n"
       }
     }
   }]
   close $fd
   set main_loop_written 1
 }