wasCSharpSQLite – Blame information for rev 4

Subversion Repositories:
Rev:
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