wasCSharpSQLite – Blame information for rev 7
?pathlinks?
Rev | Author | Line No. | Line |
---|---|---|---|
1 | office | 1 | # 2001 September 15
|
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 implements some common TCL routines used for regression
|
||
12 | # testing the SQLite library
|
||
13 | #
|
||
14 | # $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $
|
||
15 | ########################################################################
|
||
16 | # Included in SQLite3 port to C#-SQLite; 2008 Noah B Hart
|
||
17 | # C#-SQLite is an independent reimplementation of the SQLite software library
|
||
18 | #
|
||
19 | # SQLITE_SOURCE_ID: SQLITE_SOURCE_ID: 2011-05-19 13:26:54 ed1da510a239ea767a01dc332b667119fa3c908e
|
||
20 | |||
21 | #-------------------------------------------------------------------------
|
||
22 | # The commands provided by the code in this file to help with creating
|
||
23 | # test cases are as follows:
|
||
24 | #
|
||
25 | # Commands to manipulate the db and the file-system at a high level:
|
||
26 | #
|
||
27 | # copy_file FROM TO
|
||
28 | # drop_all_table ?DB?
|
||
29 | # forcedelete FILENAME
|
||
30 | #
|
||
31 | # Test the capability of the SQLite version built into the interpreter to
|
||
32 | # determine if a specific test can be run:
|
||
33 | #
|
||
34 | # ifcapable EXPR
|
||
35 | #
|
||
36 | # Calulate checksums based on database contents:
|
||
37 | #
|
||
38 | # dbcksum DB DBNAME
|
||
39 | # allcksum ?DB?
|
||
40 | # cksum ?DB?
|
||
41 | #
|
||
42 | # Commands to execute/explain SQL statements:
|
||
43 | #
|
||
44 | # stepsql DB SQL
|
||
45 | # execsql2 SQL
|
||
46 | # explain_no_trace SQL
|
||
47 | # explain SQL ?DB?
|
||
48 | # catchsql SQL ?DB?
|
||
49 | # execsql SQL ?DB?
|
||
50 | #
|
||
51 | # Commands to run test cases:
|
||
52 | #
|
||
53 | # do_ioerr_test TESTNAME ARGS...
|
||
54 | # crashsql ARGS...
|
||
55 | # integrity_check TESTNAME ?DB?
|
||
56 | # do_test TESTNAME SCRIPT EXPECTED
|
||
57 | # do_execsql_test TESTNAME SQL EXPECTED
|
||
58 | # do_catchsql_test TESTNAME SQL EXPECTED
|
||
59 | #
|
||
60 | # Commands providing a lower level interface to the global test counters:
|
||
61 | #
|
||
62 | # set_test_counter COUNTER ?VALUE?
|
||
63 | # omit_test TESTNAME REASON
|
||
64 | # fail_test TESTNAME
|
||
65 | # incr_ntest
|
||
66 | #
|
||
67 | # Command run at the end of each test file:
|
||
68 | #
|
||
69 | # finish_test
|
||
70 | #
|
||
71 | # Commands to help create test files that run with the "WAL" and other
|
||
72 | # permutations (see file permutations.test):
|
||
73 | #
|
||
74 | # wal_is_wal_mode
|
||
75 | # wal_set_journal_mode ?DB?
|
||
76 | # wal_check_journal_mode TESTNAME?DB?
|
||
77 | # permutation
|
||
78 | # presql
|
||
79 | #
|
||
80 | |||
81 | # Set the precision of FP arithmatic used by the interpreter. And
|
||
82 | # configure SQLite to take database file locks on the page that begins
|
||
83 | # 64KB into the database file instead of the one 1GB in. This means
|
||
84 | # the code that handles that special case can be tested without creating
|
||
85 | # very large database files.
|
||
86 | #
|
||
87 | set tcl_precision 15 |
||
88 | sqlite3_test_control_pending_byte 0x0010000 |
||
89 | |||
90 | |||
91 | # If the pager codec is available, create a wrapper for the [sqlite3]
|
||
92 | # command that appends "-key {xyzzy}" to the command line. i.e. this:
|
||
93 | #
|
||
94 | # sqlite3 db test.db
|
||
95 | #
|
||
96 | # becomes
|
||
97 | #
|
||
98 | # sqlite3 db test.db -key {xyzzy}
|
||
99 | #
|
||
100 | if {[info command sqlite_orig]==""} { |
||
101 | rename sqlite3 sqlite_orig |
||
102 | proc sqlite3 {args} { |
||
103 | if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} { |
||
104 | # This command is opening a new database connection.
|
||
105 | #
|
||
106 | if {[info exists ::G(perm:sqlite3_args)]} { |
||
107 | set args [concat $args $::G(perm:sqlite3_args)] |
||
108 | } |
||
109 | if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} { |
||
110 | lappend args -key {xyzzy} |
||
111 | } |
||
112 | |||
113 | set res [uplevel 1 sqlite_orig $args] |
||
114 | if {[info exists ::G(perm:presql)]} { |
||
115 | [lindex $args 0] eval $::G(perm:presql) |
||
116 | } |
||
117 | if {[info exists ::G(perm:dbconfig)]} { |
||
118 | set ::dbhandle [lindex $args 0] |
||
119 | uplevel #0 $::G(perm:dbconfig)
|
||
120 | } |
||
121 | set res |
||
122 | } else { |
||
123 | # This command is not opening a new database connection. Pass the
|
||
124 | # arguments through to the C implemenation as the are.
|
||
125 | #
|
||
126 | uplevel 1 sqlite_orig $args |
||
127 | } |
||
128 | } |
||
129 | } |
||
130 | |||
131 | proc execpresql {handle args} { |
||
132 | trace remove execution $handle enter [list execpresql $handle] |
||
133 | if {[info exists ::G(perm:presql)]} { |
||
134 | $handle eval $::G(perm:presql) |
||
135 | } |
||
136 | } |
||
137 | |||
138 | # This command should be called after loading tester.tcl from within
|
||
139 | # all test scripts that are incompatible with encryption codecs.
|
||
140 | #
|
||
141 | proc do_not_use_codec {} { |
||
142 | set ::do_not_use_codec 1 |
||
143 | reset_db |
||
144 | } |
||
145 | |||
146 | # The following block only runs the first time this file is sourced. It
|
||
147 | # does not run in slave interpreters (since the ::cmdlinearg array is
|
||
148 | # populated before the test script is run in slave interpreters).
|
||
149 | #
|
||
150 | if {[info exists cmdlinearg]==0} { |
||
151 | |||
152 | # Parse any options specified in the $argv array. This script accepts the
|
||
153 | # following options:
|
||
154 | #
|
||
155 | # --pause
|
||
156 | # --soft-heap-limit=NN
|
||
157 | # --maxerror=NN
|
||
158 | # --malloctrace=N
|
||
159 | # --backtrace=N
|
||
160 | # --binarylog=N
|
||
161 | # --soak=N
|
||
162 | # --start=[$permutation:]$testfile
|
||
163 | #
|
||
164 | set cmdlinearg(soft-heap-limit) 0 |
||
165 | set cmdlinearg(maxerror) 1000 |
||
166 | set cmdlinearg(malloctrace) 0 |
||
167 | set cmdlinearg(backtrace) 10 |
||
168 | set cmdlinearg(binarylog) 0 |
||
169 | set cmdlinearg(soak) 0 |
||
170 | set cmdlinearg(start) "" |
||
171 | |||
172 | set leftover [list] |
||
173 | foreach a $argv { |
||
174 | switch -regexp -- $a { |
||
175 | {^-+pause$} { |
||
176 | # Wait for user input before continuing. This is to give the user an
|
||
177 | # opportunity to connect profiling tools to the process.
|
||
178 | puts -nonewline "Press RETURN to begin..." |
||
179 | flush stdout |
||
180 | gets stdin |
||
181 | } |
||
182 | {^-+soft-heap-limit=.+$} { |
||
183 | foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break |
||
184 | } |
||
185 | {^-+maxerror=.+$} { |
||
186 | foreach {dummy cmdlinearg(maxerror)} [split $a =] break |
||
187 | } |
||
188 | {^-+malloctrace=.+$} { |
||
189 | foreach {dummy cmdlinearg(malloctrace)} [split $a =] break |
||
190 | if {$cmdlinearg(malloctrace)} { |
||
191 | sqlite3_memdebug_log start |
||
192 | } |
||
193 | } |
||
194 | {^-+backtrace=.+$} { |
||
195 | foreach {dummy cmdlinearg(backtrace)} [split $a =] break |
||
196 | sqlite3_memdebug_backtrace $value |
||
197 | } |
||
198 | {^-+binarylog=.+$} { |
||
199 | foreach {dummy cmdlinearg(binarylog)} [split $a =] break |
||
200 | } |
||
201 | {^-+soak=.+$} { |
||
202 | foreach {dummy cmdlinearg(soak)} [split $a =] break |
||
203 | set ::G(issoak) $cmdlinearg(soak) |
||
204 | } |
||
205 | {^-+start=.+$} { |
||
206 | foreach {dummy cmdlinearg(start)} [split $a =] break |
||
207 | |||
208 | set ::G(start:file) $cmdlinearg(start) |
||
209 | if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} { |
||
210 | set ::G(start:permutation) ${s.perm} |
||
211 | set ::G(start:file) ${s.file} |
||
212 | } |
||
213 | if {$::G(start:file) == ""} {unset ::G(start:file)} |
||
214 | } |
||
215 | default { |
||
216 | lappend leftover $a |
||
217 | } |
||
218 | } |
||
219 | } |
||
220 | set argv $leftover |
||
221 | |||
222 | # Install the malloc layer used to inject OOM errors. And the 'automatic'
|
||
223 | # extensions. This only needs to be done once for the process.
|
||
224 | #
|
||
225 | sqlite3_shutdown |
||
226 | ################################
|
||
227 | # not implemented in C#-SQLite #
|
||
228 | ################################
|
||
229 | # install_malloc_faultsim 1
|
||
230 | ################################
|
||
231 | sqlite3_initialize |
||
232 | autoinstall_test_functions |
||
233 | |||
234 | # If the --binarylog option was specified, create the logging VFS. This
|
||
235 | # call installs the new VFS as the default for all SQLite connections.
|
||
236 | #
|
||
237 | if {$cmdlinearg(binarylog)} { |
||
238 | vfslog new binarylog {} vfslog.bin |
||
239 | } |
||
240 | |||
241 | # Set the backtrace depth, if malloc tracing is enabled.
|
||
242 | #
|
||
243 | if {$cmdlinearg(malloctrace)} { |
||
244 | sqlite3_memdebug_backtrace $cmdlinearg(backtrace) |
||
245 | } |
||
246 | } |
||
247 | |||
248 | # Update the soft-heap-limit each time this script is run. In that
|
||
249 | # way if an individual test file changes the soft-heap-limit, it
|
||
250 | # will be reset at the start of the next test file.
|
||
251 | #
|
||
252 | sqlite3_soft_heap_limit $cmdlinearg(soft-heap-limit) |
||
253 | |||
254 | # Create a test database
|
||
255 | #
|
||
256 | proc reset_db {} { |
||
257 | catch {db close} |
||
258 | file delete -force test.db |
||
259 | file delete -force test.db-journal |
||
260 | file delete -force test.db-wal |
||
261 | sqlite3 db ./test.db |
||
262 | set ::DB [sqlite3_connection_pointer db] |
||
263 | if {[info exists ::SETUP_SQL]} { |
||
264 | db eval $::SETUP_SQL |
||
265 | } |
||
266 | } |
||
267 | reset_db |
||
268 | |||
269 | # Abort early if this script has been run before.
|
||
270 | #
|
||
271 | if {[info exists TC(count)]} return |
||
272 | |||
273 | # Make sure memory statistics are enabled.
|
||
274 | #
|
||
275 | sqlite3_config_memstatus 1 |
||
276 | |||
277 | # Initialize the test counters and set up commands to access them.
|
||
278 | # Or, if this is a slave interpreter, set up aliases to write the
|
||
279 | # counters in the parent interpreter.
|
||
280 | #
|
||
281 | if {0==[info exists ::SLAVE]} { |
||
282 | set TC(errors) 0 |
||
283 | set TC(count) 0 |
||
284 | set TC(fail_list) [list] |
||
285 | set TC(omit_list) [list] |
||
286 | |||
287 | proc set_test_counter {counter args} { |
||
288 | if {[llength $args]} { |
||
289 | set ::TC($counter) [lindex $args 0] |
||
290 | } |
||
291 | set ::TC($counter) |
||
292 | } |
||
293 | } |
||
294 | |||
295 | # Record the fact that a sequence of tests were omitted.
|
||
296 | #
|
||
297 | proc omit_test {name reason} { |
||
298 | set omitList [set_test_counter omit_list] |
||
299 | lappend omitList [list $name $reason] |
||
300 | set_test_counter omit_list $omitList |
||
301 | } |
||
302 | |||
303 | # Record the fact that a test failed.
|
||
304 | #
|
||
305 | proc fail_test {name} { |
||
306 | set f [set_test_counter fail_list] |
||
307 | lappend f $name |
||
308 | set_test_counter fail_list $f |
||
309 | set_test_counter errors [expr [set_test_counter errors] + 1] |
||
310 | |||
311 | set nFail [set_test_counter errors] |
||
312 | if {$nFail>=$::cmdlinearg(maxerror)} { |
||
313 | puts "*** Giving up..." |
||
314 | finalize_testing |
||
315 | } |
||
316 | } |
||
317 | |||
318 | # Increment the number of tests run
|
||
319 | #
|
||
320 | proc incr_ntest {} { |
||
321 | set_test_counter count [expr [set_test_counter count] + 1] |
||
322 | } |
||
323 | |||
324 | |||
325 | # Invoke the do_test procedure to run a single test
|
||
326 | #
|
||
327 | proc do_test {name cmd expected} { |
||
328 | |||
329 | global argv cmdlinearg |
||
330 | |||
331 | fix_testname name |
||
332 | |||
333 | sqlite3_memdebug_settitle $name |
||
334 | |||
335 | # if {[llength $argv]==0} {
|
||
336 | # set go 1
|
||
337 | # } else {
|
||
338 | # set go 0
|
||
339 | # foreach pattern $argv {
|
||
340 | # if {[string match $pattern $name]} {
|
||
341 | # set go 1
|
||
342 | # break
|
||
343 | # }
|
||
344 | # }
|
||
345 | # }
|
||
346 | |||
347 | if {[info exists ::G(perm:prefix)]} { |
||
348 | set name "$::G(perm:prefix)$name" |
||
349 | } |
||
350 | |||
351 | incr_ntest |
||
352 | puts -nonewline $name... |
||
353 | flush stdout |
||
354 | if {[catch {uplevel #0 "$cmd;\n"} result]} {
|
||
355 | puts "\nError: $result" |
||
356 | fail_test $name |
||
357 | } else { |
||
358 | #
|
||
359 | # TCL implementation BUG can return {{}} for empty string
|
||
360 | # 2011-06-11 Noah Hart -- To be fixed
|
||
361 | #
|
||
362 | set REPLACE "{{}} " |
||
363 | regsub -all $REPLACE $expected "" expected |
||
364 | regsub -all $REPLACE $result "" result |
||
365 | set REPLACE "{{}}" |
||
366 | regsub -all $REPLACE $expected "" expected |
||
367 | regsub -all $REPLACE $result "" result |
||
368 | if {[string compare $result $expected]} { |
||
369 | set WHITESPACE "{} \t\r\n" ;# white space & Extra braces
|
||
370 | set REPLACE "(\[$WHITESPACE])" |
||
371 | regsub -all $REPLACE $expected "" testEXP |
||
372 | regsub -all $REPLACE $result "" testRES |
||
373 | if { [string compare $testRES $testEXP]} { |
||
374 | puts "\nExpected: \[$expected\]\n Got: \[$result\]" |
||
375 | fail_test $name |
||
376 | } else { |
||
377 | puts " Ok" |
||
378 | } |
||
379 | } else { |
||
380 | puts " Ok" |
||
381 | } |
||
382 | } |
||
383 | flush stdout |
||
384 | } |
||
385 | |||
386 | # Implemented in the changes in Tcl/Tk 8.5 as part of TIP #272[1].
|
||
387 | # Downward compatible pure-Tcl version:
|
||
388 | proc lreverse list { |
||
389 | set res {} |
||
390 | set i [llength $list] |
||
391 | while {$i > 0} {lappend res [lindex $list [incr i -1]]} |
||
392 | set res |
||
393 | } ;# RS
|
||
394 | |||
395 | proc filepath_normalize {p} { |
||
396 | # test cases should be written to assume "unix"-like file paths
|
||
397 | if {$::tcl_platform(platform)!="unix"} { |
||
398 | # lreverse*2 as a hack to remove any unneeded {} after the string map
|
||
399 | lreverse [lreverse [string map {\\ /} [regsub -nocase -all {[a-z]:[/\\]+} $p {/}]]] |
||
400 | } { |
||
401 | set p |
||
402 | } |
||
403 | } |
||
404 | proc do_filepath_test {name cmd expected} { |
||
405 | uplevel [list do_test $name [ |
||
406 | subst -nocommands { filepath_normalize [ $cmd ] } |
||
407 | ] [filepath_normalize $expected]] |
||
408 | } |
||
409 | |||
410 | proc realnum_normalize {r} { |
||
411 | # different TCL versions display floating point values differently.
|
||
412 | string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}]
|
||
413 | } |
||
414 | proc do_realnum_test {name cmd expected} { |
||
415 | uplevel [list do_test $name [ |
||
416 | subst -nocommands { realnum_normalize [ $cmd ] } |
||
417 | ] [realnum_normalize $expected]] |
||
418 | } |
||
419 | |||
420 | proc fix_testname {varname} { |
||
421 | upvar $varname testname |
||
422 | if {[info exists ::testprefix] |
||
423 | && [string is digit [string range $testname 0 0]] |
||
424 | } { |
||
425 | set testname "${::testprefix}-$testname" |
||
426 | } |
||
427 | } |
||
428 | |||
429 | proc do_execsql_test {testname sql {result {}}} { |
||
430 | fix_testname testname |
||
431 | uplevel do_test [list $testname] [list "execsql {$sql}"] [list [list {*}$result]] |
||
432 | } |
||
433 | proc do_catchsql_test {testname sql result} { |
||
434 | fix_testname testname |
||
435 | uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result] |
||
436 | } |
||
437 | proc do_eqp_test {name sql res} { |
||
438 | uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res] |
||
439 | } |
||
440 | |||
441 | |||
442 | #-------------------------------------------------------------------------
|
||
443 | # Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST
|
||
444 | #
|
||
445 | # Where switches are:
|
||
446 | #
|
||
447 | # -errorformat FMTSTRING
|
||
448 | # -count
|
||
449 | # -query SQL
|
||
450 | # -tclquery TCL
|
||
451 | # -repair TCL
|
||
452 | #
|
||
453 | proc do_select_tests {prefix args} { |
||
454 | |||
455 | set testlist [lindex $args end] |
||
456 | set switches [lrange $args 0 end-1] |
||
457 | |||
458 | set errfmt "" |
||
459 | set countonly 0 |
||
460 | set tclquery "" |
||
461 | set repair "" |
||
462 | |||
463 | for {set i 0} {$i < [llength $switches]} {incr i} { |
||
464 | set s [lindex $switches $i] |
||
465 | set n [string length $s] |
||
466 | if {$n>=2 && [string equal -length $n $s "-query"]} { |
||
467 | set tclquery [list execsql [lindex $switches [incr i]]] |
||
468 | } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} { |
||
469 | set tclquery [lindex $switches [incr i]] |
||
470 | } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} { |
||
471 | set errfmt [lindex $switches [incr i]] |
||
472 | } elseif {$n>=2 && [string equal -length $n $s "-repair"]} { |
||
473 | set repair [lindex $switches [incr i]] |
||
474 | } elseif {$n>=2 && [string equal -length $n $s "-count"]} { |
||
475 | set countonly 1 |
||
476 | } else { |
||
477 | error "unknown switch: $s" |
||
478 | } |
||
479 | } |
||
480 | |||
481 | if {$countonly && $errfmt!=""} { |
||
482 | error "Cannot use -count and -errorformat together" |
||
483 | } |
||
484 | set nTestlist [llength $testlist] |
||
485 | if {$nTestlist%3 || $nTestlist==0 } { |
||
486 | error "SELECT test list contains [llength $testlist] elements" |
||
487 | } |
||
488 | |||
489 | eval $repair |
||
490 | foreach {tn sql res} $testlist { |
||
491 | if {$tclquery != ""} { |
||
492 | execsql $sql |
||
493 | uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]] |
||
494 | } elseif {$countonly} { |
||
495 | set nRow 0 |
||
496 | db eval $sql {incr nRow} |
||
497 | uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res] |
||
498 | } elseif {$errfmt==""} { |
||
499 | uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]] |
||
500 | } else { |
||
501 | set res [list 1 [string trim [format $errfmt {*}$res]]] |
||
502 | uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res] |
||
503 | } |
||
504 | eval $repair |
||
505 | } |
||
506 | |||
507 | } |
||
508 | |||
509 | proc delete_all_data {} { |
||
510 | db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} { |
||
511 | db eval "DELETE FROM '[string map {' ''} $t]'" |
||
512 | } |
||
513 | } |
||
514 | |||
515 | # Run an SQL script.
|
||
516 | # Return the number of microseconds per statement.
|
||
517 | #
|
||
518 | proc speed_trial {name numstmt units sql} { |
||
519 | puts -nonewline [format {%-21.21s } $name...] |
||
520 | flush stdout |
||
521 | set speed [time {sqlite3_exec_nr db $sql}] |
||
522 | set tm [lindex $speed 0] |
||
523 | if {$tm == 0} { |
||
524 | set rate [format %20s "many"] |
||
525 | } else { |
||
526 | set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] |
||
527 | } |
||
528 | set u2 $units/s |
||
529 | puts [format {%12d uS %s %s} $tm $rate $u2] |
||
530 | global total_time |
||
531 | set total_time [expr {$total_time+$tm}] |
||
532 | lappend ::speed_trial_times $name $tm |
||
533 | } |
||
534 | proc speed_trial_tcl {name numstmt units script} { |
||
535 | puts -nonewline [format {%-21.21s } $name...] |
||
536 | flush stdout |
||
537 | set speed [time {eval $script}] |
||
538 | set tm [lindex $speed 0] |
||
539 | if {$tm == 0} { |
||
540 | set rate [format %20s "many"] |
||
541 | } else { |
||
542 | set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] |
||
543 | } |
||
544 | set u2 $units/s |
||
545 | puts [format {%12d uS %s %s} $tm $rate $u2] |
||
546 | global total_time |
||
547 | set total_time [expr {$total_time+$tm}] |
||
548 | lappend ::speed_trial_times $name $tm |
||
549 | } |
||
550 | proc speed_trial_init {name} { |
||
551 | global total_time |
||
552 | set total_time 0 |
||
553 | set ::speed_trial_times [list] |
||
554 | sqlite3 versdb :memory: |
||
555 | set vers [versdb one {SELECT sqlite_source_id()}] |
||
556 | versdb close |
||
557 | puts "SQLite $vers" |
||
558 | } |
||
559 | proc speed_trial_summary {name} { |
||
560 | global total_time |
||
561 | puts [format {%-21.21s %12d uS TOTAL} $name $total_time] |
||
562 | |||
563 | if { 0 } { |
||
564 | sqlite3 versdb :memory: |
||
565 | set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0] |
||
566 | versdb close |
||
567 | puts "CREATE TABLE IF NOT EXISTS time(version, script, test, us);" |
||
568 | foreach {test us} $::speed_trial_times { |
||
569 | puts "INSERT INTO time VALUES('$vers', '$name', '$test', $us);" |
||
570 | } |
||
571 | } |
||
572 | } |
||
573 | |||
574 | # Run this routine last
|
||
575 | #
|
||
576 | proc finish_test {} { |
||
577 | catch {db close} |
||
578 | catch {db2 close} |
||
579 | catch {db3 close} |
||
580 | if {0==[info exists ::SLAVE]} { finalize_testing } |
||
581 | } |
||
582 | proc finalize_testing {} { |
||
583 | global sqlite_open_file_count |
||
584 | |||
585 | set omitList [set_test_counter omit_list] |
||
586 | |||
587 | catch {db close} |
||
588 | catch {db2 close} |
||
589 | catch {db3 close} |
||
590 | |||
591 | vfs_unlink_test |
||
592 | sqlite3 db {} |
||
593 | # sqlite3_clear_tsd_memdebug
|
||
594 | db close |
||
595 | sqlite3_reset_auto_extension |
||
596 | |||
597 | sqlite3_soft_heap_limit 0 |
||
598 | set nTest [incr_ntest] |
||
599 | set nErr [set_test_counter errors] |
||
600 | |||
601 | puts "$nErr errors out of $nTest tests" |
||
602 | if {$nErr>0} { |
||
603 | puts "Failures on these tests: [set_test_counter fail_list]" |
||
604 | } |
||
605 | run_thread_tests 1 |
||
606 | if {[llength $omitList]>0} { |
||
607 | puts "Omitted test cases:" |
||
608 | set prec {} |
||
609 | foreach {rec} [lsort $omitList] { |
||
610 | if {$rec==$prec} continue |
||
611 | set prec $rec |
||
612 | puts [format { %-12s %s} [lindex $rec 0] [lindex $rec 1]] |
||
613 | } |
||
614 | } |
||
615 | if {$nErr>0 && ![working_64bit_int]} { |
||
616 | puts "******************************************************************" |
||
617 | puts "N.B.: The version of TCL that you used to build this test harness" |
||
618 | puts "is defective in that it does not support 64-bit integers. Some or" |
||
619 | puts "all of the test failures above might be a result from this defect" |
||
620 | puts "in your TCL build." |
||
621 | puts "******************************************************************" |
||
622 | } |
||
623 | if {$::cmdlinearg(binarylog)} { |
||
624 | vfslog finalize binarylog |
||
625 | } |
||
626 | if {$sqlite_open_file_count} { |
||
627 | puts "$sqlite_open_file_count files were left open" |
||
628 | incr nErr |
||
629 | } |
||
630 | ifcapable malloc { |
||
631 | if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 || |
||
632 | [sqlite3_memory_used]>0} { |
||
633 | puts "Unfreed memory: [sqlite3_memory_used] bytes in\
|
||
634 | [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations" |
||
635 | incr nErr |
||
636 | ifcapable memdebug||mem5||(mem3&&debug) { |
||
637 | puts "Writing unfreed memory log to \"./memleak.txt\"" |
||
638 | sqlite3_memdebug_dump ./memleak.txt |
||
639 | } |
||
640 | } else { |
||
641 | puts "All memory allocations freed - no leaks" |
||
642 | ifcapable memdebug||mem5 { |
||
643 | sqlite3_memdebug_dump ./memusage.txt |
||
644 | } |
||
645 | } |
||
646 | show_memstats |
||
647 | #puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
|
||
648 | #puts "Current memory usage: [sqlite3_memory_highwater] bytes"
|
||
649 | if {[info commands sqlite3_memdebug_malloc_count] ne ""} { |
||
650 | puts "Number of malloc() : [sqlite3_memdebug_malloc_count] calls" |
||
651 | } |
||
652 | if {$::cmdlinearg(malloctrace)} { |
||
653 | puts "Writing mallocs.sql..." |
||
654 | memdebug_log_sql |
||
655 | sqlite3_memdebug_log stop |
||
656 | sqlite3_memdebug_log clear |
||
657 | |||
658 | if {[sqlite3_memory_used]>0} { |
||
659 | puts "Writing leaks.sql..." |
||
660 | sqlite3_memdebug_log sync |
||
661 | memdebug_log_sql leaks.sql |
||
662 | } |
||
663 | } |
||
664 | } else { |
||
665 | puts "Memory usage not tracked" |
||
666 | } |
||
667 | |||
668 | foreach f [glob -nocomplain test.db-*-journal] { |
||
669 | file delete -force $f |
||
670 | } |
||
671 | foreach f [glob -nocomplain test.db-mj*] { |
||
672 | file delete -force $f |
||
673 | } |
||
674 | puts -nonewline "Press RETURN to exit..."; gets stdin |
||
675 | exit [expr {$nErr>0}] |
||
676 | } |
||
677 | |||
678 | # Display memory statistics for analysis and debugging purposes.
|
||
679 | #
|
||
680 | proc show_memstats {} { |
||
681 | set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0] |
||
682 | set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0] |
||
683 | set val [format {now %10d max %10d max-size %10d} \ |
||
684 | [lindex $x 1] [lindex $x 2] [lindex $y 2]] |
||
685 | puts "Memory used: $val" |
||
686 | set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] |
||
687 | set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] |
||
688 | puts "Allocation count: $val" |
||
689 | set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0] |
||
690 | set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0] |
||
691 | set val [format {now %10d max %10d max-size %10d} \ |
||
692 | [lindex $x 1] [lindex $x 2] [lindex $y 2]] |
||
693 | puts "Page-cache used: $val" |
||
694 | set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0] |
||
695 | set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] |
||
696 | puts "Page-cache overflow: $val" |
||
697 | set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0] |
||
698 | set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] |
||
699 | puts "Scratch memory used: $val" |
||
700 | set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0] |
||
701 | set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0] |
||
702 | set val [format {now %10d max %10d max-size %10d} \ |
||
703 | [lindex $x 1] [lindex $x 2] [lindex $y 2]] |
||
704 | puts "Scratch overflow: $val" |
||
705 | ifcapable yytrackmaxstackdepth { |
||
706 | set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0] |
||
707 | set val [format { max %10d} [lindex $x 2]] |
||
708 | puts "Parser stack depth: $val" |
||
709 | } |
||
710 | } |
||
711 | |||
712 | # A procedure to execute SQL
|
||
713 | #
|
||
714 | proc execsql {sql {db db}} { |
||
715 | # puts "SQL = $sql"
|
||
716 | uplevel [list $db eval $sql] |
||
717 | } |
||
718 | |||
719 | # Execute SQL and catch exceptions.
|
||
720 | #
|
||
721 | proc catchsql {sql {db db}} { |
||
722 | # puts "SQL = $sql"
|
||
723 | set r [catch [list uplevel [list $db eval $sql]] msg] |
||
724 | lappend r $msg |
||
725 | return $r |
||
726 | } |
||
727 | |||
728 | # Do an VDBE code dump on the SQL given
|
||
729 | #
|
||
730 | proc explain {sql {db db}} { |
||
731 | puts "" |
||
732 | puts "addr opcode p1 p2 p3 p4 p5 #" |
||
733 | puts "---- ------------ ------ ------ ------ --------------- -- -" |
||
734 | $db eval "explain $sql" {} { |
||
735 | puts [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \ |
||
736 | $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment |
||
737 | ] |
||
738 | } |
||
739 | } |
||
740 | |||
741 | # Show the VDBE program for an SQL statement but omit the Trace
|
||
742 | # opcode at the beginning. This procedure can be used to prove
|
||
743 | # that different SQL statements generate exactly the same VDBE code.
|
||
744 | #
|
||
745 | proc explain_no_trace {sql} { |
||
746 | set tr [db eval "EXPLAIN $sql"] |
||
747 | return [lrange $tr 7 end] |
||
748 | } |
||
749 | |||
750 | # Another procedure to execute SQL. This one includes the field
|
||
751 | # names in the returned list.
|
||
752 | #
|
||
753 | proc execsql2 {sql} { |
||
754 | set result {} |
||
755 | db eval $sql data { |
||
756 | foreach f $data(*) { |
||
757 | lappend result $f $data($f) |
||
758 | } |
||
759 | } |
||
760 | return $result |
||
761 | } |
||
762 | |||
763 | # Use the non-callback API to execute multiple SQL statements
|
||
764 | #
|
||
765 | proc stepsql {dbptr sql} { |
||
766 | set sql [string trim $sql] |
||
767 | set r 0 |
||
768 | while {[string length $sql]>0} { |
||
769 | if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} { |
||
770 | return [list 1 $vm] |
||
771 | } |
||
772 | set sql [string trim $sqltail] |
||
773 | # while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
|
||
774 | # foreach v $VAL {lappend r $v}
|
||
775 | # }
|
||
776 | while {[sqlite3_step $vm]=="SQLITE_ROW"} { |
||
777 | for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} { |
||
778 | lappend r [sqlite3_column_text $vm $i] |
||
779 | } |
||
780 | } |
||
781 | if {[catch {sqlite3_finalize $vm} errmsg]} { |
||
782 | return [list 1 $errmsg] |
||
783 | } |
||
784 | } |
||
785 | return $r |
||
786 | } |
||
787 | |||
788 | # Delete a file or directory
|
||
789 | #
|
||
790 | proc forcedelete {args} { |
||
791 | foreach filename $args { |
||
792 | # On windows, sometimes even a [file delete -force] can fail just after
|
||
793 | # a file is closed. The cause is usually "tag-alongs" - programs like
|
||
794 | # anti-virus software, automatic backup tools and various explorer
|
||
795 | # extensions that keep a file open a little longer than we expect, causing
|
||
796 | # the delete to fail.
|
||
797 | #
|
||
798 | # The solution is to wait a short amount of time before retrying the
|
||
799 | # delete.
|
||
800 | #
|
||
801 | set nRetry 50 ;# Maximum number of retries.
|
||
802 | set nDelay 100 ;# Delay in ms before retrying.
|
||
803 | for {set i 0} {$i<$nRetry} {incr i} { |
||
804 | set rc [catch {file delete -force $filename} msg] |
||
805 | if {$rc==0} break |
||
806 | after $nDelay |
||
807 | } |
||
808 | if {$rc} { error $msg } |
||
809 | } |
||
810 | } |
||
811 | |||
812 | # Do an integrity check of the entire database
|
||
813 | #
|
||
814 | proc integrity_check {name {db db}} { |
||
815 | ifcapable integrityck { |
||
816 | do_test $name [list execsql {PRAGMA integrity_check} $db] {ok} |
||
817 | } |
||
818 | } |
||
819 | |||
820 | |||
821 | # Return true if the SQL statement passed as the second argument uses a
|
||
822 | # statement transaction.
|
||
823 | #
|
||
824 | proc sql_uses_stmt {db sql} { |
||
825 | set stmt [sqlite3_prepare $db $sql -1 dummy] |
||
826 | set uses [uses_stmt_journal $stmt] |
||
827 | sqlite3_finalize $stmt |
||
828 | return $uses |
||
829 | } |
||
830 | |||
831 | proc fix_ifcapable_expr {expr} { |
||
832 | set ret "" |
||
833 | set state 0 |
||
834 | for {set i 0} {$i < [string length $expr]} {incr i} { |
||
835 | set char [string range $expr $i $i] |
||
836 | set newstate [expr {[string is alnum $char] || $char eq "_"}] |
||
837 | if {$newstate && !$state} { |
||
838 | append ret {$::sqlite_options(} |
||
839 | } |
||
840 | if {!$newstate && $state} { |
||
841 | append ret ) |
||
842 | } |
||
843 | append ret $char |
||
844 | set state $newstate |
||
845 | } |
||
846 | if {$state} {append ret )} |
||
847 | return $ret |
||
848 | } |
||
849 | |||
850 | # Evaluate a boolean expression of capabilities. If true, execute the
|
||
851 | # code. Omit the code if false.
|
||
852 | #
|
||
853 | proc ifcapable {expr code {else ""} {elsecode ""}} { |
||
854 | #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
|
||
855 | set e2 [fix_ifcapable_expr $expr] |
||
856 | if ($e2) { |
||
857 | set c [catch {uplevel 1 $code} r] |
||
858 | } else { |
||
859 | set c [catch {uplevel 1 $elsecode} r] |
||
860 | } |
||
861 | return -code $c $r |
||
862 | } |
||
863 | |||
864 | # This proc execs a seperate process that crashes midway through executing
|
||
865 | # the SQL script $sql on database test.db.
|
||
866 | #
|
||
867 | # The crash occurs during a sync() of file $crashfile. When the crash
|
||
868 | # occurs a random subset of all unsynced writes made by the process are
|
||
869 | # written into the files on disk. Argument $crashdelay indicates the
|
||
870 | # number of file syncs to wait before crashing.
|
||
871 | #
|
||
872 | # The return value is a list of two elements. The first element is a
|
||
873 | # boolean, indicating whether or not the process actually crashed or
|
||
874 | # reported some other error. The second element in the returned list is the
|
||
875 | # error message. This is "child process exited abnormally" if the crash
|
||
876 | # occured.
|
||
877 | #
|
||
878 | # crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
|
||
879 | #
|
||
880 | proc crashsql {args} { |
||
881 | |||
882 | set blocksize "" |
||
883 | set crashdelay 1 |
||
884 | set prngseed 0 |
||
885 | set tclbody {} |
||
886 | set crashfile "" |
||
887 | set dc "" |
||
888 | set sql [lindex $args end] |
||
889 | |||
890 | for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} { |
||
891 | set z [lindex $args $ii] |
||
892 | set n [string length $z] |
||
893 | set z2 [lindex $args [expr $ii+1]] |
||
894 | |||
895 | if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \ |
||
896 | elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \ |
||
897 | elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \ |
||
898 | elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \ |
||
899 | elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \ |
||
900 | elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \ |
||
901 | else { error "Unrecognized option: $z" } |
||
902 | } |
||
903 | |||
904 | if {$crashfile eq ""} { |
||
905 | error "Compulsory option -file missing" |
||
906 | } |
||
907 | |||
908 | # $crashfile gets compared to the native filename in
|
||
909 | # cfSync(), which can be different then what TCL uses by
|
||
910 | # default, so here we force it to the "nativename" format.
|
||
911 | set cfile [string map {\\ \\\\} [file nativename [file join [pwd] $crashfile]]] |
||
912 | |||
913 | set f [open crash.tcl w] |
||
914 | puts $f "sqlite3_crash_enable 1" |
||
915 | puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile" |
||
916 | puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" |
||
917 | puts $f "sqlite3 db test.db -vfs crash" |
||
918 | |||
919 | # This block sets the cache size of the main database to 10
|
||
920 | # pages. This is done in case the build is configured to omit
|
||
921 | # "PRAGMA cache_size".
|
||
922 | puts $f {db eval {SELECT * FROM sqlite_master;}} |
||
923 | puts $f {set bt [btree_from_db db]} |
||
924 | puts $f {btree_set_cache_size $bt 10} |
||
925 | if {$prngseed} { |
||
926 | set seed [expr {$prngseed%10007+1}] |
||
927 | # puts seed=$seed
|
||
928 | puts $f "db eval {SELECT randomblob($seed)}" |
||
929 | } |
||
930 | |||
931 | if {[string length $tclbody]>0} { |
||
932 | puts $f $tclbody |
||
933 | } |
||
934 | if {[string length $sql]>0} { |
||
935 | puts $f "db eval {" |
||
936 | puts $f "$sql" |
||
937 | puts $f "}" |
||
938 | } |
||
939 | close $f |
||
940 | set r [catch { |
||
941 | exec [info nameofexec] crash.tcl >@stdout |
||
942 | } msg] |
||
943 | |||
944 | # Windows/ActiveState TCL returns a slightly different
|
||
945 | # error message. We map that to the expected message
|
||
946 | # so that we don't have to change all of the test
|
||
947 | # cases.
|
||
948 | if {$::tcl_platform(platform)=="windows"} { |
||
949 | if {$msg=="child killed: unknown signal"} { |
||
950 | set msg "child process exited abnormally" |
||
951 | } |
||
952 | } |
||
953 | |||
954 | lappend r $msg |
||
955 | } |
||
956 | |||
957 | # Usage: do_ioerr_test <test number> <options...>
|
||
958 | #
|
||
959 | # This proc is used to implement test cases that check that IO errors
|
||
960 | # are correctly handled. The first argument, <test number>, is an integer
|
||
961 | # used to name the tests executed by this proc. Options are as follows:
|
||
962 | #
|
||
963 | # -tclprep TCL script to run to prepare test.
|
||
964 | # -sqlprep SQL script to run to prepare test.
|
||
965 | # -tclbody TCL script to run with IO error simulation.
|
||
966 | # -sqlbody TCL script to run with IO error simulation.
|
||
967 | # -exclude List of 'N' values not to test.
|
||
968 | # -erc Use extended result codes
|
||
969 | # -persist Make simulated I/O errors persistent
|
||
970 | # -start Value of 'N' to begin with (default 1)
|
||
971 | #
|
||
972 | # -cksum Boolean. If true, test that the database does
|
||
973 | # not change during the execution of the test case.
|
||
974 | #
|
||
975 | proc do_ioerr_test {testname args} { |
||
976 | |||
977 | set ::ioerropts(-start) 1 |
||
978 | set ::ioerropts(-cksum) 0 |
||
979 | set ::ioerropts(-erc) 0 |
||
980 | set ::ioerropts(-count) 100000000 |
||
981 | set ::ioerropts(-persist) 1 |
||
982 | set ::ioerropts(-ckrefcount) 0 |
||
983 | set ::ioerropts(-restoreprng) 1 |
||
984 | array set ::ioerropts $args |
||
985 | |||
986 | # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
|
||
987 | # a couple of obscure IO errors that do not return them.
|
||
988 | set ::ioerropts(-erc) 0 |
||
989 | |||
990 | set ::go 1 |
||
991 | #reset_prng_state
|
||
992 | save_prng_state |
||
993 | for {set n $::ioerropts(-start)} {$::go} {incr n} { |
||
994 | set ::TN $n |
||
995 | incr ::ioerropts(-count) -1 |
||
996 | if {$::ioerropts(-count)<0} break |
||
997 | |||
998 | # Skip this IO error if it was specified with the "-exclude" option.
|
||
999 | if {[info exists ::ioerropts(-exclude)]} { |
||
1000 | if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue |
||
1001 | } |
||
1002 | if {$::ioerropts(-restoreprng)} { |
||
1003 | restore_prng_state |
||
1004 | } |
||
1005 | |||
1006 | # Delete the files test.db and test2.db, then execute the TCL and
|
||
1007 | # SQL (in that order) to prepare for the test case.
|
||
1008 | do_test $testname.$n.1 { |
||
1009 | set ::sqlite_io_error_pending 0 |
||
1010 | catch {db close} |
||
1011 | catch {db2 close} |
||
1012 | catch {file delete -force test.db} |
||
1013 | catch {file delete -force test.db-journal} |
||
1014 | catch {file delete -force test2.db} |
||
1015 | catch {file delete -force test2.db-journal} |
||
1016 | set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] |
||
1017 | sqlite3_extended_result_codes $::DB $::ioerropts(-erc) |
||
1018 | if {[info exists ::ioerropts(-tclprep)]} { |
||
1019 | eval $::ioerropts(-tclprep) |
||
1020 | } |
||
1021 | if {[info exists ::ioerropts(-sqlprep)]} { |
||
1022 | execsql $::ioerropts(-sqlprep) |
||
1023 | } |
||
1024 | expr 0 |
||
1025 | } {0} |
||
1026 | |||
1027 | # Read the 'checksum' of the database.
|
||
1028 | if {$::ioerropts(-cksum)} { |
||
1029 | set checksum [cksum] |
||
1030 | } |
||
1031 | |||
1032 | # Set the Nth IO error to fail.
|
||
1033 | do_test $testname.$n.2 [subst { |
||
1034 | set ::sqlite_io_error_persist $::ioerropts(-persist) |
||
1035 | set ::sqlite_io_error_pending $n |
||
1036 | }] $n |
||
1037 | |||
1038 | # Create a single TCL script from the TCL and SQL specified
|
||
1039 | # as the body of the test.
|
||
1040 | set ::ioerrorbody {} |
||
1041 | if {[info exists ::ioerropts(-tclbody)]} { |
||
1042 | append ::ioerrorbody "$::ioerropts(-tclbody)\n" |
||
1043 | } |
||
1044 | if {[info exists ::ioerropts(-sqlbody)]} { |
||
1045 | append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}" |
||
1046 | } |
||
1047 | |||
1048 | # Execute the TCL Script created in the above block. If
|
||
1049 | # there are at least N IO operations performed by SQLite as
|
||
1050 | # a result of the script, the Nth will fail.
|
||
1051 | do_test $testname.$n.3 { |
||
1052 | set ::sqlite_io_error_hit 0 |
||
1053 | set ::sqlite_io_error_hardhit 0 |
||
1054 | set r [catch $::ioerrorbody msg] |
||
1055 | set ::errseen $r |
||
1056 | set rc [sqlite3_errcode $::DB] |
||
1057 | if {$::ioerropts(-erc)} { |
||
1058 | # If we are in extended result code mode, make sure all of the
|
||
1059 | # IOERRs we get back really do have their extended code values.
|
||
1060 | # If an extended result code is returned, the sqlite3_errcode
|
||
1061 | # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn
|
||
1062 | # where nnnn is a number
|
||
1063 | if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} { |
||
1064 | return $rc |
||
1065 | } |
||
1066 | } else { |
||
1067 | # If we are not in extended result code mode, make sure no
|
||
1068 | # extended error codes are returned.
|
||
1069 | if {[regexp {\+\d} $rc]} { |
||
1070 | return $rc |
||
1071 | } |
||
1072 | } |
||
1073 | # The test repeats as long as $::go is non-zero. $::go starts out
|
||
1074 | # as 1. When a test runs to completion without hitting an I/O
|
||
1075 | # error, that means there is no point in continuing with this test
|
||
1076 | # case so set $::go to zero.
|
||
1077 | #
|
||
1078 | if {$::sqlite_io_error_pending>0} { |
||
1079 | set ::go 0 |
||
1080 | set q 0 |
||
1081 | set ::sqlite_io_error_pending 0 |
||
1082 | } else { |
||
1083 | set q 1 |
||
1084 | } |
||
1085 | |||
1086 | set s [expr $::sqlite_io_error_hit==0] |
||
1087 | if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} { |
||
1088 | set r 1 |
||
1089 | } |
||
1090 | set ::sqlite_io_error_hit 0 |
||
1091 | |||
1092 | # One of two things must have happened. either
|
||
1093 | # 1. We never hit the IO error and the SQL returned OK
|
||
1094 | # 2. An IO error was hit and the SQL failed
|
||
1095 | #
|
||
1096 | #puts "s=$s r=$r q=$q"
|
||
1097 | expr { ($s && !$r && !$q) || (!$s && $r && $q) } |
||
1098 | } {1} |
||
1099 | |||
1100 | set ::sqlite_io_error_hit 0 |
||
1101 | set ::sqlite_io_error_pending 0 |
||
1102 | |||
1103 | # Check that no page references were leaked. There should be
|
||
1104 | # a single reference if there is still an active transaction,
|
||
1105 | # or zero otherwise.
|
||
1106 | #
|
||
1107 | # UPDATE: If the IO error occurs after a 'BEGIN' but before any
|
||
1108 | # locks are established on database files (i.e. if the error
|
||
1109 | # occurs while attempting to detect a hot-journal file), then
|
||
1110 | # there may 0 page references and an active transaction according
|
||
1111 | # to [sqlite3_get_autocommit].
|
||
1112 | #
|
||
1113 | if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} { |
||
1114 | do_test $testname.$n.4 { |
||
1115 | set bt [btree_from_db db] |
||
1116 | db_enter db |
||
1117 | array set stats [btree_pager_stats $bt] |
||
1118 | db_leave db |
||
1119 | set nRef $stats(ref) |
||
1120 | expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)} |
||
1121 | } {1} |
||
1122 | } |
||
1123 | |||
1124 | # If there is an open database handle and no open transaction,
|
||
1125 | # and the pager is not running in exclusive-locking mode,
|
||
1126 | # check that the pager is in "unlocked" state. Theoretically,
|
||
1127 | # if a call to xUnlock() failed due to an IO error the underlying
|
||
1128 | # file may still be locked.
|
||
1129 | #
|
||
1130 | ifcapable pragma { |
||
1131 | if { [info commands db] ne "" |
||
1132 | && $::ioerropts(-ckrefcount) |
||
1133 | && [db one {pragma locking_mode}] eq "normal" |
||
1134 | && [sqlite3_get_autocommit db] |
||
1135 | } { |
||
1136 | do_test $testname.$n.5 { |
||
1137 | set bt [btree_from_db db] |
||
1138 | db_enter db |
||
1139 | array set stats [btree_pager_stats $bt] |
||
1140 | db_leave db |
||
1141 | set stats(state) |
||
1142 | } 0 |
||
1143 | } |
||
1144 | } |
||
1145 | |||
1146 | # If an IO error occured, then the checksum of the database should
|
||
1147 | # be the same as before the script that caused the IO error was run.
|
||
1148 | #
|
||
1149 | if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} { |
||
1150 | do_test $testname.$n.6 { |
||
1151 | catch {db close} |
||
1152 | catch {db2 close} |
||
1153 | set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] |
||
1154 | cksum |
||
1155 | } $checksum |
||
1156 | } |
||
1157 | |||
1158 | set ::sqlite_io_error_hardhit 0 |
||
1159 | set ::sqlite_io_error_pending 0 |
||
1160 | if {[info exists ::ioerropts(-cleanup)]} { |
||
1161 | catch $::ioerropts(-cleanup) |
||
1162 | } |
||
1163 | } |
||
1164 | set ::sqlite_io_error_pending 0 |
||
1165 | set ::sqlite_io_error_persist 0 |
||
1166 | unset ::ioerropts |
||
1167 | } |
||
1168 | |||
1169 | # Return a checksum based on the contents of the main database associated
|
||
1170 | # with connection $db
|
||
1171 | #
|
||
1172 | proc cksum {{db db}} { |
||
1173 | set txt [$db eval { |
||
1174 | SELECT name, type, sql FROM sqlite_master order by name |
||
1175 | }]\n |
||
1176 | foreach tbl [$db eval { |
||
1177 | SELECT name FROM sqlite_master WHERE type='table' order by name |
||
1178 | }] { |
||
1179 | append txt [$db eval "SELECT * FROM $tbl"]\n |
||
1180 | } |
||
1181 | foreach prag {default_synchronous default_cache_size} { |
||
1182 | append txt $prag-[$db eval "PRAGMA $prag"]\n |
||
1183 | } |
||
1184 | set cksum [string length $txt]-[md5 $txt] |
||
1185 | # puts $cksum-[file size test.db]
|
||
1186 | return $cksum |
||
1187 | } |
||
1188 | |||
1189 | # Generate a checksum based on the contents of the main and temp tables
|
||
1190 | # database $db. If the checksum of two databases is the same, and the
|
||
1191 | # integrity-check passes for both, the two databases are identical.
|
||
1192 | #
|
||
1193 | proc allcksum {{db db}} { |
||
1194 | set ret [list] |
||
1195 | ifcapable tempdb { |
||
1196 | set sql { |
||
1197 | SELECT name FROM sqlite_master WHERE type = 'table' UNION |
||
1198 | SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION |
||
1199 | SELECT 'sqlite_master' UNION |
||
1200 | SELECT 'sqlite_temp_master' ORDER BY 1 |
||
1201 | } |
||
1202 | } else { |
||
1203 | set sql { |
||
1204 | SELECT name FROM sqlite_master WHERE type = 'table' UNION |
||
1205 | SELECT 'sqlite_master' ORDER BY 1 |
||
1206 | } |
||
1207 | } |
||
1208 | set tbllist [$db eval $sql] |
||
1209 | set txt {} |
||
1210 | foreach tbl $tbllist { |
||
1211 | append txt [$db eval "SELECT * FROM $tbl"] |
||
1212 | } |
||
1213 | foreach prag {default_cache_size} { |
||
1214 | append txt $prag-[$db eval "PRAGMA $prag"]\n |
||
1215 | } |
||
1216 | # puts txt=$txt
|
||
1217 | return [md5 $txt] |
||
1218 | } |
||
1219 | |||
1220 | # Generate a checksum based on the contents of a single database with
|
||
1221 | # a database connection. The name of the database is $dbname.
|
||
1222 | # Examples of $dbname are "temp" or "main".
|
||
1223 | #
|
||
1224 | proc dbcksum {db dbname} { |
||
1225 | if {$dbname=="temp"} { |
||
1226 | set master sqlite_temp_master |
||
1227 | } else { |
||
1228 | set master $dbname.sqlite_master |
||
1229 | } |
||
1230 | set alltab [$db eval "SELECT name FROM $master WHERE type='table'"] |
||
1231 | set txt [$db eval "SELECT * FROM $master"]\n |
||
1232 | foreach tab $alltab { |
||
1233 | append txt [$db eval "SELECT * FROM $dbname.$tab"]\n |
||
1234 | } |
||
1235 | return [md5 $txt] |
||
1236 | } |
||
1237 | |||
1238 | proc memdebug_log_sql {{filename mallocs.sql}} { |
||
1239 | |||
1240 | set data [sqlite3_memdebug_log dump] |
||
1241 | set nFrame [expr [llength [lindex $data 0]]-2] |
||
1242 | if {$nFrame < 0} { return "" } |
||
1243 | |||
1244 | set database temp |
||
1245 | |||
1246 | set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);" |
||
1247 | |||
1248 | set sql "" |
||
1249 | foreach e $data { |
||
1250 | set nCall [lindex $e 0] |
||
1251 | set nByte [lindex $e 1] |
||
1252 | set lStack [lrange $e 2 end] |
||
1253 | append sql "INSERT INTO ${database}.malloc VALUES" |
||
1254 | append sql "('test', $nCall, $nByte, '$lStack');\n" |
||
1255 | foreach f $lStack { |
||
1256 | set frames($f) 1 |
||
1257 | } |
||
1258 | } |
||
1259 | |||
1260 | set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n" |
||
1261 | set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n" |
||
1262 | |||
1263 | foreach f [array names frames] { |
||
1264 | set addr [format %x $f] |
||
1265 | set cmd "addr2line -e [info nameofexec] $addr" |
||
1266 | set line [eval exec $cmd] |
||
1267 | append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n" |
||
1268 | |||
1269 | set file [lindex [split $line :] 0] |
||
1270 | set files($file) 1 |
||
1271 | } |
||
1272 | |||
1273 | foreach f [array names files] { |
||
1274 | set contents "" |
||
1275 | catch { |
||
1276 | set fd [open $f] |
||
1277 | set contents [read $fd] |
||
1278 | close $fd |
||
1279 | } |
||
1280 | set contents [string map {' ''} $contents] |
||
1281 | append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n" |
||
1282 | } |
||
1283 | |||
1284 | set fd [open $filename w] |
||
1285 | puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;" |
||
1286 | close $fd |
||
1287 | } |
||
1288 | |||
1289 | # Copy file $from into $to. This is used because some versions of
|
||
1290 | # TCL for windows (notably the 8.4.1 binary package shipped with the
|
||
1291 | # current mingw release) have a broken "file copy" command.
|
||
1292 | #
|
||
1293 | proc copy_file {from to} { |
||
1294 | if {$::tcl_platform(platform)=="unix"} { |
||
1295 | file copy -force $from $to |
||
1296 | } else { |
||
1297 | set f [open $from] |
||
1298 | fconfigure $f -translation binary |
||
1299 | set t [open $to w] |
||
1300 | fconfigure $t -translation binary |
||
1301 | puts -nonewline $t [read $f [file size $from]] |
||
1302 | close $t |
||
1303 | close $f |
||
1304 | } |
||
1305 | } |
||
1306 | |||
1307 | # Drop all tables in database [db]
|
||
1308 | proc drop_all_tables {{db db}} { |
||
1309 | ifcapable trigger&&foreignkey { |
||
1310 | set pk [$db one "PRAGMA foreign_keys"] |
||
1311 | $db eval "PRAGMA foreign_keys = OFF" |
||
1312 | } |
||
1313 | foreach {idx name file} [db eval {PRAGMA database_list}] { |
||
1314 | if {$idx==1} { |
||
1315 | set master sqlite_temp_master |
||
1316 | } else { |
||
1317 | set master $name.sqlite_master |
||
1318 | } |
||
1319 | foreach {t type} [$db eval "
|
||
1320 | SELECT name, type FROM $master
|
||
1321 | WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
|
||
1322 | "] { |
||
1323 | $db eval "DROP $type \"$t\"" |
||
1324 | } |
||
1325 | } |
||
1326 | ifcapable trigger&&foreignkey { |
||
1327 | $db eval "PRAGMA foreign_keys = $pk" |
||
1328 | } |
||
1329 | } |
||
1330 | |||
1331 | #-------------------------------------------------------------------------
|
||
1332 | # If a test script is executed with global variable $::G(perm:name) set to
|
||
1333 | # "wal", then the tests are run in WAL mode. Otherwise, they should be run
|
||
1334 | # in rollback mode. The following Tcl procs are used to make this less
|
||
1335 | # intrusive:
|
||
1336 | #
|
||
1337 | # wal_set_journal_mode ?DB?
|
||
1338 | #
|
||
1339 | # If running a WAL test, execute "PRAGMA journal_mode = wal" using
|
||
1340 | # connection handle DB. Otherwise, this command is a no-op.
|
||
1341 | #
|
||
1342 | # wal_check_journal_mode TESTNAME ?DB?
|
||
1343 | #
|
||
1344 | # If running a WAL test, execute a tests case that fails if the main
|
||
1345 | # database for connection handle DB is not currently a WAL database.
|
||
1346 | # Otherwise (if not running a WAL permutation) this is a no-op.
|
||
1347 | #
|
||
1348 | # wal_is_wal_mode
|
||
1349 | #
|
||
1350 | # Returns true if this test should be run in WAL mode. False otherwise.
|
||
1351 | #
|
||
1352 | proc wal_is_wal_mode {} { |
||
1353 | expr {[permutation] eq "wal"} |
||
1354 | } |
||
1355 | proc wal_set_journal_mode {{db db}} { |
||
1356 | if { [wal_is_wal_mode] } { |
||
1357 | $db eval "PRAGMA journal_mode = WAL" |
||
1358 | } |
||
1359 | } |
||
1360 | proc wal_check_journal_mode {testname {db db}} { |
||
1361 | if { [wal_is_wal_mode] } { |
||
1362 | $db eval { SELECT * FROM sqlite_master } |
||
1363 | do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal} |
||
1364 | } |
||
1365 | } |
||
1366 | |||
1367 | proc permutation {} { |
||
1368 | set perm "" |
||
1369 | catch {set perm $::G(perm:name)} |
||
1370 | set perm |
||
1371 | } |
||
1372 | proc presql {} { |
||
1373 | set presql "" |
||
1374 | catch {set presql $::G(perm:presql)} |
||
1375 | set presql |
||
1376 | } |
||
1377 | |||
1378 | #-------------------------------------------------------------------------
|
||
1379 | #
|
||
1380 | proc slave_test_script {script} { |
||
1381 | |||
1382 | # Create the interpreter used to run the test script.
|
||
1383 | interp create tinterp |
||
1384 | |||
1385 | # Populate some global variables that tester.tcl expects to see.
|
||
1386 | foreach {var value} [list \ |
||
1387 | ::argv0 $::argv0 \ |
||
1388 | ::argv {} \ |
||
1389 | ::SLAVE 1 \ |
||
1390 | ] { |
||
1391 | interp eval tinterp [list set $var $value] |
||
1392 | } |
||
1393 | |||
1394 | # The alias used to access the global test counters.
|
||
1395 | tinterp alias set_test_counter set_test_counter |
||
1396 | |||
1397 | # Set up the ::cmdlinearg array in the slave.
|
||
1398 | interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]] |
||
1399 | |||
1400 | # Set up the ::G array in the slave.
|
||
1401 | interp eval tinterp [list array set ::G [array get ::G]] |
||
1402 | |||
1403 | # Load the various test interfaces implemented in C.
|
||
1404 | load_testfixture_extensions tinterp |
||
1405 | |||
1406 | # Run the test script.
|
||
1407 | interp eval tinterp $script |
||
1408 | |||
1409 | # Check if the interpreter call [run_thread_tests]
|
||
1410 | if { [interp eval tinterp {info exists ::run_thread_tests_called}] } { |
||
1411 | set ::run_thread_tests_called 1 |
||
1412 | } |
||
1413 | |||
1414 | # Delete the interpreter used to run the test script.
|
||
1415 | interp delete tinterp |
||
1416 | } |
||
1417 | |||
1418 | proc slave_test_file {zFile} { |
||
1419 | set tail [file tail $zFile] |
||
1420 | |||
1421 | if {[info exists ::G(start:permutation)]} { |
||
1422 | if {[permutation] != $::G(start:permutation)} return |
||
1423 | unset ::G(start:permutation) |
||
1424 | } |
||
1425 | if {[info exists ::G(start:file)]} { |
||
1426 | if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return |
||
1427 | unset ::G(start:file) |
||
1428 | } |
||
1429 | |||
1430 | # Remember the value of the shared-cache setting. So that it is possible
|
||
1431 | # to check afterwards that it was not modified by the test script.
|
||
1432 | #
|
||
1433 | ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] } |
||
1434 | |||
1435 | # Run the test script in a slave interpreter.
|
||
1436 | #
|
||
1437 | unset -nocomplain ::run_thread_tests_called |
||
1438 | reset_prng_state |
||
1439 | set ::sqlite_open_file_count 0 |
||
1440 | set time [time { slave_test_script [list source $zFile] }] |
||
1441 | set ms [expr [lindex $time 0] / 1000] |
||
1442 | |||
1443 | # Test that all files opened by the test script were closed. Omit this
|
||
1444 | # if the test script has "thread" in its name. The open file counter
|
||
1445 | # is not thread-safe.
|
||
1446 | #
|
||
1447 | if {[info exists ::run_thread_tests_called]==0} { |
||
1448 | do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0} |
||
1449 | } |
||
1450 | set ::sqlite_open_file_count 0 |
||
1451 | |||
1452 | # Test that the global "shared-cache" setting was not altered by
|
||
1453 | # the test script.
|
||
1454 | #
|
||
1455 | ifcapable shared_cache { |
||
1456 | set res [expr {[sqlite3_enable_shared_cache] == $scs}] |
||
1457 | do_test ${tail}-sharedcachesetting [list set {} $res] 1 |
||
1458 | } |
||
1459 | |||
1460 | # Add some info to the output.
|
||
1461 | #
|
||
1462 | puts "Time: $tail $ms ms" |
||
1463 | #show_memstats
|
||
1464 | } |
||
1465 | |||
1466 | # Open a new connection on database test.db and execute the SQL script
|
||
1467 | # supplied as an argument. Before returning, close the new conection and
|
||
1468 | # restore the 4 byte fields starting at header offsets 28, 92 and 96
|
||
1469 | # to the values they held before the SQL was executed. This simulates
|
||
1470 | # a write by a pre-3.7.0 client.
|
||
1471 | #
|
||
1472 | proc sql36231 {sql} { |
||
1473 | set B [hexio_read test.db 92 8] |
||
1474 | set A [hexio_read test.db 28 4] |
||
1475 | sqlite3 db36231 test.db |
||
1476 | catch { db36231 func a_string a_string } |
||
1477 | execsql $sql db36231 |
||
1478 | db36231 close |
||
1479 | hexio_write test.db 28 $A |
||
1480 | hexio_write test.db 92 $B |
||
1481 | return "" |
||
1482 | } |
||
1483 | |||
1484 | proc db_save {} { |
||
1485 | foreach f [glob -nocomplain sv_test.db*] { forcedelete $f } |
||
1486 | foreach f [glob -nocomplain test.db*] { |
||
1487 | set f2 "sv_$f" |
||
1488 | file copy -force $f $f2 |
||
1489 | } |
||
1490 | } |
||
1491 | proc db_save_and_close {} { |
||
1492 | db_save |
||
1493 | catch { db close } |
||
1494 | return "" |
||
1495 | } |
||
1496 | proc db_restore {} { |
||
1497 | foreach f [glob -nocomplain test.db*] { forcedelete $f } |
||
1498 | foreach f2 [glob -nocomplain sv_test.db*] { |
||
1499 | set f [string range $f2 3 end] |
||
1500 | file copy -force $f2 $f |
||
1501 | } |
||
1502 | } |
||
1503 | proc db_restore_and_reopen {{dbfile test.db}} { |
||
1504 | catch { db close } |
||
1505 | db_restore |
||
1506 | sqlite3 db $dbfile |
||
1507 | } |
||
1508 | proc db_delete_and_reopen {{file test.db}} { |
||
1509 | catch { db close } |
||
1510 | foreach f [glob -nocomplain test.db*] { file delete -force $f } |
||
1511 | sqlite3 db $file |
||
1512 | } |
||
1513 | |||
1514 | # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
|
||
1515 | # to non-zero, then set the global variable $AUTOVACUUM to 1.
|
||
1516 | set AUTOVACUUM $sqlite_options(default_autovacuum) |
||
1517 | |||
1518 | source $testdir/thread_common.tcl |
||
1519 | source $testdir/malloc_common.tcl |