1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
|
# 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.
#
#***********************************************************************
# This file contains code used by several different test scripts. The
# code in this file allows testfixture to control another process (or
# processes) to test locking.
#
proc do_multiclient_test {varname script} {
foreach {tn code} [list 1 {
if {[info exists ::G(valgrind)]} { db close ; continue }
set ::code2_chan [launch_testfixture]
set ::code3_chan [launch_testfixture]
proc code2 {tcl} { testfixture $::code2_chan $tcl }
proc code3 {tcl} { testfixture $::code3_chan $tcl }
} 2 {
proc code2 {tcl} { uplevel #0 $tcl }
proc code3 {tcl} { uplevel #0 $tcl }
}] {
# Do not run multi-process tests with the unix-excl VFS.
#
if {$tn==1 && [permutation]=="unix-excl"} continue
faultsim_delete_and_reopen
proc code1 {tcl} { uplevel #0 $tcl }
# Open connections [db2] and [db3]. Depending on which iteration this
# is, the connections may be created in this interpreter, or in
# interpreters running in other OS processes. As such, the [db2] and [db3]
# commands should only be accessed within [code2] and [code3] blocks,
# respectively.
#
eval $code
code2 { sqlite3 db2 test.db }
code3 { sqlite3 db3 test.db }
# Shorthand commands. Execute SQL using database connection [db2] or
# [db3]. Return the results.
#
proc sql1 {sql} { db eval $sql }
proc sql2 {sql} { code2 [list db2 eval $sql] }
proc sql3 {sql} { code3 [list db3 eval $sql] }
proc csql1 {sql} { list [catch { sql1 $sql } msg] $msg }
proc csql2 {sql} { list [catch { sql2 $sql } msg] $msg }
proc csql3 {sql} { list [catch { sql3 $sql } msg] $msg }
uplevel set $varname $tn
uplevel $script
catch { code2 { db2 close } }
catch { code3 { db3 close } }
catch { close $::code2_chan }
catch { close $::code3_chan }
catch { db close }
}
}
# Launch another testfixture process to be controlled by this one. A
# channel name is returned that may be passed as the first argument to proc
# 'testfixture' to execute a command. The child testfixture process is shut
# down by closing the channel.
proc launch_testfixture {{prg ""}} {
write_main_loop
if {$prg eq ""} { set prg [info nameofexec] }
if {$prg eq ""} { set prg testfixture }
if {[file tail $prg]==$prg} { set prg [file join . $prg] }
set chan [open "|$prg tf_main.tcl" r+]
fconfigure $chan -buffering line
set rc [catch {
testfixture $chan "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
}]
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 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" } {
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]
unset ::tfnb($chan)
close $chan
} else {
append ::tfnb($chan) $line
}
}
proc testfixture_nb {varname cmd} {
set chan [launch_testfixture]
set ::tfnb($chan) ""
fconfigure $chan -blocking 0 -buffering none
puts $chan $cmd
puts $chan OVER
fileevent $chan readable [list testfixture_nb_cb $varname $chan]
return ""
}
# Write the main loop for the child testfixture processes into file
# tf_main.tcl. The parent (this script) interacts with the child processes
# via a two way pipe. The parent writes a script to the stdin of the child
# process, followed by the word "OVER" on a line of its own. The child
# process evaluates the script and writes the results to stdout, followed
# by an "OVER" of its own.
#
set main_loop_written 0
proc write_main_loop {} {
if {$::main_loop_written} return
set wrapper ""
if {[sqlite3 -has-codec] && [info exists ::do_not_use_codec]==0} {
set wrapper "
rename sqlite3 sqlite_orig
proc sqlite3 {args} {[info body sqlite3]}
"
}
set fd [open tf_main.tcl w]
puts $fd [string map [list %WRAPPER% $wrapper] {
%WRAPPER%
set script ""
while {![eof stdin]} {
flush stdout
set line [gets stdin]
if { $line == "OVER" } {
set rc [catch {eval $script} result]
puts [list $rc $result]
puts OVER
flush stdout
set script ""
} else {
append script $line
append script "\n"
}
}
}]
close $fd
set main_loop_written 1
}
|