3 # The author disclaims copyright to this source code. In place of
4 # a legal notice, here is a blessing:
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.
10 #***********************************************************************
11 # This file implements some common TCL routines used for regression
12 # testing the SQLite library
14 # $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $
16 #-------------------------------------------------------------------------
17 # The commands provided by the code in this file to help with creating
18 # test cases are as follows:
20 # Commands to manipulate the db and the file-system at a high level:
26 # delete_file FILENAME
27 # drop_all_tables ?DB?
28 # drop_all_indexes ?DB?
30 # forcedelete FILENAME
32 # Test the capability of the SQLite version built into the interpreter to
33 # determine if a specific test can be run:
38 # Calulate checksums based on database contents:
44 # Commands to execute/explain SQL statements:
49 # explain_no_trace SQL
54 # Commands to run test cases:
56 # do_ioerr_test TESTNAME ARGS...
58 # integrity_check TESTNAME ?DB?
59 # verify_ex_errcode TESTNAME EXPECTED ?DB?
60 # do_test TESTNAME SCRIPT EXPECTED
61 # do_execsql_test TESTNAME SQL EXPECTED
62 # do_catchsql_test TESTNAME SQL EXPECTED
63 # do_timed_execsql_test TESTNAME SQL EXPECTED
65 # Commands providing a lower level interface to the global test counters:
67 # set_test_counter COUNTER ?VALUE?
68 # omit_test TESTNAME REASON ?APPEND?
72 # Command run at the end of each test file:
76 # Commands to help create test files that run with the "WAL" and other
77 # permutations (see file permutations.test):
80 # wal_set_journal_mode ?DB?
81 # wal_check_journal_mode TESTNAME?DB?
85 # Command to test whether or not --verbose=1 was specified on the command
86 # line (returns 0 for not-verbose, 1 for verbose and 2 for "verbose in the
92 # Only run this script once. If sourced a second time, make it a no-op
93 if {[info exists
::tester_tcl_has_run]} return
95 # Set the precision of FP arithmatic used by the interpreter. And
96 # configure SQLite to take database file locks on the page that begins
97 # 64KB into the database file instead of the one 1GB in. This means
98 # the code that handles that special case can be tested without creating
99 # very large database files.
102 sqlite3_test_control_pending_byte
0x0010000
105 # If the pager codec is available, create a wrapper for the [sqlite3]
106 # command that appends "-key {xyzzy}" to the command line. i.e. this:
112 # sqlite3 db test.db -key {xyzzy}
114 if {[info command sqlite_orig
]==""} {
115 rename sqlite3 sqlite_orig
116 proc sqlite3
{args
} {
117 if {[llength $args]>=2 && [string index
[lindex $args 0] 0]!="-"} {
118 # This command is opening a new database connection.
120 if {[info exists
::G(perm
:sqlite3_args
)]} {
121 set args
[concat $args $::G(perm
:sqlite3_args
)]
123 if {[sqlite_orig
-has-codec
] && ![info exists
::do_not_use_codec]} {
124 lappend args
-key {xyzzy
}
127 set res
[uplevel 1 sqlite_orig
$args]
128 if {[info exists
::G(perm
:presql
)]} {
129 [lindex $args 0] eval $::G(perm
:presql
)
131 if {[info exists
::G(perm
:dbconfig
)]} {
132 set ::dbhandle [lindex $args 0]
133 uplevel #0 $::G(perm:dbconfig)
135 [lindex $args 0] cache size
3
138 # This command is not opening a new database connection. Pass the
139 # arguments through to the C implementation as the are.
141 uplevel 1 sqlite_orig
$args
146 proc getFileRetries
{} {
147 if {![info exists
::G(file-retries
)]} {
149 # NOTE: Return the default number of retries for [file] operations. A
150 # value of zero or less here means "disabled".
152 return [expr {$::tcl_platform(platform
) eq
"windows" ?
50 : 0}]
154 return $::G(file-retries
)
157 proc getFileRetryDelay
{} {
158 if {![info exists
::G(file-retry-delay
)]} {
160 # NOTE: Return the default number of milliseconds to wait when retrying
161 # failed [file] operations. A value of zero or less means "do not
164 return 100; # TODO: Good default?
166 return $::G(file-retry-delay
)
169 # Return the string representing the name of the current directory. On
170 # Windows, the result is "normalized" to whatever our parent command shell
171 # is using to prevent case-mismatch issues.
174 if {$::tcl_platform(platform
) eq
"windows"} {
176 # NOTE: Cannot use [file normalize] here because it would alter the
177 # case of the result to what Tcl considers canonical, which would
178 # defeat the purpose of this procedure.
180 if {[info exists
::env(ComSpec
)]} {
181 set comSpec
$::env(ComSpec
)
183 # NOTE: Hard-code the typical default value.
184 set comSpec
{C
:\Windows
\system32
\cmd.exe
}
186 return [string map
[list \\ /] \
187 [string trim
[exec -- $comSpec /c CD
]]]
193 # Copy file $from into $to. This is used because some versions of
194 # TCL for windows (notably the 8.4.1 binary package shipped with the
195 # current mingw release) have a broken "file copy" command.
197 proc copy_file
{from to
} {
198 do_copy_file false
$from $to
201 proc forcecopy
{from to
} {
202 do_copy_file true
$from $to
205 proc do_copy_file
{force from to
} {
206 set nRetry
[getFileRetries
] ;# Maximum number of retries.
207 set nDelay
[getFileRetryDelay
] ;# Delay in ms before retrying.
209 # On windows, sometimes even a [file copy -force] can fail. The cause is
210 # usually "tag-alongs" - programs like anti-virus software, automatic backup
211 # tools and various explorer extensions that keep a file open a little longer
212 # than we expect, causing the delete to fail.
214 # The solution is to wait a short amount of time before retrying the copy.
217 for {set i
0} {$i<$nRetry} {incr i
} {
220 file copy
-force $from $to
226 if {$nDelay > 0} { after $nDelay }
228 if {$rc} { error $msg }
231 file copy
-force $from $to
238 # Check if a file name is relative
240 proc is_relative_file
{ file } {
241 return [expr {[file pathtype
$file] != "absolute"}]
244 # If the VFS supports using the current directory, returns [pwd];
245 # otherwise, it returns only the provided suffix string (which is
248 proc test_pwd
{ args
} {
249 if {[llength $args] > 0} {
250 set suffix1
[lindex $args 0]
251 if {[llength $args] > 1} {
252 set suffix2
[lindex $args 1]
257 set suffix1
""; set suffix2
""
260 return "[get_pwd]$suffix1"
266 # Delete a file or directory
268 proc delete_file
{args
} {
269 do_delete_file false
{*}$args
272 proc forcedelete
{args
} {
273 do_delete_file true
{*}$args
276 proc do_delete_file
{force args
} {
277 set nRetry
[getFileRetries
] ;# Maximum number of retries.
278 set nDelay
[getFileRetryDelay
] ;# Delay in ms before retrying.
280 foreach filename $args {
281 # On windows, sometimes even a [file delete -force] can fail just after
282 # a file is closed. The cause is usually "tag-alongs" - programs like
283 # anti-virus software, automatic backup tools and various explorer
284 # extensions that keep a file open a little longer than we expect, causing
285 # the delete to fail.
287 # The solution is to wait a short amount of time before retrying the
291 for {set i
0} {$i<$nRetry} {incr i
} {
294 file delete
-force $filename
296 file delete
$filename
300 if {$nDelay > 0} { after $nDelay }
302 if {$rc} { error $msg }
305 file delete
-force $filename
307 file delete
$filename
313 proc execpresql
{handle args
} {
314 trace remove execution
$handle enter
[list execpresql
$handle]
315 if {[info exists
::G(perm
:presql
)]} {
316 $handle eval $::G(perm
:presql
)
320 # This command should be called after loading tester.tcl from within
321 # all test scripts that are incompatible with encryption codecs.
323 proc do_not_use_codec
{} {
324 set ::do_not_use_codec 1
327 unset -nocomplain do_not_use_codec
329 # Return true if the "reserved_bytes" integer on database files is non-zero.
331 proc nonzero_reserved_bytes
{} {
332 return [sqlite3
-has-codec
]
335 # Print a HELP message and exit
337 proc print_help_and_quit
{} {
339 --pause Wait
for user input before continuing
340 --soft-heap
-limit
=N Set the soft-heap-limit to N
341 --hard-heap
-limit
=N Set the hard-heap-limit to N
342 --maxerror=N Quit
after N errors
343 --verbose=(0|
1) Control the amount of output. Default '
1'
344 --output=FILE
set --verbose=2 and output to FILE. Implies
-q
345 -q Shorthand
for --verbose=0
351 # The following block only runs the first time this file is sourced. It
352 # does not run in slave interpreters (since the ::cmdlinearg array is
353 # populated before the test script is run in slave interpreters).
355 if {[info exists cmdlinearg
]==0} {
357 # Parse any options specified in the $argv array. This script accepts the
361 # --soft-heap-limit=NN
362 # --hard-heap-limit=NN
369 # --file-retry-delay=N
370 # --start=[$permutation:]$testfile
375 # --testdir=$dir Run tests in subdirectory $dir
378 set cmdlinearg
(soft-heap-limit
) 0
379 set cmdlinearg
(hard-heap-limit
) 0
380 set cmdlinearg
(maxerror
) 1000
381 set cmdlinearg
(malloctrace
) 0
382 set cmdlinearg
(backtrace
) 10
383 set cmdlinearg
(binarylog
) 0
384 set cmdlinearg
(soak
) 0
385 set cmdlinearg
(file-retries
) 0
386 set cmdlinearg
(file-retry-delay
) 0
387 set cmdlinearg
(start
) ""
388 set cmdlinearg
(match
) ""
389 set cmdlinearg
(verbose
) ""
390 set cmdlinearg
(output
) ""
391 set cmdlinearg
(testdir
) "testdir"
395 switch -regexp -- $a {
397 # Wait for user input before continuing. This is to give the user an
398 # opportunity to connect profiling tools to the process.
399 puts -nonewline "Press RETURN to begin..."
403 {^
-+soft-heap-limit
=.
+$} {
404 foreach {dummy cmdlinearg
(soft-heap-limit
)} [split $a =] break
406 {^
-+hard-heap-limit
=.
+$} {
407 foreach {dummy cmdlinearg
(hard-heap-limit
)} [split $a =] break
410 foreach {dummy cmdlinearg
(maxerror
)} [split $a =] break
412 {^
-+malloctrace
=.
+$} {
413 foreach {dummy cmdlinearg
(malloctrace
)} [split $a =] break
414 if {$cmdlinearg(malloctrace
)} {
415 if {0==$::sqlite_options(memdebug
)} {
416 set err
"Error: --malloctrace=1 requires an SQLITE_MEMDEBUG build"
420 sqlite3_memdebug_log start
424 foreach {dummy cmdlinearg
(backtrace
)} [split $a =] break
425 sqlite3_memdebug_backtrace
$cmdlinearg(backtrace
)
428 foreach {dummy cmdlinearg
(binarylog
)} [split $a =] break
429 set cmdlinearg
(binarylog
) [file normalize
$cmdlinearg(binarylog
)]
432 foreach {dummy cmdlinearg
(soak
)} [split $a =] break
433 set ::G(issoak
) $cmdlinearg(soak
)
435 {^
-+file-retries
=.
+$} {
436 foreach {dummy cmdlinearg
(file-retries
)} [split $a =] break
437 set ::G(file-retries
) $cmdlinearg(file-retries
)
439 {^
-+file-retry-delay
=.
+$} {
440 foreach {dummy cmdlinearg
(file-retry-delay
)} [split $a =] break
441 set ::G(file-retry-delay
) $cmdlinearg(file-retry-delay
)
444 foreach {dummy cmdlinearg
(start
)} [split $a =] break
446 set ::G(start
:file) $cmdlinearg(start
)
447 if {[regexp {(.
*):(.
*)} $cmdlinearg(start
) -> s.perm s.
file]} {
448 set ::G(start
:permutation
) ${s.perm
}
449 set ::G(start
:file) ${s.
file}
451 if {$::G(start
:file) == ""} {unset ::G(start
:file)}
454 foreach {dummy cmdlinearg
(match
)} [split $a =] break
456 set ::G(match
) $cmdlinearg(match
)
457 if {$::G(match
) == ""} {unset ::G(match
)}
461 foreach {dummy cmdlinearg
(output
)} [split $a =] break
462 set cmdlinearg
(output
) [file normalize
$cmdlinearg(output
)]
463 if {$cmdlinearg(verbose
)==""} {
464 set cmdlinearg
(verbose
) 2
468 foreach {dummy cmdlinearg
(verbose
)} [split $a =] break
469 if {$cmdlinearg(verbose
)=="file"} {
470 set cmdlinearg
(verbose
) 2
471 } elseif
{[string is boolean
-strict $cmdlinearg(verbose
)]==0} {
472 error "option --verbose= must be set to a boolean or to \"file\""
476 foreach {dummy cmdlinearg
(testdir
)} [split $a =] break
482 set cmdlinearg
(output
) test-out.txt
483 set cmdlinearg
(verbose
) 2
487 if {[file tail
$a]==$a} {
490 lappend leftover
[file normalize
$a]
496 set testdir
[file normalize
$testdir]
497 set cmdlinearg
(TESTFIXTURE_HOME
) [file dirname
[info nameofexec
]]
498 set cmdlinearg
(INFO_SCRIPT
) [file normalize
[info script
]]
499 set argv0
[file normalize
$argv0]
500 if {$cmdlinearg(testdir
)!=""} {
501 file mkdir
$cmdlinearg(testdir
)
502 cd $cmdlinearg(testdir
)
506 # Install the malloc layer used to inject OOM errors. And the 'automatic'
507 # extensions. This only needs to be done once for the process.
510 install_malloc_faultsim
1
512 autoinstall_test_functions
514 # If the --binarylog option was specified, create the logging VFS. This
515 # call installs the new VFS as the default for all SQLite connections.
517 if {$cmdlinearg(binarylog
)} {
518 vfslog new binarylog
{} vfslog.bin
521 # Set the backtrace depth, if malloc tracing is enabled.
523 if {$cmdlinearg(malloctrace
)} {
524 sqlite3_memdebug_backtrace
$cmdlinearg(backtrace
)
527 if {$cmdlinearg(output
)!=""} {
528 puts "Copying output to file $cmdlinearg(output)"
529 set ::G(output_fd
) [open $cmdlinearg(output
) w
]
530 fconfigure $::G(output_fd
) -buffering line
533 if {$cmdlinearg(verbose
)==""} {
534 set cmdlinearg
(verbose
) 1
537 if {[info commands vdbe_coverage
]!=""} {
542 # Update the soft-heap-limit each time this script is run. In that
543 # way if an individual test file changes the soft-heap-limit, it
544 # will be reset at the start of the next test file.
546 sqlite3_soft_heap_limit64
$cmdlinearg(soft-heap-limit
)
547 sqlite3_hard_heap_limit64
$cmdlinearg(hard-heap-limit
)
549 # Create a test database
554 forcedelete test.db-journal
555 forcedelete test.db-wal
557 set ::DB [sqlite3_connection_pointer db
]
558 if {[info exists
::SETUP_SQL]} {
564 # Abort early if this script has been run before.
566 if {[info exists TC
(count
)]} return
568 # Make sure memory statistics are enabled.
570 sqlite3_config_memstatus
1
572 # Initialize the test counters and set up commands to access them.
573 # Or, if this is a slave interpreter, set up aliases to write the
574 # counters in the parent interpreter.
576 if {0==[info exists
::SLAVE]} {
579 set TC
(fail_list
) [list]
580 set TC
(omit_list
) [list]
581 set TC
(warn_list
) [list]
583 proc set_test_counter
{counter args
} {
584 if {[llength $args]} {
585 set ::TC($counter) [lindex $args 0]
591 # Record the fact that a sequence of tests were omitted.
593 proc omit_test
{name reason
{append 1}} {
594 set omitList
[set_test_counter omit_list
]
596 lappend omitList
[list $name $reason]
598 set_test_counter omit_list
$omitList
601 # Record the fact that a test failed.
603 proc fail_test
{name
} {
604 set f
[set_test_counter fail_list
]
606 set_test_counter fail_list
$f
607 set_test_counter errors
[expr [set_test_counter errors
] + 1]
609 set nFail
[set_test_counter errors
]
610 if {$nFail>=$::cmdlinearg(maxerror
)} {
611 output2
"*** Giving up..."
616 # Remember a warning message to be displayed at the conclusion of all testing
618 proc warning
{msg
{append 1}} {
619 output2
"Warning: $msg"
620 set warnList
[set_test_counter warn_list
]
622 lappend warnList
$msg
624 set_test_counter warn_list
$warnList
628 # Increment the number of tests run
631 set_test_counter count
[expr [set_test_counter count
] + 1]
634 # Return true if --verbose=1 was specified on the command line. Otherwise,
638 return $::cmdlinearg(verbose
)
641 # Use the following commands instead of [puts] for test output within
642 # this file. Test scripts can still use regular [puts], which is directed
643 # to stdout and, if one is open, the --output file.
645 # output1: output that should be printed if --verbose=1 was specified.
646 # output2: output that should be printed unconditionally.
647 # output2_if_no_verbose: output that should be printed only if --verbose=0.
649 proc output1
{args
} {
652 uplevel output2
$args
654 uplevel puts [lrange $args 0 end-1
] $::G(output_fd
) [lrange $args end end
]
657 proc output2
{args
} {
658 set nArg
[llength $args]
661 proc output2_if_no_verbose
{args
} {
664 uplevel output2
$args
666 uplevel puts [lrange $args 0 end-1
] stdout
[lrange $args end end
]
670 # Override the [puts] command so that if no channel is explicitly
671 # specified the string is written to both stdout and to the file
672 # specified by "--output=", if any.
674 proc puts_override
{args
} {
675 set nArg
[llength $args]
676 if {$nArg==1 ||
($nArg==2 && [string first
[lindex $args 0] -nonewline]==0)} {
677 uplevel puts_original
$args
678 if {[info exists
::G(output_fd
)]} {
679 uplevel puts [lrange $args 0 end-1
] $::G(output_fd
) [lrange $args end end
]
682 # A channel was explicitly specified.
683 uplevel puts_original
$args
686 rename puts puts_original
687 proc puts {args
} { uplevel puts_override
$args }
690 # Invoke the do_test procedure to run a single test
692 # The $expected parameter is the expected result. The result is the return
693 # value from the last TCL command in $cmd.
695 # Normally, $expected must match exactly. But if $expected is of the form
696 # "/regexp/" then regular expression matching is used. If $expected is
697 # "~/regexp/" then the regular expression must NOT match. If $expected is
698 # of the form "#/value-list/" then each term in value-list must be numeric
699 # and must approximately match the corresponding numeric term in $result.
700 # Values must match within 10%. Or if the $expected term is A..B then the
701 # $result term must be in between A and B.
703 proc do_test
{name cmd expected
} {
704 global argv cmdlinearg
708 sqlite3_memdebug_settitle
$name
710 # if {[llength $argv]==0} {
714 # foreach pattern $argv {
715 # if {[string match $pattern $name]} {
722 if {[info exists
::G(perm
:prefix
)]} {
723 set name
"$::G(perm:prefix)$name"
727 output1
-nonewline $name...
730 if {![info exists
::G(match
)] ||
[string match
$::G(match
) $name]} {
731 if {[catch {uplevel #0 "$cmd;\n"} result]} {
732 output2_if_no_verbose
-nonewline $name...
733 output2
"\nError: $result"
736 if {[permutation
]=="maindbname"} {
737 set result
[string map
[list [string tolower ICECUBE
] main
] $result]
739 if {[regexp {^
[~
#]?/.*/$} $expected]} {
740 # "expected" is of the form "/PATTERN/" then the result if correct if
741 # regular expression PATTERN matches the result. "~/PATTERN/" means
742 # the regular expression must not match.
743 if {[string index
$expected 0]=="~"} {
744 set re
[string range
$expected 2 end-1
]
745 if {[string index
$re 0]=="*"} {
746 # If the regular expression begins with * then treat it as a glob instead
747 set ok
[string match
$re $result]
749 set re
[string map
{# {[-0-9.]+}} $re]
750 set ok
[regexp $re $result]
753 } elseif
{[string index
$expected 0]=="#"} {
754 # Numeric range value comparison. Each term of the $result is matched
755 # against one term of $expect. Both $result and $expected terms must be
756 # numeric. The values must match within 10%. Or if $expected is of the
757 # form A..B then the $result term must be between A and B.
758 set e2
[string range
$expected 2 end-1
]
759 foreach i
$result j
$e2 {
760 if {[regexp {^
(-?
\d
+)\.
\.
(-?
\d
)$} $j all A B
]} {
761 set ok
[expr {$i+0>=$A && $i+0<=$B}]
763 set ok
[expr {$i+0>=0.9*$j && $i+0<=1.1*$j}]
767 if {$ok && [llength $result]!=[llength $e2]} {set ok
0}
769 set re
[string range
$expected 1 end-1
]
770 if {[string index
$re 0]=="*"} {
771 # If the regular expression begins with * then treat it as a glob instead
772 set ok
[string match
$re $result]
774 set re
[string map
{# {[-0-9.]+}} $re]
775 set ok
[regexp $re $result]
778 } elseif
{[regexp {^~?
\*.
*\*$} $expected]} {
779 # "expected" is of the form "*GLOB*" then the result if correct if
780 # glob pattern GLOB matches the result. "~/GLOB/" means
781 # the glob must not match.
782 if {[string index
$expected 0]=="~"} {
783 set e
[string range
$expected 1 end
]
784 set ok
[expr {![string match
$e $result]}]
786 set ok
[string match
$expected $result]
789 set ok
[expr {[string compare
$result $expected]==0}]
791 set ok
[fpnum_compare
$result $expected]
795 # if {![info exists ::testprefix] || $::testprefix eq ""} {
796 # error "no test prefix"
799 output2
"! $name expected: \[$expected\]\n! $name got: \[$result\]"
807 omit_test
$name "pattern mismatch" 0
814 for {set i
0} {$i < [string length
$s]} {incr i
} {
815 if {$i > 0} {append r
" "}
816 append r
[format %02X
[scan [string index
$s $i] %c
]]
821 proc catchcmd
{db
{cmd
""}} {
823 set out
[open cmds.txt w
]
826 set line
"exec $CLI $db < cmds.txt"
827 set rc
[catch { eval $line } msg
]
830 proc catchsafecmd
{db
{cmd
""}} {
832 set out
[open cmds.txt w
]
835 set line
"exec $CLI -safe $db < cmds.txt"
836 set rc
[catch { eval $line } msg
]
840 proc catchcmdex
{db
{cmd
""}} {
842 set out
[open cmds.txt w
]
843 fconfigure $out -translation binary
844 puts -nonewline $out $cmd
846 set line
"exec -keepnewline -- $CLI $db < cmds.txt"
847 set chans
[list stdin stdout stderr
]
848 foreach chan
$chans {
850 set modes
($chan) [fconfigure $chan]
851 fconfigure $chan -translation binary -buffering none
854 set rc
[catch { eval $line } msg
]
855 foreach chan
$chans {
857 eval fconfigure [list $chan] $modes($chan)
860 # puts [dumpbytes $msg]
864 proc filepath_normalize
{p
} {
865 # test cases should be written to assume "unix"-like file paths
866 if {$::tcl_platform(platform
)!="unix"} {
867 string map
[list \\ / \{/ / .db
\} .db
] \
868 [regsub -nocase -all {[a-z
]:[/\\]+} $p {/}]
873 proc do_filepath_test
{name cmd expected
} {
874 uplevel [list do_test
$name [
875 subst -nocommands { filepath_normalize
[ $cmd ] }
876 ] [filepath_normalize
$expected]]
879 proc realnum_normalize
{r
} {
880 # different TCL versions display floating point values differently.
881 string map
{1.
#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}]
883 proc do_realnum_test
{name cmd expected
} {
884 uplevel [list do_test
$name [
885 subst -nocommands { realnum_normalize
[ $cmd ] }
886 ] [realnum_normalize
$expected]]
889 proc fix_testname
{varname
} {
890 upvar $varname testname
891 if {[info exists
::testprefix]
892 && [string is digit
[string range
$testname 0 0]]
894 set testname
"${::testprefix}-$testname"
898 proc normalize_list
{L
} {
900 foreach l
$L {lappend L2
$l}
904 # Run SQL and verify that the number of "vmsteps" required is greater
905 # than or less than some constant.
907 proc do_vmstep_test
{tn sql nstep
{res
{}}} {
908 uplevel [list do_execsql_test
$tn.0 $sql $res]
910 set vmstep
[db status vmstep
]
911 if {[string range
$nstep 0 0]=="+"} {
912 set body
"if {$vmstep<$nstep} {
913 error \"got $vmstep, expected more than [string range $nstep 1 end]\"
916 set body
"if {$vmstep>$nstep} {
917 error \"got $vmstep, expected less than $nstep\"
921 # set name "$tn.vmstep=$vmstep,expect=$nstep"
923 uplevel [list do_test
$name $body {}]
929 # do_execsql_test TESTNAME SQL ?RES?
930 # do_execsql_test -db DB TESTNAME SQL ?RES?
932 proc do_execsql_test
{args
} {
934 if {[lindex $args 0]=="-db"} {
935 set db
[lindex $args 1]
936 set args
[lrange $args 2 end
]
939 if {[llength $args]==2} {
940 foreach {testname sql
} $args {}
942 } elseif
{[llength $args]==3} {
943 foreach {testname sql result
} $args {}
945 # With some versions of Tcl on windows, if $result is all whitespace but
946 # contains some CR/LF characters, the [list {*}$result] below returns a
947 # copy of $result instead of a zero length string. Not clear exactly why
948 # this is. The following is a workaround.
949 if {[llength $result]==0} { set result
"" }
952 wrong
# args: should be "do_execsql_test ?-db DB? testname sql ?result?"
956 fix_testname testname
960 [list "execsql {$sql} $db"] \
961 [list [list {*}$result]]
964 proc do_catchsql_test
{testname sql result
} {
965 fix_testname testname
966 uplevel do_test
[list $testname] [list "catchsql {$sql}"] [list $result]
968 proc do_timed_execsql_test
{testname sql
{result
{}}} {
969 fix_testname testname
970 uplevel do_test
[list $testname] [list "execsql_timed {$sql}"]\
971 [list [list {*}$result]]
974 # Run an EXPLAIN QUERY PLAN $sql in database "db". Then rewrite the output
975 # as an ASCII-art graph and return a string that is that graph.
977 # Hexadecimal literals in the output text are converted into "xxxxxx" since those
978 # literals are pointer values that might very from one run of the test to the
979 # next, yet we want the output to be consistent.
981 proc query_plan_graph
{sql
} {
982 db
eval "EXPLAIN QUERY PLAN $sql" {
984 lappend cx
($parent) $id
986 set a
"\n QUERY PLAN\n"
987 append a
[append_graph
" " dx cx
0]
988 regsub -all {SUBQUERY
0x
[A-F0-9
]+\y
} $a {SUBQUERY xxxxxx
} a
989 regsub -all {(MATERIALIZE|CO-ROUTINE|SUBQUERY
) \d
+\y
} $a {\1 xxxxxx
} a
990 regsub -all {\((join|subquery
)-\d
+\)} $a {(\1-xxxxxx
)} a
994 # Helper routine for [query_plan_graph SQL]:
996 # Output rows of the graph that are children of $level.
998 # prefix: Prepend to every output line
1000 # dxname: Name of an array variable that stores text describe
1001 # The description for $id is $dx($id)
1003 # cxname: Name of an array variable holding children of item.
1004 # Children of $id are $cx($id)
1006 # level: Render all lines that are children of $level
1008 proc append_graph
{prefix dxname cxname level
} {
1009 upvar $dxname dx
$cxname cx
1013 for {set i
0} {$i<$n} {incr i
} {
1014 set id
[lindex $x $i]
1022 append a
$prefix$p1$dx($id)\n
1023 if {[info exists cx
($id)]} {
1024 append a
[append_graph
"$prefix$p2" dx cx
$id]
1030 # Do an EXPLAIN QUERY PLAN test on input $sql with expected results $res
1032 # If $res begins with a "\s+QUERY PLAN\n" then it is assumed to be the
1033 # complete graph which must match the output of [query_plan_graph $sql]
1036 # If $res does not begin with "\s+QUERY PLAN\n" then take it is a string
1037 # that must be found somewhere in the query plan output.
1039 proc do_eqp_test
{name sql res
} {
1040 if {[regexp {^
\s
+QUERY PLAN
\n} $res]} {
1042 set query_plan
[query_plan_graph
$sql]
1044 if {[list {*}$query_plan]==[list {*}$res]} {
1045 uplevel [list do_test
$name [list set {} ok
] ok
]
1048 do_test
$name [list query_plan_graph
$sql] $res
1052 if {[string index
$res 0]!="/"} {
1055 uplevel do_execsql_test
$name [list "EXPLAIN QUERY PLAN $sql"] [list $res]
1059 # Do both an eqp_test and an execsql_test on the same SQL.
1061 proc do_eqp_execsql_test
{name sql res1 res2
} {
1062 if {[regexp {^
\s
+QUERY PLAN
\n} $res1]} {
1064 set query_plan
[query_plan_graph
$sql]
1066 if {[list {*}$query_plan]==[list {*}$res1]} {
1067 uplevel [list do_test
${name
}a
[list set {} ok
] ok
]
1070 do_test
${name
}a
[list query_plan_graph
$sql] $res1
1074 if {[string index
$res 0]!="/"} {
1075 set res1
"/*$res1*/"
1077 uplevel do_execsql_test
${name
}a
[list "EXPLAIN QUERY PLAN $sql"] [list $res1]
1079 uplevel do_execsql_test
${name
}b
[list $sql] [list $res2]
1083 #-------------------------------------------------------------------------
1084 # Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST
1086 # Where switches are:
1088 # -errorformat FMTSTRING
1094 proc do_select_tests
{prefix args
} {
1096 set testlist
[lindex $args end
]
1097 set switches
[lrange $args 0 end-1
]
1104 for {set i
0} {$i < [llength $switches]} {incr i
} {
1105 set s
[lindex $switches $i]
1106 set n
[string length
$s]
1107 if {$n>=2 && [string equal
-length $n $s "-query"]} {
1108 set tclquery
[list execsql
[lindex $switches [incr i
]]]
1109 } elseif
{$n>=2 && [string equal
-length $n $s "-tclquery"]} {
1110 set tclquery
[lindex $switches [incr i
]]
1111 } elseif
{$n>=2 && [string equal
-length $n $s "-errorformat"]} {
1112 set errfmt
[lindex $switches [incr i
]]
1113 } elseif
{$n>=2 && [string equal
-length $n $s "-repair"]} {
1114 set repair
[lindex $switches [incr i
]]
1115 } elseif
{$n>=2 && [string equal
-length $n $s "-count"]} {
1118 error "unknown switch: $s"
1122 if {$countonly && $errfmt!=""} {
1123 error "Cannot use -count and -errorformat together"
1125 set nTestlist
[llength $testlist]
1126 if {$nTestlist%3 ||
$nTestlist==0 } {
1127 error "SELECT test list contains [llength $testlist] elements"
1131 foreach {tn sql res
} $testlist {
1132 if {$tclquery != ""} {
1134 uplevel do_test
${prefix
}.
$tn [list $tclquery] [list [list {*}$res]]
1135 } elseif
{$countonly} {
1137 db
eval $sql {incr nRow
}
1138 uplevel do_test
${prefix
}.
$tn [list [list set {} $nRow]] [list $res]
1139 } elseif
{$errfmt==""} {
1140 uplevel do_execsql_test
${prefix
}.
${tn
} [list $sql] [list [list {*}$res]]
1142 set res
[list 1 [string trim
[format $errfmt {*}$res]]]
1143 uplevel do_catchsql_test
${prefix
}.
${tn
} [list $sql] [list $res]
1150 proc delete_all_data
{} {
1151 db
eval {SELECT tbl_name AS t FROM sqlite_master WHERE type
= 'table'
} {
1152 db
eval "DELETE FROM '[string map {' ''} $t]'"
1156 # Run an SQL script.
1157 # Return the number of microseconds per statement.
1159 proc speed_trial
{name numstmt units sql
} {
1160 output2
-nonewline [format {%-21.21s
} $name...
]
1162 set speed
[time {sqlite3_exec_nr db
$sql}]
1163 set tm
[lindex $speed 0]
1165 set rate
[format %20s
"many"]
1167 set rate
[format %20.5f
[expr {1000000.0*$numstmt/$tm}]]
1170 output2
[format {%12d uS
%s
%s
} $tm $rate $u2]
1172 set total_time
[expr {$total_time+$tm}]
1173 lappend ::speed_trial_times $name $tm
1175 proc speed_trial_tcl
{name numstmt units script
} {
1176 output2
-nonewline [format {%-21.21s
} $name...
]
1178 set speed
[time {eval $script}]
1179 set tm
[lindex $speed 0]
1181 set rate
[format %20s
"many"]
1183 set rate
[format %20.5f
[expr {1000000.0*$numstmt/$tm}]]
1186 output2
[format {%12d uS
%s
%s
} $tm $rate $u2]
1188 set total_time
[expr {$total_time+$tm}]
1189 lappend ::speed_trial_times $name $tm
1191 proc speed_trial_init
{name
} {
1194 set ::speed_trial_times [list]
1195 sqlite3 versdb
:memory:
1196 set vers
[versdb one
{SELECT sqlite_source_id
()}]
1198 output2
"SQLite $vers"
1200 proc speed_trial_summary
{name
} {
1202 output2
[format {%-21.21s
%12d uS TOTAL
} $name $total_time]
1205 sqlite3 versdb
:memory:
1206 set vers
[lindex [versdb one
{SELECT sqlite_source_id
()}] 0]
1208 output2
"CREATE TABLE IF NOT EXISTS time(version, script, test, us);"
1209 foreach {test us
} $::speed_trial_times {
1210 output2
"INSERT INTO time VALUES('$vers', '$name', '$test', $us);"
1215 # Clear out left-over configuration setup from the end of a test
1217 proc finish_test_precleanup
{} {
1221 catch {unregister_devsim
}
1222 catch {unregister_jt_vfs
}
1223 catch {unregister_demovfs
}
1226 # Run this routine last
1228 proc finish_test
{} {
1230 finish_test_precleanup
1231 if {[llength $argv]>0} {
1232 # If additional test scripts are specified on the command-line,
1233 # run them also, before quitting.
1234 proc finish_test
{} {
1235 finish_test_precleanup
1238 foreach extra
$argv {
1239 puts "Running \"$extra\""
1240 db_delete_and_reopen
1241 uplevel #0 source $extra
1245 if {0==[info exists
::SLAVE]} { finalize_testing
}
1247 proc finalize_testing
{} {
1248 global sqlite_open_file_count
1250 set omitList
[set_test_counter omit_list
]
1258 # sqlite3_clear_tsd_memdebug
1260 sqlite3_reset_auto_extension
1262 sqlite3_soft_heap_limit64
0
1263 sqlite3_hard_heap_limit64
0
1264 set nTest
[incr_ntest
]
1265 set nErr
[set_test_counter errors
]
1268 if {[file readable known-problems.txt
]} {
1269 set fd
[open known-problems.txt
]
1270 set content
[read $fd]
1272 foreach x
$content {set known_error
($x) 1}
1273 foreach x
[set_test_counter fail_list
] {
1274 if {[info exists known_error
($x)]} {incr nKnown
}
1278 output2
"[expr {$nErr-$nKnown}] new errors and $nKnown known errors\
1279 out of $nTest tests"
1282 if {[catch {exec hostname
} hname
]==0} {
1283 regsub {\.local
$} $hname {} hname
1284 set cpuinfo
[string trim
$hname]
1286 append cpuinfo
" $::tcl_platform(os)"
1287 append cpuinfo
" [expr {$::tcl_platform(pointerSize)*8}]-bit"
1288 if {[string match big
* $::tcl_platform(byteOrder
)]} {
1289 append cpuinfo
" [string map {E -e} $::tcl_platform(byteOrder)]"
1291 output2
"SQLite [sqlite3 -sourceid]"
1292 output2
"$nErr errors out of $nTest tests on $cpuinfo"
1294 if {$nErr>$nKnown} {
1295 output2
-nonewline "!Failures on these tests:"
1296 foreach x
[set_test_counter fail_list
] {
1297 if {![info exists known_error
($x)]} {output2
-nonewline " $x"}
1301 foreach warning
[set_test_counter warn_list
] {
1302 output2
"Warning: $warning"
1305 if {[llength $omitList]>0} {
1306 output2
"Omitted test cases:"
1308 foreach {rec
} [lsort $omitList] {
1309 if {$rec==$prec} continue
1311 output2
[format {.
%-12s %s
} [lindex $rec 0] [lindex $rec 1]]
1314 if {$nErr>0 && ![working_64bit_int
]} {
1315 output2
"******************************************************************"
1316 output2
"N.B.: The version of TCL that you used to build this test harness"
1317 output2
"is defective in that it does not support 64-bit integers. Some or"
1318 output2
"all of the test failures above might be a result from this defect"
1319 output2
"in your TCL build."
1320 output2
"******************************************************************"
1322 if {$::cmdlinearg(binarylog
)} {
1323 vfslog finalize binarylog
1325 if {[info exists
::run_thread_tests_called]==0} {
1326 if {$sqlite_open_file_count} {
1327 output2
"$sqlite_open_file_count files were left open"
1331 if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT
0] 1]>0 ||
1332 [sqlite3_memory_used
]>0} {
1333 output2
"Unfreed memory: [sqlite3_memory_used] bytes in\
1334 [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations"
1336 ifcapable mem5||
(mem3
&&debug
) {
1337 output2
"Writing unfreed memory log to \"./memleak.txt\""
1338 sqlite3_memdebug_dump .
/memleak.txt
1341 output2
"All memory allocations freed - no leaks"
1343 sqlite3_memdebug_dump .
/memusage.txt
1347 output2
"Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
1348 output2
"Current memory usage: [sqlite3_memory_highwater] bytes"
1349 if {[info commands sqlite3_memdebug_malloc_count
] ne
""} {
1350 output2
"Number of malloc() : [sqlite3_memdebug_malloc_count] calls"
1352 if {$::cmdlinearg(malloctrace
)} {
1353 output2
"Writing mallocs.tcl..."
1354 memdebug_log_sql mallocs.tcl
1355 sqlite3_memdebug_log stop
1356 sqlite3_memdebug_log clear
1357 if {[sqlite3_memory_used
]>0} {
1358 output2
"Writing leaks.tcl..."
1359 sqlite3_memdebug_log sync
1360 memdebug_log_sql leaks.tcl
1363 if {[info commands vdbe_coverage
]!=""} {
1364 vdbe_coverage_report
1366 foreach f
[glob -nocomplain test.db-
*-journal] {
1369 foreach f
[glob -nocomplain test.db-mj
*] {
1372 exit [expr {$nErr>0}]
1375 proc vdbe_coverage_report
{} {
1376 puts "Writing vdbe coverage report to vdbe_coverage.txt"
1379 if {[file exists ..
/sqlite3.c
]} {
1380 set fd
[open ..
/sqlite3.c
]
1382 while { ![eof $fd] } {
1385 if {[regexp {^
/\** Begin
file (.
*\.c
) \**/} $line -> file]} {
1386 lappend lSrc
[list $iLine $file]
1391 set fd
[open vdbe_coverage.txt w
]
1392 foreach miss
[vdbe_coverage report
] {
1393 foreach {line branch never
} $miss {}
1395 while {[llength $lSrc]>0 && [lindex $lSrc 0 0] < $line} {
1396 set nextfile
[lindex $lSrc 0 1]
1397 set lSrc
[lrange $lSrc 1 end
]
1399 if {$nextfile != ""} {
1401 puts $fd "### $nextfile ###"
1403 puts $fd "Vdbe branch $line: never $never (path $branch)"
1408 # Display memory statistics for analysis and debugging purposes.
1410 proc show_memstats
{} {
1411 set x
[sqlite3_status SQLITE_STATUS_MEMORY_USED
0]
1412 set y
[sqlite3_status SQLITE_STATUS_MALLOC_SIZE
0]
1413 set val
[format {now
%10d max
%10d max-size
%10d
} \
1414 [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1415 output1
"Memory used: $val"
1416 set x
[sqlite3_status SQLITE_STATUS_MALLOC_COUNT
0]
1417 set val
[format {now
%10d max
%10d
} [lindex $x 1] [lindex $x 2]]
1418 output1
"Allocation count: $val"
1419 set x
[sqlite3_status SQLITE_STATUS_PAGECACHE_USED
0]
1420 set y
[sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE
0]
1421 set val
[format {now
%10d max
%10d max-size
%10d
} \
1422 [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1423 output1
"Page-cache used: $val"
1424 set x
[sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW
0]
1425 set val
[format {now
%10d max
%10d
} [lindex $x 1] [lindex $x 2]]
1426 output1
"Page-cache overflow: $val"
1427 ifcapable yytrackmaxstackdepth
{
1428 set x
[sqlite3_status SQLITE_STATUS_PARSER_STACK
0]
1429 set val
[format { max
%10d
} [lindex $x 2]]
1430 output2
"Parser stack depth: $val"
1434 # A procedure to execute SQL
1436 proc execsql
{sql
{db db
}} {
1438 uplevel [list $db eval $sql]
1440 proc execsql_timed
{sql
{db db
}} {
1442 set x
[uplevel [list $db eval $sql]]
1444 set tm
[lindex $tm 0]
1445 output1
-nonewline " ([expr {$tm*0.001}]ms) "
1449 # Execute SQL and catch exceptions.
1451 proc catchsql
{sql
{db db
}} {
1453 set r
[catch [list uplevel [list $db eval $sql]] msg
]
1458 # Do an VDBE code dump on the SQL given
1460 proc explain
{sql
{db db
}} {
1462 output2
"addr opcode p1 p2 p3 p4 p5 #"
1463 output2
"---- ------------ ------ ------ ------ --------------- -- -"
1464 $db eval "explain $sql" {} {
1465 output2
[format {%-4d %-12.12s
%-6d %-6d %-6d % -17s %s
%s
} \
1466 $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
1471 proc explain_i
{sql
{db db
}} {
1473 output2
"addr opcode p1 p2 p3 p4 p5 #"
1474 output2
"---- ------------ ------ ------ ------ ---------------- -- -"
1477 # Set up colors for the different opcodes. Scheme is as follows:
1479 # Red: Opcodes that write to a b-tree.
1480 # Blue: Opcodes that reposition or seek a cursor.
1481 # Green: The ResultRow opcode.
1483 if { [catch {fconfigure stdout
-mode}]==0 } {
1484 set R
"\033\[31;1m" ;# Red fg
1485 set G
"\033\[32;1m" ;# Green fg
1486 set B
"\033\[34;1m" ;# Red fg
1487 set D
"\033\[39;0m" ;# Default fg
1495 Seek SeekGE SeekGT SeekLE SeekLT NotFound Last Rewind
1496 NoConflict Next Prev VNext VPrev VFilter
1497 SorterSort SorterNext NextIfOpen
1499 set color
($opcode) $B
1501 foreach opcode
{ResultRow
} {
1502 set color
($opcode) $G
1504 foreach opcode
{IdxInsert Insert Delete IdxDelete
} {
1505 set color
($opcode) $R
1509 $db eval "explain $sql" {} {
1511 set op
($addr) $opcode
1513 if {$opcode == "Goto" && ($bSeenGoto==0 ||
($p2 > $addr+10))} {
1514 set linebreak
($p2) 1
1518 if {$opcode=="Once"} {
1519 for {set i
$addr} {$i<$p2} {incr i
} {
1524 if {$opcode=="Next" ||
$opcode=="Prev"
1525 ||
$opcode=="VNext" ||
$opcode=="VPrev"
1526 ||
$opcode=="SorterNext" ||
$opcode=="NextIfOpen"
1528 for {set i
$p2} {$i<$addr} {incr i
} {
1533 if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} {
1534 for {set i
[expr $p2+1]} {$i<$addr} {incr i
} {
1539 if {$opcode == "Halt" && $comment == "End of coroutine"} {
1540 set linebreak
([expr $addr+1]) 1
1544 $db eval "explain $sql" {} {
1545 if {[info exists linebreak
($addr)]} {
1548 set I
[string repeat
" " $x($addr)]
1550 if {[info exists star
($addr)]} {
1551 set ii
[expr $x($star($addr))]
1553 set I
[string replace
$I $ii $ii *]
1557 catch { set col
$color($opcode) }
1559 output2
[format {%-4d %s
%s
%-12.12s
%s
%-6d %-6d %-6d % -17s %s
%s
} \
1560 $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment
1563 output2
"---- ------------ ------ ------ ------ ---------------- -- -"
1566 proc execsql_pp
{sql
{db db
}} {
1570 set nCol
[llength $A(*)]
1572 set aWidth
($c) [string length
$c]
1577 set n
[string length
$A($c)]
1578 if {$n > $aWidth($c)} {
1586 foreach e
[array names aWidth
] { incr nTotal
$aWidth($e) }
1587 incr nTotal
[expr ($nCol-1) * 3]
1592 lappend fmt
"% -$aWidth($c)s"
1594 set fmt
"| [join $fmt { | }] |"
1596 puts [string repeat
- $nTotal]
1597 for {set i
0} {$i < [llength $data]} {incr i
$nCol} {
1598 set vals
[lrange $data $i [expr $i+$nCol-1]]
1599 puts [format $fmt {*}$vals]
1600 if {$i==0} { puts [string repeat
- $nTotal] }
1602 puts [string repeat
- $nTotal]
1607 # Show the VDBE program for an SQL statement but omit the Trace
1608 # opcode at the beginning. This procedure can be used to prove
1609 # that different SQL statements generate exactly the same VDBE code.
1611 proc explain_no_trace
{sql
} {
1612 set tr
[db
eval "EXPLAIN $sql"]
1613 return [lrange $tr 7 end
]
1616 # Another procedure to execute SQL. This one includes the field
1617 # names in the returned list.
1619 proc execsql2
{sql
} {
1622 foreach f
$data(*) {
1623 lappend result
$f $data($f)
1629 # Use a temporary in-memory database to execute SQL statements
1631 proc memdbsql
{sql
} {
1632 sqlite3 memdb
:memory:
1633 set result
[memdb
eval $sql]
1638 # Use the non-callback API to execute multiple SQL statements
1640 proc stepsql
{dbptr sql
} {
1641 set sql
[string trim
$sql]
1643 while {[string length
$sql]>0} {
1644 if {[catch {sqlite3_prepare
$dbptr $sql -1 sqltail
} vm
]} {
1647 set sql
[string trim
$sqltail]
1648 # while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
1649 # foreach v $VAL {lappend r $v}
1651 while {[sqlite3_step
$vm]=="SQLITE_ROW"} {
1652 for {set i
0} {$i<[sqlite3_data_count
$vm]} {incr i
} {
1653 lappend r
[sqlite3_column_text
$vm $i]
1656 if {[catch {sqlite3_finalize
$vm} errmsg
]} {
1657 return [list 1 $errmsg]
1663 # Do an integrity check of the entire database
1665 proc integrity_check
{name
{db db
}} {
1666 ifcapable integrityck
{
1667 do_test
$name [list execsql
{PRAGMA integrity_check
} $db] {ok
}
1671 # Check the extended error code
1673 proc verify_ex_errcode
{name expected
{db db
}} {
1674 do_test
$name [list sqlite3_extended_errcode
$db] $expected
1678 # Return true if the SQL statement passed as the second argument uses a
1679 # statement transaction.
1681 proc sql_uses_stmt
{db sql
} {
1682 set stmt
[sqlite3_prepare
$db $sql -1 dummy
]
1683 set uses
[uses_stmt_journal
$stmt]
1684 sqlite3_finalize
$stmt
1688 proc fix_ifcapable_expr
{expr} {
1691 for {set i
0} {$i < [string length
$expr]} {incr i
} {
1692 set char
[string range
$expr $i $i]
1693 set newstate
[expr {[string is alnum
$char] ||
$char eq
"_"}]
1694 if {$newstate && !$state} {
1695 append ret
{$::sqlite_options(}
1697 if {!$newstate && $state} {
1703 if {$state} {append ret
)}
1707 # Returns non-zero if the capabilities are present; zero otherwise.
1709 proc capable
{expr} {
1710 set e
[fix_ifcapable_expr
$expr]; return [expr ($e)]
1713 # Evaluate a boolean expression of capabilities. If true, execute the
1714 # code. Omit the code if false.
1716 proc ifcapable
{expr code
{else ""} {elsecode
""}} {
1717 #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
1718 set e2
[fix_ifcapable_expr
$expr]
1720 set c
[catch {uplevel 1 $code} r
]
1722 set c
[catch {uplevel 1 $elsecode} r
]
1727 # This proc execs a seperate process that crashes midway through executing
1728 # the SQL script $sql on database test.db.
1730 # The crash occurs during a sync() of file $crashfile. When the crash
1731 # occurs a random subset of all unsynced writes made by the process are
1732 # written into the files on disk. Argument $crashdelay indicates the
1733 # number of file syncs to wait before crashing.
1735 # The return value is a list of two elements. The first element is a
1736 # boolean, indicating whether or not the process actually crashed or
1737 # reported some other error. The second element in the returned list is the
1738 # error message. This is "child process exited abnormally" if the crash
1741 # crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
1743 proc crashsql
{args
} {
1748 set opendb
{ sqlite3 db test.db
-vfs crash
}
1753 set sql
[lindex $args end
]
1755 for {set ii
0} {$ii < [llength $args]-1} {incr ii
2} {
1756 set z
[lindex $args $ii]
1757 set n
[string length
$z]
1758 set z2
[lindex $args [expr $ii+1]]
1760 if {$n>1 && [string first
$z -delay]==0} {set crashdelay
$z2} \
1761 elseif
{$n>1 && [string first
$z -opendb]==0} {set opendb
$z2} \
1762 elseif
{$n>1 && [string first
$z -seed]==0} {set prngseed
$z2} \
1763 elseif
{$n>1 && [string first
$z -file]==0} {set crashfile
$z2} \
1764 elseif
{$n>1 && [string first
$z -tclbody]==0} {set tclbody
$z2} \
1765 elseif
{$n>1 && [string first
$z -blocksize]==0} {set blocksize
"-s $z2" } \
1766 elseif
{$n>1 && [string first
$z -characteristics]==0} {set dc
"-c {$z2}" }\
1767 elseif
{$n>1 && [string first
$z -dfltvfs]==0} {set dfltvfs
$z2 }\
1768 else { error "Unrecognized option: $z" }
1771 if {$crashfile eq
""} {
1772 error "Compulsory option -file missing"
1775 # $crashfile gets compared to the native filename in
1776 # cfSync(), which can be different then what TCL uses by
1777 # default, so here we force it to the "nativename" format.
1778 set cfile
[string map
{\\ \\\\} [file nativename
[file join [get_pwd
] $crashfile]]]
1780 set f
[open crash.tcl w
]
1781 puts $f "sqlite3_initialize ; sqlite3_shutdown"
1782 puts $f "catch { install_malloc_faultsim 1 }"
1783 puts $f "sqlite3_crash_enable 1 $dfltvfs"
1784 puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
1785 puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
1786 puts $f "autoinstall_test_functions"
1788 # This block sets the cache size of the main database to 10
1789 # pages. This is done in case the build is configured to omit
1790 # "PRAGMA cache_size".
1793 puts $f {db
eval {SELECT
* FROM sqlite_master
;}}
1794 puts $f {set bt
[btree_from_db db
]}
1795 puts $f {btree_set_cache_size
$bt 10}
1799 set seed
[expr {$prngseed%10007+1}]
1801 puts $f "db eval {SELECT randomblob($seed)}"
1804 if {[string length
$tclbody]>0} {
1807 if {[string length
$sql]>0} {
1814 exec [info nameofexec
] crash.tcl
>@stdout
2>@stdout
1817 # Windows/ActiveState TCL returns a slightly different
1818 # error message. We map that to the expected message
1819 # so that we don't have to change all of the test
1821 if {$::tcl_platform(platform
)=="windows"} {
1822 if {$msg=="child killed: unknown signal"} {
1823 set msg
"child process exited abnormally"
1826 if {$r && [string match
{*ERROR
: LeakSanitizer
*} $msg]} {
1827 set msg
"child process exited abnormally"
1833 # crash_on_write ?-devchar DEVCHAR? CRASHDELAY SQL
1835 proc crash_on_write
{args
} {
1837 set nArg
[llength $args]
1838 if {$nArg<2 ||
$nArg%2} {
1839 error "bad args: $args"
1841 set zSql
[lindex $args end
]
1842 set nDelay
[lindex $args end-1
]
1845 for {set ii
0} {$ii < $nArg-2} {incr ii
2} {
1846 set opt
[lindex $args $ii]
1847 switch -- [lindex $args $ii] {
1849 set devchar
[lindex $args [expr $ii+1]]
1852 default { error "unrecognized option: $opt" }
1856 set f
[open crash.tcl w
]
1857 puts $f "sqlite3_crash_on_write $nDelay"
1858 puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
1859 puts $f "sqlite3 db test.db -vfs writecrash"
1860 puts $f "db eval {$zSql}"
1865 exec [info nameofexec
] crash.tcl
>@stdout
1868 # Windows/ActiveState TCL returns a slightly different
1869 # error message. We map that to the expected message
1870 # so that we don't have to change all of the test
1872 if {$::tcl_platform(platform
)=="windows"} {
1873 if {$msg=="child killed: unknown signal"} {
1874 set msg
"child process exited abnormally"
1881 proc run_ioerr_prep
{} {
1882 set ::sqlite_io_error_pending 0
1885 catch {forcedelete test.db
}
1886 catch {forcedelete test.db-journal
}
1887 catch {forcedelete test2.db
}
1888 catch {forcedelete test2.db-journal
}
1889 set ::DB [sqlite3 db test.db
; sqlite3_connection_pointer db
]
1890 sqlite3_extended_result_codes
$::DB $::ioerropts(-erc)
1891 if {[info exists
::ioerropts(-tclprep)]} {
1892 eval $::ioerropts(-tclprep)
1894 if {[info exists
::ioerropts(-sqlprep)]} {
1895 execsql
$::ioerropts(-sqlprep)
1900 # Usage: do_ioerr_test <test number> <options...>
1902 # This proc is used to implement test cases that check that IO errors
1903 # are correctly handled. The first argument, <test number>, is an integer
1904 # used to name the tests executed by this proc. Options are as follows:
1906 # -tclprep TCL script to run to prepare test.
1907 # -sqlprep SQL script to run to prepare test.
1908 # -tclbody TCL script to run with IO error simulation.
1909 # -sqlbody TCL script to run with IO error simulation.
1910 # -exclude List of 'N' values not to test.
1911 # -erc Use extended result codes
1912 # -persist Make simulated I/O errors persistent
1913 # -start Value of 'N' to begin with (default 1)
1915 # -cksum Boolean. If true, test that the database does
1916 # not change during the execution of the test case.
1918 proc do_ioerr_test
{testname args
} {
1920 set ::ioerropts(-start) 1
1921 set ::ioerropts(-cksum) 0
1922 set ::ioerropts(-erc) 0
1923 set ::ioerropts(-count) 100000000
1924 set ::ioerropts(-persist) 1
1925 set ::ioerropts(-ckrefcount) 0
1926 set ::ioerropts(-restoreprng) 1
1927 array set ::ioerropts $args
1929 # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
1930 # a couple of obscure IO errors that do not return them.
1931 set ::ioerropts(-erc) 0
1933 # Create a single TCL script from the TCL and SQL specified
1934 # as the body of the test.
1935 set ::ioerrorbody {}
1936 if {[info exists
::ioerropts(-tclbody)]} {
1937 append ::ioerrorbody "$::ioerropts(-tclbody)\n"
1939 if {[info exists
::ioerropts(-sqlbody)]} {
1940 append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
1944 if {$::ioerropts(-cksum)} {
1947 set ::goodcksum [cksum
]
1952 for {set n
$::ioerropts(-start)} {$::go} {incr n
} {
1954 incr ::ioerropts(-count) -1
1955 if {$::ioerropts(-count)<0} break
1957 # Skip this IO error if it was specified with the "-exclude" option.
1958 if {[info exists
::ioerropts(-exclude)]} {
1959 if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
1961 if {$::ioerropts(-restoreprng)} {
1965 # Delete the files test.db and test2.db, then execute the TCL and
1966 # SQL (in that order) to prepare for the test case.
1967 do_test
$testname.
$n.1 {
1971 # Read the 'checksum' of the database.
1972 if {$::ioerropts(-cksum)} {
1973 set ::checksum [cksum
]
1976 # Set the Nth IO error to fail.
1977 do_test
$testname.
$n.2 [subst {
1978 set ::sqlite_io_error_persist $::ioerropts(-persist)
1979 set ::sqlite_io_error_pending $n
1982 # Execute the TCL script created for the body of this test. If
1983 # at least N IO operations performed by SQLite as a result of
1984 # the script, the Nth will fail.
1985 do_test
$testname.
$n.3 {
1986 set ::sqlite_io_error_hit 0
1987 set ::sqlite_io_error_hardhit 0
1988 set r
[catch $::ioerrorbody msg
]
1990 if {[info commands db
]!=""} {
1991 set rc
[sqlite3_errcode db
]
1992 if {$::ioerropts(-erc)} {
1993 # If we are in extended result code mode, make sure all of the
1994 # IOERRs we get back really do have their extended code values.
1995 # If an extended result code is returned, the sqlite3_errcode
1996 # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn
1997 # where nnnn is a number
1998 if {[regexp {^SQLITE_IOERR
} $rc] && ![regexp {IOERR
\+\d
} $rc]} {
2002 # If we are not in extended result code mode, make sure no
2003 # extended error codes are returned.
2004 if {[regexp {\+\d
} $rc]} {
2009 # The test repeats as long as $::go is non-zero. $::go starts out
2010 # as 1. When a test runs to completion without hitting an I/O
2011 # error, that means there is no point in continuing with this test
2012 # case so set $::go to zero.
2014 if {$::sqlite_io_error_pending>0} {
2017 set ::sqlite_io_error_pending 0
2022 set s
[expr $::sqlite_io_error_hit==0]
2023 if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
2026 set ::sqlite_io_error_hit 0
2028 # One of two things must have happened. either
2029 # 1. We never hit the IO error and the SQL returned OK
2030 # 2. An IO error was hit and the SQL failed
2032 #puts "s=$s r=$r q=$q"
2033 expr { ($s && !$r && !$q) ||
(!$s && $r && $q) }
2036 set ::sqlite_io_error_hit 0
2037 set ::sqlite_io_error_pending 0
2039 # Check that no page references were leaked. There should be
2040 # a single reference if there is still an active transaction,
2041 # or zero otherwise.
2043 # UPDATE: If the IO error occurs after a 'BEGIN' but before any
2044 # locks are established on database files (i.e. if the error
2045 # occurs while attempting to detect a hot-journal file), then
2046 # there may 0 page references and an active transaction according
2047 # to [sqlite3_get_autocommit].
2049 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
2050 do_test
$testname.
$n.4 {
2051 set bt
[btree_from_db db
]
2053 array set stats
[btree_pager_stats
$bt]
2055 set nRef
$stats(ref
)
2056 expr {$nRef == 0 ||
([sqlite3_get_autocommit db
]==0 && $nRef == 1)}
2060 # If there is an open database handle and no open transaction,
2061 # and the pager is not running in exclusive-locking mode,
2062 # check that the pager is in "unlocked" state. Theoretically,
2063 # if a call to xUnlock() failed due to an IO error the underlying
2064 # file may still be locked.
2067 if { [info commands db
] ne
""
2068 && $::ioerropts(-ckrefcount)
2069 && [db one
{pragma locking_mode
}] eq
"normal"
2070 && [sqlite3_get_autocommit db
]
2072 do_test
$testname.
$n.5 {
2073 set bt
[btree_from_db db
]
2075 array set stats
[btree_pager_stats
$bt]
2082 # If an IO error occurred, then the checksum of the database should
2083 # be the same as before the script that caused the IO error was run.
2085 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
2086 do_test
$testname.
$n.6 {
2089 set ::DB [sqlite3 db test.db
; sqlite3_connection_pointer db
]
2090 set nowcksum
[cksum
]
2091 set res
[expr {$nowcksum==$::checksum ||
$nowcksum==$::goodcksum}]
2093 output2
"now=$nowcksum"
2094 output2
"the=$::checksum"
2095 output2
"fwd=$::goodcksum"
2101 set ::sqlite_io_error_hardhit 0
2102 set ::sqlite_io_error_pending 0
2103 if {[info exists
::ioerropts(-cleanup)]} {
2104 catch $::ioerropts(-cleanup)
2107 set ::sqlite_io_error_pending 0
2108 set ::sqlite_io_error_persist 0
2112 # Return a checksum based on the contents of the main database associated
2113 # with connection $db
2115 proc cksum
{{db db
}} {
2117 SELECT name
, type
, sql FROM sqlite_master order by name
2119 foreach tbl
[$db eval {
2120 SELECT name FROM sqlite_master WHERE type
='table' order by name
2122 append txt
[$db eval "SELECT * FROM $tbl"]\n
2124 foreach prag
{default_synchronous default_cache_size
} {
2125 append txt
$prag-[$db eval "PRAGMA $prag"]\n
2127 set cksum
[string length
$txt]-[md5
$txt]
2128 # puts $cksum-[file size test.db]
2132 # Generate a checksum based on the contents of the main and temp tables
2133 # database $db. If the checksum of two databases is the same, and the
2134 # integrity-check passes for both, the two databases are identical.
2136 proc allcksum
{{db db
}} {
2140 SELECT name FROM sqlite_master WHERE type
= 'table' UNION
2141 SELECT name FROM sqlite_temp_master WHERE type
= 'table' UNION
2142 SELECT 'sqlite_master' UNION
2143 SELECT 'sqlite_temp_master' ORDER BY
1
2147 SELECT name FROM sqlite_master WHERE type
= 'table' UNION
2148 SELECT 'sqlite_master' ORDER BY
1
2151 set tbllist
[$db eval $sql]
2153 foreach tbl
$tbllist {
2154 append txt
[$db eval "SELECT * FROM $tbl"]
2156 foreach prag
{default_cache_size
} {
2157 append txt
$prag-[$db eval "PRAGMA $prag"]\n
2163 # Generate a checksum based on the contents of a single database with
2164 # a database connection. The name of the database is $dbname.
2165 # Examples of $dbname are "temp" or "main".
2167 proc dbcksum
{db dbname
} {
2168 if {$dbname=="temp"} {
2169 set master sqlite_temp_master
2171 set master
$dbname.sqlite_master
2173 set alltab
[$db eval "SELECT name FROM $master WHERE type='table'"]
2174 set txt
[$db eval "SELECT * FROM $master"]\n
2175 foreach tab
$alltab {
2176 append txt
[$db eval "SELECT * FROM $dbname.$tab"]\n
2181 proc memdebug_log_sql
{filename} {
2183 set data
[sqlite3_memdebug_log dump
]
2184 set nFrame
[expr [llength [lindex $data 0]]-2]
2185 if {$nFrame < 0} { return "" }
2189 set tbl
"CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);"
2193 set nCall
[lindex $e 0]
2194 set nByte
[lindex $e 1]
2195 set lStack
[lrange $e 2 end
]
2196 append sql
"INSERT INTO ${database}.malloc VALUES"
2197 append sql
"('test', $nCall, $nByte, '$lStack');\n"
2203 set tbl2
"CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
2204 set tbl3
"CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
2208 foreach f
[array names frames
] {
2209 set addr
[format %x
$f]
2210 set cmd
"eu-addr2line --pid=$pid $addr"
2211 set line
[eval exec $cmd]
2212 append sql
"INSERT INTO ${database}.frame VALUES($f, '$line');\n"
2214 set file [lindex [split $line :] 0]
2218 foreach f
[array names files
] {
2222 set contents
[read $fd]
2225 set contents
[string map
{' ''
} $contents]
2226 append sql
"INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
2229 set escaped
"BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
2230 set escaped
[string map
[list "{" "\\{" "}" "\\}" "\\" "\\\\"] $escaped]
2232 set fd
[open $filename w
]
2233 puts $fd "set BUILTIN {"
2236 puts $fd {set BUILTIN
[string map
[list "\\{" "{" "\\}" "}" "\\\\" "\\"] $BUILTIN]}
2237 set mtv
[open $::testdir/malloctraceviewer.tcl
]
2244 # Drop all tables in database [db]
2245 proc drop_all_tables
{{db db
}} {
2246 ifcapable trigger
&&foreignkey
{
2247 set pk
[$db one
"PRAGMA foreign_keys"]
2248 $db eval "PRAGMA foreign_keys = OFF"
2250 foreach {idx name
file} [db
eval {PRAGMA database_list
}] {
2252 set master sqlite_temp_master
2254 set master
$name.sqlite_master
2256 foreach {t type
} [$db eval "
2257 SELECT name, type FROM $master
2258 WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
2260 $db eval "DROP $type \"$t\""
2263 ifcapable trigger
&&foreignkey
{
2264 $db eval "PRAGMA foreign_keys = $pk"
2268 # Drop all auxiliary indexes from the main database opened by handle [db].
2270 proc drop_all_indexes
{{db db
}} {
2272 SELECT name FROM sqlite_master WHERE type
='index' AND sql LIKE 'create
%'
2274 foreach idx
$L { $db eval "DROP INDEX $idx" }
2278 #-------------------------------------------------------------------------
2279 # If a test script is executed with global variable $::G(perm:name) set to
2280 # "wal", then the tests are run in WAL mode. Otherwise, they should be run
2281 # in rollback mode. The following Tcl procs are used to make this less
2284 # wal_set_journal_mode ?DB?
2286 # If running a WAL test, execute "PRAGMA journal_mode = wal" using
2287 # connection handle DB. Otherwise, this command is a no-op.
2289 # wal_check_journal_mode TESTNAME ?DB?
2291 # If running a WAL test, execute a tests case that fails if the main
2292 # database for connection handle DB is not currently a WAL database.
2293 # Otherwise (if not running a WAL permutation) this is a no-op.
2297 # Returns true if this test should be run in WAL mode. False otherwise.
2299 proc wal_is_wal_mode
{} {
2300 expr {[permutation
] eq
"wal"}
2302 proc wal_set_journal_mode
{{db db
}} {
2303 if { [wal_is_wal_mode
] } {
2304 $db eval "PRAGMA journal_mode = WAL"
2307 proc wal_check_journal_mode
{testname
{db db
}} {
2308 if { [wal_is_wal_mode
] } {
2309 $db eval { SELECT
* FROM sqlite_master
}
2310 do_test
$testname [list $db eval "PRAGMA main.journal_mode"] {wal
}
2314 proc wal_is_capable
{} {
2315 ifcapable
!wal
{ return 0 }
2316 if {[permutation
]=="journaltest"} { return 0 }
2320 proc permutation
{} {
2322 catch {set perm
$::G(perm
:name
)}
2327 catch {set presql
$::G(perm
:presql
)}
2333 catch {set ret
$::G(isquick
)}
2337 #-------------------------------------------------------------------------
2339 proc slave_test_script
{script
} {
2341 # Create the interpreter used to run the test script.
2342 interp create tinterp
2344 # Populate some global variables that tester.tcl expects to see.
2345 foreach {var value
} [list \
2350 interp eval tinterp
[list set $var $value]
2353 # If output is being copied into a file, share the file-descriptor with
2355 if {[info exists
::G(output_fd
)]} {
2356 interp share
{} $::G(output_fd
) tinterp
2359 # The alias used to access the global test counters.
2360 tinterp alias set_test_counter set_test_counter
2362 # Set up the ::cmdlinearg array in the slave.
2363 interp eval tinterp
[list array set ::cmdlinearg [array get
::cmdlinearg]]
2365 # Set up the ::G array in the slave.
2366 interp eval tinterp
[list array set ::G [array get
::G]]
2368 # Load the various test interfaces implemented in C.
2369 load_testfixture_extensions tinterp
2371 # Run the test script.
2372 interp eval tinterp
$script
2374 # Check if the interpreter call [run_thread_tests]
2375 if { [interp eval tinterp
{info exists
::run_thread_tests_called}] } {
2376 set ::run_thread_tests_called 1
2379 # Delete the interpreter used to run the test script.
2380 interp delete tinterp
2383 proc slave_test_file
{zFile
} {
2384 set tail
[file tail
$zFile]
2386 if {[info exists
::G(start
:permutation
)]} {
2387 if {[permutation
] != $::G(start
:permutation
)} return
2388 unset ::G(start
:permutation
)
2390 if {[info exists
::G(start
:file)]} {
2391 if {$tail != $::G(start
:file) && $tail!="$::G(start:file).test"} return
2392 unset ::G(start
:file)
2395 # Remember the value of the shared-cache setting. So that it is possible
2396 # to check afterwards that it was not modified by the test script.
2398 ifcapable shared_cache
{ set scs
[sqlite3_enable_shared_cache
] }
2400 # Run the test script in a slave interpreter.
2402 unset -nocomplain ::run_thread_tests_called
2404 set ::sqlite_open_file_count 0
2405 set time [time { slave_test_script
[list source $zFile] }]
2406 set ms
[expr [lindex $time 0] / 1000]
2408 # Test that all files opened by the test script were closed. Omit this
2409 # if the test script has "thread" in its name. The open file counter
2410 # is not thread-safe.
2412 if {[info exists
::run_thread_tests_called]==0} {
2413 do_test
${tail
}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0}
2415 set ::sqlite_open_file_count 0
2417 # Test that the global "shared-cache" setting was not altered by
2420 ifcapable shared_cache
{
2421 set res
[expr {[sqlite3_enable_shared_cache
] == $scs}]
2422 do_test
${tail
}-sharedcachesetting [list set {} $res] 1
2425 # Add some info to the output.
2427 output2
"Time: $tail $ms ms"
2431 # Open a new connection on database test.db and execute the SQL script
2432 # supplied as an argument. Before returning, close the new conection and
2433 # restore the 4 byte fields starting at header offsets 28, 92 and 96
2434 # to the values they held before the SQL was executed. This simulates
2435 # a write by a pre-3.7.0 client.
2437 proc sql36231
{sql
} {
2438 set B
[hexio_read test.db
92 8]
2439 set A
[hexio_read test.db
28 4]
2440 sqlite3 db36231 test.db
2441 catch { db36231 func a_string a_string
}
2442 execsql
$sql db36231
2444 hexio_write test.db
28 $A
2445 hexio_write test.db
92 $B
2450 foreach f
[glob -nocomplain sv_test.db
*] { forcedelete
$f }
2451 foreach f
[glob -nocomplain test.db
*] {
2456 proc db_save_and_close
{} {
2461 proc db_restore
{} {
2462 foreach f
[glob -nocomplain test.db
*] { forcedelete
$f }
2463 foreach f2
[glob -nocomplain sv_test.db
*] {
2464 set f
[string range
$f2 3 end
]
2468 proc db_restore_and_reopen
{{dbfile test.db
}} {
2473 proc db_delete_and_reopen
{{file test.db
}} {
2475 foreach f
[glob -nocomplain test.db
*] { forcedelete
$f }
2479 # Close any connections named [db], [db2] or [db3]. Then use sqlite3_config
2480 # to configure the size of the PAGECACHE allocation using the parameters
2481 # provided to this command. Save the old PAGECACHE parameters in a global
2482 # variable so that [test_restore_config_pagecache] can restore the previous
2485 # Before returning, reopen connection [db] on file test.db.
2487 proc test_set_config_pagecache
{sz nPg
} {
2493 set ::old_pagecache_config [sqlite3_config_pagecache
$sz $nPg]
2495 autoinstall_test_functions
2499 # Close any connections named [db], [db2] or [db3]. Then use sqlite3_config
2500 # to configure the size of the PAGECACHE allocation to the size saved in
2501 # the global variable by an earlier call to [test_set_config_pagecache].
2503 # Before returning, reopen connection [db] on file test.db.
2505 proc test_restore_config_pagecache
{} {
2511 if {[info exists
::old_pagecache_config]} {
2512 eval sqlite3_config_pagecache
$::old_pagecache_config
2513 unset ::old_pagecache_config
2516 autoinstall_test_functions
2520 proc test_binary_name
{nm
} {
2521 if {$::tcl_platform(platform
)=="windows"} {
2526 file normalize
[file join $::cmdlinearg(TESTFIXTURE_HOME
) $ret]
2529 proc test_find_binary
{nm
} {
2530 set ret
[test_binary_name
$nm]
2531 if {![file executable
$ret]} {
2538 # Find the name of the 'shell' executable (e.g. "sqlite3.exe") to use for
2539 # the tests in shell*.test. If no such executable can be found, invoke
2540 # [finish_test ; return] in the callers context.
2542 proc test_find_cli
{} {
2543 set prog
[test_find_binary sqlite3
]
2544 if {$prog==""} { return -code return }
2548 # Find invocation of the 'shell' executable (e.g. "sqlite3.exe") to use
2549 # for the tests in shell*.test with optional valgrind prefix when the
2550 # environment variable SQLITE_CLI_VALGRIND_OPT is set. The set value
2551 # operates as follows:
2552 # empty or 0 => no valgrind prefix;
2553 # 1 => valgrind options for memory leak check;
2554 # other => use value as valgrind options.
2555 # If shell not found, invoke [finish_test ; return] in callers context.
2557 proc test_cli_invocation
{} {
2558 set prog
[test_find_binary sqlite3
]
2559 if {$prog==""} { return -code return }
2560 set vgrun
[expr {[permutation
]=="valgrind"}]
2561 if {$vgrun ||
[info exists
::env(SQLITE_CLI_VALGRIND_OPT
)]} {
2565 set vgo
$::env(SQLITE_CLI_VALGRIND_OPT
)
2567 if {$vgo == 0 ||
$vgo eq
""} {
2569 } elseif
{$vgo == 1} {
2570 return "valgrind --quiet --leak-check=yes $prog"
2572 return "valgrind $vgo $prog"
2579 # Find the name of the 'sqldiff' executable (e.g. "sqlite3.exe") to use for
2580 # the tests in sqldiff tests. If no such executable can be found, invoke
2581 # [finish_test ; return] in the callers context.
2583 proc test_find_sqldiff
{} {
2584 set prog
[test_find_binary sqldiff
]
2585 if {$prog==""} { return -code return }
2589 # Call sqlite3_expanded_sql() on all statements associated with database
2590 # connection $db. This sometimes finds use-after-free bugs if run with
2591 # valgrind or address-sanitizer.
2592 proc expand_all_sql
{db
} {
2594 while {[set stmt
[sqlite3_next_stmt
$db $stmt]]!=""} {
2595 sqlite3_expanded_sql
$stmt
2600 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
2601 # to non-zero, then set the global variable $AUTOVACUUM to 1.
2602 set AUTOVACUUM
$sqlite_options(default_autovacuum
)
2604 # Make sure the FTS enhanced query syntax is disabled.
2605 set sqlite_fts3_enable_parentheses
0
2607 # During testing, assume that all database files are well-formed. The
2608 # few test cases that deliberately corrupt database files should rescind
2609 # this setting by invoking "database_can_be_corrupt"
2611 database_never_corrupt
2612 extra_schema_checks
1
2614 source $testdir/thread_common.tcl
2615 source $testdir/malloc_common.tcl
2617 set tester_tcl_has_run
1