gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/lock_common.tcl (about) 1 # 2010 April 14 2 # 3 # The author disclaims copyright to this source code. In place of 4 # 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. The 12 # code in this file allows testfixture to control another process (or 13 # processes) to test locking. 14 # 15 16 proc 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"} continue 31 32 faultsim_delete_and_reopen 33 34 proc code1 {tcl} { uplevel #0 $tcl } 35 36 # Open connections [db2] and [db3]. Depending on which iteration this 37 # 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 $code 43 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 $tn 58 uplevel $script 59 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. A 69 # channel name is returned that may be passed as the first argument to proc 70 # 'testfixture' to execute a command. The child testfixture process is shut 71 # down by closing the channel. 72 proc launch_testfixture {{prg ""}} { 73 write_main_loop 74 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 line 79 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 $chan 86 } 87 88 # Execute a command in a child testfixture process, connected by two-way 89 # channel $chan. Return the result of the command, or an error message. 90 # 91 proc testfixture {chan cmd args} { 92 93 if {[llength $args] == 0} { 94 fconfigure $chan -blocking 1 95 puts $chan $cmd 96 puts $chan OVER 97 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 $res 105 } 106 if {[eof $chan]} { 107 return "ERROR: Child process hung up" 108 } 109 append r $line 110 } 111 return $r 112 } else { 113 set ::tfnb($chan) "" 114 fconfigure $chan -blocking 0 -buffering none 115 puts $chan $cmd 116 puts $chan OVER 117 fileevent $chan readable [list testfixture_script_cb $chan [lindex $args 0]] 118 return "" 119 } 120 } 121 122 proc 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) $line 136 } 137 } 138 139 proc 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 set $varname [lindex $::tfnb($chan) 1] 149 unset ::tfnb($chan) 150 close $chan 151 } else { 152 append ::tfnb($chan) $line 153 } 154 } 155 156 proc testfixture_nb {varname cmd} { 157 set chan [launch_testfixture] 158 set ::tfnb($chan) "" 159 fconfigure $chan -blocking 0 -buffering none 160 puts $chan $cmd 161 puts $chan OVER 162 fileevent $chan readable [list testfixture_nb_cb $varname $chan] 163 return "" 164 } 165 166 # Write the main loop for the child testfixture processes into file 167 # tf_main.tcl. The parent (this script) interacts with the child processes 168 # via a two way pipe. The parent writes a script to the stdin of the child 169 # process, followed by the word "OVER" on a line of its own. The child 170 # process evaluates the script and writes the results to stdout, followed 171 # by an "OVER" of its own. 172 # 173 set main_loop_written 0 174 proc write_main_loop {} { 175 if {$::main_loop_written} return 176 set wrapper "" 177 if {[sqlite3 -has-codec] && [info exists ::do_not_use_codec]==0} { 178 set wrapper " 179 rename sqlite3 sqlite_orig 180 proc sqlite3 {args} {[info body sqlite3]} 181 " 182 } 183 184 set fd [open tf_main.tcl w] 185 puts $fd [string map [list %WRAPPER% $wrapper] { 186 %WRAPPER% 187 set script "" 188 while {![eof stdin]} { 189 flush stdout 190 set line [gets stdin] 191 if { $line == "OVER" } { 192 set rc [catch {eval $script} result] 193 puts [list $rc $result] 194 puts OVER 195 flush stdout 196 set script "" 197 } else { 198 append script $line 199 append script "\n" 200 } 201 } 202 }] 203 close $fd 204 set main_loop_written 1 205 } 206