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