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