• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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
16proc 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    code2 { db2 close }
59    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.
70proc 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#
89proc 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
107proc 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
124proc 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#
141set main_loop_written 0
142proc 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
175