Return to lock_common.tcl CVS log

Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / sqlite3 / test

sqlite3

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