AryaWu/sqlite
0
1# 2010 April 142#3# The author disclaims copyright to this source code. In place of4# a legal notice, here is a blessing:5#6# May you do good and not evil.7# May you find forgiveness for yourself and forgive others.8# May you share freely, never taking more than you give.9#10#***********************************************************************11# This file contains code used by several different test scripts. The12# code in this file allows testfixture to control another process (or13# processes) to test locking.14#15 16proc do_multiclient_test {varname script} {17 18 foreach {tn code} [list 1 {19 if {[info exists ::G(valgrind)]} { db close ; continue }20 set ::code2_chan [launch_testfixture]21 set ::code3_chan [launch_testfixture]22 proc code2 {tcl} { testfixture $::code2_chan $tcl }23 proc code3 {tcl} { testfixture $::code3_chan $tcl }24 } 2 {25 proc code2 {tcl} { uplevel #0 $tcl }26 proc code3 {tcl} { uplevel #0 $tcl }27 }] {28 # Do not run multi-process tests with the unix-excl VFS.29 #30 if {$tn==1 && [permutation]=="unix-excl"} continue31 32 faultsim_delete_and_reopen33 34 proc code1 {tcl} { uplevel #0 $tcl }35 36 # Open connections [db2] and [db3]. Depending on which iteration this37 # is, the connections may be created in this interpreter, or in 38 # interpreters running in other OS processes. As such, the [db2] and [db3]39 # commands should only be accessed within [code2] and [code3] blocks,40 # respectively.41 #42 eval $code43 code2 { sqlite3 db2 test.db }44 code3 { sqlite3 db3 test.db }45 46 # Shorthand commands. Execute SQL using database connection [db2] or 47 # [db3]. Return the results.48 #49 proc sql1 {sql} { db eval $sql }50 proc sql2 {sql} { code2 [list db2 eval $sql] }51 proc sql3 {sql} { code3 [list db3 eval $sql] }52 53 proc csql1 {sql} { list [catch { sql1 $sql } msg] $msg }54 proc csql2 {sql} { list [catch { sql2 $sql } msg] $msg }55 proc csql3 {sql} { list [catch { sql3 $sql } msg] $msg }56 57 uplevel set $varname $tn58 uplevel $script59 60 catch { code2 { db2 close } }61 catch { code3 { db3 close } }62 catch { close $::code2_chan }63 catch { close $::code3_chan }64 catch { db close }65 }66}67 68# Launch another testfixture process to be controlled by this one. A69# channel name is returned that may be passed as the first argument to proc70# 'testfixture' to execute a command. The child testfixture process is shut71# down by closing the channel.72proc launch_testfixture {{prg ""}} {73 write_main_loop74 if {$prg eq ""} { set prg [info nameofexec] }75 if {$prg eq ""} { set prg testfixture }76 if {[file tail $prg]==$prg} { set prg [file join . $prg] }77 set chan [open "|$prg tf_main.tcl" r+]78 fconfigure $chan -buffering line79 set rc [catch { 80 testfixture $chan "sqlite3_test_control_pending_byte $::sqlite_pending_byte"81 }]82 if {$rc} {83 testfixture $chan "set ::sqlite_pending_byte $::sqlite_pending_byte"84 }85 return $chan86}87 88# Execute a command in a child testfixture process, connected by two-way89# channel $chan. Return the result of the command, or an error message.90#91proc testfixture {chan cmd args} {92 93 if {[llength $args] == 0} {94 fconfigure $chan -blocking 195 puts $chan $cmd96 puts $chan OVER97 98 set r ""99 while { 1 } {100 set line [gets $chan]101 if { $line == "OVER" } { 102 set res [lindex $r 1]103 if { [lindex $r 0] } { error $res }104 return $res105 }106 if {[eof $chan]} {107 return "ERROR: Child process hung up"108 }109 append r $line110 }111 return $r112 } else {113 set ::tfnb($chan) ""114 fconfigure $chan -blocking 0 -buffering none115 puts $chan $cmd116 puts $chan OVER117 fileevent $chan readable [list testfixture_script_cb $chan [lindex $args 0]]118 return ""119 }120}121 122proc testfixture_script_cb {chan script} {123 if {[eof $chan]} {124 append ::tfnb($chan) "ERROR: Child process hung up"125 set line "OVER"126 } else {127 set line [gets $chan]128 }129 130 if { $line == "OVER" } {131 uplevel #0 $script [list [lindex $::tfnb($chan) 1]]132 unset ::tfnb($chan)133 fileevent $chan readable ""134 } else {135 append ::tfnb($chan) $line136 }137}138 139proc testfixture_nb_cb {varname chan} {140 if {[eof $chan]} {141 append ::tfnb($chan) "ERROR: Child process hung up"142 set line "OVER"143 } else {144 set line [gets $chan]145 }146 147 if { $line == "OVER" } {148 if {[string range $varname 0 1]!="::"} { global $varname }149 set $varname [lindex $::tfnb($chan) 1]150 unset ::tfnb($chan)151 close $chan152 } else {153 append ::tfnb($chan) $line154 }155}156 157proc testfixture_nb {varname cmd} {158 set chan [launch_testfixture]159 set ::tfnb($chan) ""160 fconfigure $chan -blocking 0 -buffering none161 puts $chan $cmd162 puts $chan OVER163 fileevent $chan readable [list testfixture_nb_cb $varname $chan]164 return ""165}166 167# Write the main loop for the child testfixture processes into file168# tf_main.tcl. The parent (this script) interacts with the child processes169# via a two way pipe. The parent writes a script to the stdin of the child170# process, followed by the word "OVER" on a line of its own. The child171# process evaluates the script and writes the results to stdout, followed172# by an "OVER" of its own.173#174set main_loop_written 0175proc write_main_loop {} {176 if {$::main_loop_written} return177 set wrapper ""178 if {[sqlite3 -has-codec] && [info exists ::do_not_use_codec]==0} {179 set wrapper "180 rename sqlite3 sqlite_orig181 proc sqlite3 {args} {[info body sqlite3]}182 "183 }184 185 set fd [open tf_main.tcl w]186 puts $fd [string map [list %WRAPPER% $wrapper] {187 %WRAPPER%188 set script ""189 while {![eof stdin]} {190 flush stdout191 set line [gets stdin]192 if { $line == "OVER" } {193 set rc [catch {eval $script} result]194 puts [list $rc $result]195 puts OVER196 flush stdout197 set script ""198 } else {199 append script $line200 append script "\n"201 }202 }203 }]204 close $fd205 set main_loop_written 1206}207 208