database/sqlite
1
0
Fork 0
mirror of https://github.com/sqlite/sqlite.git synced 2025-07-29 08:01:23 +03:00
Code Activity

Add a test for the change on this branch.

Browse Source 
FossilOrigin-Name: e22dde187eb0b389d6d93e2e39a26fd0f4e6196e
This commit is contained in:
dan
2015-03-17 16:01:29 +00:00
parent bbf76eec34
commit 363fc9e724
5 changed files with 177 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
test/lock_common.tcl
View File

@ -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 } {
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
}
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" } {
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 { $line == "OVER" } {
uplevel #0 $script [list [lindex $::tfnb($chan) 1]]
unset ::tfnb($chan)
fileevent $chan readable ""
} else {
append ::tfnb($chan) $line
}
}