diff options
Diffstat (limited to '')
| -rw-r--r-- | test/tester.tcl | 2600 |
1 files changed, 2600 insertions, 0 deletions
diff --git a/test/tester.tcl b/test/tester.tcl new file mode 100644 index 0000000..9353b91 --- /dev/null +++ b/test/tester.tcl @@ -0,0 +1,2600 @@ +# 2001 September 15 +# +# The author disclaims copyright to this source code. In place of +# a legal notice, here is a blessing: +# +# May you do good and not evil. +# May you find forgiveness for yourself and forgive others. +# May you share freely, never taking more than you give. +# +#*********************************************************************** +# This file implements some common TCL routines used for regression +# testing the SQLite library +# +# $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $ + +#------------------------------------------------------------------------- +# The commands provided by the code in this file to help with creating +# test cases are as follows: +# +# Commands to manipulate the db and the file-system at a high level: +# +# is_relative_file +# test_pwd +# get_pwd +# copy_file FROM TO +# delete_file FILENAME +# drop_all_tables ?DB? +# drop_all_indexes ?DB? +# forcecopy FROM TO +# forcedelete FILENAME +# +# Test the capability of the SQLite version built into the interpreter to +# determine if a specific test can be run: +# +# capable EXPR +# ifcapable EXPR +# +# Calulate checksums based on database contents: +# +# dbcksum DB DBNAME +# allcksum ?DB? +# cksum ?DB? +# +# Commands to execute/explain SQL statements: +# +# memdbsql SQL +# stepsql DB SQL +# execsql2 SQL +# explain_no_trace SQL +# explain SQL ?DB? +# catchsql SQL ?DB? +# execsql SQL ?DB? +# +# Commands to run test cases: +# +# do_ioerr_test TESTNAME ARGS... +# crashsql ARGS... +# integrity_check TESTNAME ?DB? +# verify_ex_errcode TESTNAME EXPECTED ?DB? +# do_test TESTNAME SCRIPT EXPECTED +# do_execsql_test TESTNAME SQL EXPECTED +# do_catchsql_test TESTNAME SQL EXPECTED +# do_timed_execsql_test TESTNAME SQL EXPECTED +# +# Commands providing a lower level interface to the global test counters: +# +# set_test_counter COUNTER ?VALUE? +# omit_test TESTNAME REASON ?APPEND? +# fail_test TESTNAME +# incr_ntest +# +# Command run at the end of each test file: +# +# finish_test +# +# Commands to help create test files that run with the "WAL" and other +# permutations (see file permutations.test): +# +# wal_is_wal_mode +# wal_set_journal_mode ?DB? +# wal_check_journal_mode TESTNAME?DB? +# permutation +# presql +# +# Command to test whether or not --verbose=1 was specified on the command +# line (returns 0 for not-verbose, 1 for verbose and 2 for "verbose in the +# output file only"). +# +# verbose +# + +# Only run this script once. If sourced a second time, make it a no-op +if {[info exists ::tester_tcl_has_run]} return + +# Set the precision of FP arithmatic used by the interpreter. And +# configure SQLite to take database file locks on the page that begins +# 64KB into the database file instead of the one 1GB in. This means +# the code that handles that special case can be tested without creating +# very large database files. +# +set tcl_precision 15 +sqlite3_test_control_pending_byte 0x0010000 + + +# If the pager codec is available, create a wrapper for the [sqlite3] +# command that appends "-key {xyzzy}" to the command line. i.e. this: +# +# sqlite3 db test.db +# +# becomes +# +# sqlite3 db test.db -key {xyzzy} +# +if {[info command sqlite_orig]==""} { + rename sqlite3 sqlite_orig + proc sqlite3 {args} { + if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} { + # This command is opening a new database connection. + # + if {[info exists ::G(perm:sqlite3_args)]} { + set args [concat $args $::G(perm:sqlite3_args)] + } + if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} { + lappend args -key {xyzzy} + } + + set res [uplevel 1 sqlite_orig $args] + if {[info exists ::G(perm:presql)]} { + [lindex $args 0] eval $::G(perm:presql) + } + if {[info exists ::G(perm:dbconfig)]} { + set ::dbhandle [lindex $args 0] + uplevel #0 $::G(perm:dbconfig) + } + [lindex $args 0] cache size 3 + set res + } else { + # This command is not opening a new database connection. Pass the + # arguments through to the C implementation as the are. + # + uplevel 1 sqlite_orig $args + } + } +} + +proc getFileRetries {} { + if {![info exists ::G(file-retries)]} { + # + # NOTE: Return the default number of retries for [file] operations. A + # value of zero or less here means "disabled". + # + return [expr {$::tcl_platform(platform) eq "windows" ? 50 : 0}] + } + return $::G(file-retries) +} + +proc getFileRetryDelay {} { + if {![info exists ::G(file-retry-delay)]} { + # + # NOTE: Return the default number of milliseconds to wait when retrying + # failed [file] operations. A value of zero or less means "do not + # wait". + # + return 100; # TODO: Good default? + } + return $::G(file-retry-delay) +} + +# Return the string representing the name of the current directory. On +# Windows, the result is "normalized" to whatever our parent command shell +# is using to prevent case-mismatch issues. +# +proc get_pwd {} { + if {$::tcl_platform(platform) eq "windows"} { + # + # NOTE: Cannot use [file normalize] here because it would alter the + # case of the result to what Tcl considers canonical, which would + # defeat the purpose of this procedure. + # + if {[info exists ::env(ComSpec)]} { + set comSpec $::env(ComSpec) + } else { + # NOTE: Hard-code the typical default value. + set comSpec {C:\Windows\system32\cmd.exe} + } + return [string map [list \\ /] \ + [string trim [exec -- $comSpec /c CD]]] + } else { + return [pwd] + } +} + +# Copy file $from into $to. This is used because some versions of +# TCL for windows (notably the 8.4.1 binary package shipped with the +# current mingw release) have a broken "file copy" command. +# +proc copy_file {from to} { + do_copy_file false $from $to +} + +proc forcecopy {from to} { + do_copy_file true $from $to +} + +proc do_copy_file {force from to} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + # On windows, sometimes even a [file copy -force] can fail. The cause is + # usually "tag-alongs" - programs like anti-virus software, automatic backup + # tools and various explorer extensions that keep a file open a little longer + # than we expect, causing the delete to fail. + # + # The solution is to wait a short amount of time before retrying the copy. + # + if {$nRetry > 0} { + for {set i 0} {$i<$nRetry} {incr i} { + set rc [catch { + if {$force} { + file copy -force $from $to + } else { + file copy $from $to + } + } msg] + if {$rc==0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + if {$force} { + file copy -force $from $to + } else { + file copy $from $to + } + } +} + +# Check if a file name is relative +# +proc is_relative_file { file } { + return [expr {[file pathtype $file] != "absolute"}] +} + +# If the VFS supports using the current directory, returns [pwd]; +# otherwise, it returns only the provided suffix string (which is +# empty by default). +# +proc test_pwd { args } { + if {[llength $args] > 0} { + set suffix1 [lindex $args 0] + if {[llength $args] > 1} { + set suffix2 [lindex $args 1] + } else { + set suffix2 $suffix1 + } + } else { + set suffix1 ""; set suffix2 "" + } + ifcapable curdir { + return "[get_pwd]$suffix1" + } else { + return $suffix2 + } +} + +# Delete a file or directory +# +proc delete_file {args} { + do_delete_file false {*}$args +} + +proc forcedelete {args} { + do_delete_file true {*}$args +} + +proc do_delete_file {force args} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + foreach filename $args { + # On windows, sometimes even a [file delete -force] can fail just after + # a file is closed. The cause is usually "tag-alongs" - programs like + # anti-virus software, automatic backup tools and various explorer + # extensions that keep a file open a little longer than we expect, causing + # the delete to fail. + # + # The solution is to wait a short amount of time before retrying the + # delete. + # + if {$nRetry > 0} { + for {set i 0} {$i<$nRetry} {incr i} { + set rc [catch { + if {$force} { + file delete -force $filename + } else { + file delete $filename + } + } msg] + if {$rc==0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + if {$force} { + file delete -force $filename + } else { + file delete $filename + } + } + } +} + +if {$::tcl_platform(platform) eq "windows"} { + proc do_remove_win32_dir {args} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + foreach dirName $args { + # On windows, sometimes even a [remove_win32_dir] can fail just after + # a directory is emptied. The cause is usually "tag-alongs" - programs + # like anti-virus software, automatic backup tools and various explorer + # extensions that keep a file open a little longer than we expect, + # causing the delete to fail. + # + # The solution is to wait a short amount of time before retrying the + # removal. + # + if {$nRetry > 0} { + for {set i 0} {$i < $nRetry} {incr i} { + set rc [catch { + remove_win32_dir $dirName + } msg] + if {$rc == 0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + remove_win32_dir $dirName + } + } + } + + proc do_delete_win32_file {args} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + foreach fileName $args { + # On windows, sometimes even a [delete_win32_file] can fail just after + # a file is closed. The cause is usually "tag-alongs" - programs like + # anti-virus software, automatic backup tools and various explorer + # extensions that keep a file open a little longer than we expect, + # causing the delete to fail. + # + # The solution is to wait a short amount of time before retrying the + # delete. + # + if {$nRetry > 0} { + for {set i 0} {$i < $nRetry} {incr i} { + set rc [catch { + delete_win32_file $fileName + } msg] + if {$rc == 0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + delete_win32_file $fileName + } + } + } +} + +proc execpresql {handle args} { + trace remove execution $handle enter [list execpresql $handle] + if {[info exists ::G(perm:presql)]} { + $handle eval $::G(perm:presql) + } +} + +# This command should be called after loading tester.tcl from within +# all test scripts that are incompatible with encryption codecs. +# +proc do_not_use_codec {} { + set ::do_not_use_codec 1 + reset_db +} +unset -nocomplain do_not_use_codec + +# Return true if the "reserved_bytes" integer on database files is non-zero. +# +proc nonzero_reserved_bytes {} { + return [sqlite3 -has-codec] +} + +# Print a HELP message and exit +# +proc print_help_and_quit {} { + puts {Options: + --pause Wait for user input before continuing + --soft-heap-limit=N Set the soft-heap-limit to N + --hard-heap-limit=N Set the hard-heap-limit to N + --maxerror=N Quit after N errors + --verbose=(0|1) Control the amount of output. Default '1' + --output=FILE set --verbose=2 and output to FILE. Implies -q + -q Shorthand for --verbose=0 + --help This message +} + exit 1 +} + +# The following block only runs the first time this file is sourced. It +# does not run in slave interpreters (since the ::cmdlinearg array is +# populated before the test script is run in slave interpreters). +# +if {[info exists cmdlinearg]==0} { + + # Parse any options specified in the $argv array. This script accepts the + # following options: + # + # --pause + # --soft-heap-limit=NN + # --hard-heap-limit=NN + # --maxerror=NN + # --malloctrace=N + # --backtrace=N + # --binarylog=N + # --soak=N + # --file-retries=N + # --file-retry-delay=N + # --start=[$permutation:]$testfile + # --match=$pattern + # --verbose=$val + # --output=$filename + # -q Reduce output + # --testdir=$dir Run tests in subdirectory $dir + # --help + # + set cmdlinearg(soft-heap-limit) 0 + set cmdlinearg(hard-heap-limit) 0 + set cmdlinearg(maxerror) 1000 + set cmdlinearg(malloctrace) 0 + set cmdlinearg(backtrace) 10 + set cmdlinearg(binarylog) 0 + set cmdlinearg(soak) 0 + set cmdlinearg(file-retries) 0 + set cmdlinearg(file-retry-delay) 0 + set cmdlinearg(start) "" + set cmdlinearg(match) "" + set cmdlinearg(verbose) "" + set cmdlinearg(output) "" + set cmdlinearg(testdir) "testdir" + + set leftover [list] + foreach a $argv { + switch -regexp -- $a { + {^-+pause$} { + # Wait for user input before continuing. This is to give the user an + # opportunity to connect profiling tools to the process. + puts -nonewline "Press RETURN to begin..." + flush stdout + gets stdin + } + {^-+soft-heap-limit=.+$} { + foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break + } + {^-+hard-heap-limit=.+$} { + foreach {dummy cmdlinearg(hard-heap-limit)} [split $a =] break + } + {^-+maxerror=.+$} { + foreach {dummy cmdlinearg(maxerror)} [split $a =] break + } + {^-+malloctrace=.+$} { + foreach {dummy cmdlinearg(malloctrace)} [split $a =] break + if {$cmdlinearg(malloctrace)} { + if {0==$::sqlite_options(memdebug)} { + set err "Error: --malloctrace=1 requires an SQLITE_MEMDEBUG build" + puts stderr $err + exit 1 + } + sqlite3_memdebug_log start + } + } + {^-+backtrace=.+$} { + foreach {dummy cmdlinearg(backtrace)} [split $a =] break + sqlite3_memdebug_backtrace $cmdlinearg(backtrace) + } + {^-+binarylog=.+$} { + foreach {dummy cmdlinearg(binarylog)} [split $a =] break + set cmdlinearg(binarylog) [file normalize $cmdlinearg(binarylog)] + } + {^-+soak=.+$} { + foreach {dummy cmdlinearg(soak)} [split $a =] break + set ::G(issoak) $cmdlinearg(soak) + } + {^-+file-retries=.+$} { + foreach {dummy cmdlinearg(file-retries)} [split $a =] break + set ::G(file-retries) $cmdlinearg(file-retries) + } + {^-+file-retry-delay=.+$} { + foreach {dummy cmdlinearg(file-retry-delay)} [split $a =] break + set ::G(file-retry-delay) $cmdlinearg(file-retry-delay) + } + {^-+start=.+$} { + foreach {dummy cmdlinearg(start)} [split $a =] break + + set ::G(start:file) $cmdlinearg(start) + if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} { + set ::G(start:permutation) ${s.perm} + set ::G(start:file) ${s.file} + } + if {$::G(start:file) == ""} {unset ::G(start:file)} + } + {^-+match=.+$} { + foreach {dummy cmdlinearg(match)} [split $a =] break + + set ::G(match) $cmdlinearg(match) + if {$::G(match) == ""} {unset ::G(match)} + } + + {^-+output=.+$} { + foreach {dummy cmdlinearg(output)} [split $a =] break + set cmdlinearg(output) [file normalize $cmdlinearg(output)] + if {$cmdlinearg(verbose)==""} { + set cmdlinearg(verbose) 2 + } + } + {^-+verbose=.+$} { + foreach {dummy cmdlinearg(verbose)} [split $a =] break + if {$cmdlinearg(verbose)=="file"} { + set cmdlinearg(verbose) 2 + } elseif {[string is boolean -strict $cmdlinearg(verbose)]==0} { + error "option --verbose= must be set to a boolean or to \"file\"" + } + } + {^-+testdir=.*$} { + foreach {dummy cmdlinearg(testdir)} [split $a =] break + } + {.*help.*} { + print_help_and_quit + } + {^-q$} { + set cmdlinearg(output) test-out.txt + set cmdlinearg(verbose) 2 + } + + default { + if {[file tail $a]==$a} { + lappend leftover $a + } else { + lappend leftover [file normalize $a] + } + } + } + } + set testdir [file normalize $testdir] + set cmdlinearg(TESTFIXTURE_HOME) [pwd] + set cmdlinearg(INFO_SCRIPT) [file normalize [info script]] + set argv0 [file normalize $argv0] + if {$cmdlinearg(testdir)!=""} { + file mkdir $cmdlinearg(testdir) + cd $cmdlinearg(testdir) + } + set argv $leftover + + # Install the malloc layer used to inject OOM errors. And the 'automatic' + # extensions. This only needs to be done once for the process. + # + sqlite3_shutdown + install_malloc_faultsim 1 + sqlite3_initialize + autoinstall_test_functions + + # If the --binarylog option was specified, create the logging VFS. This + # call installs the new VFS as the default for all SQLite connections. + # + if {$cmdlinearg(binarylog)} { + vfslog new binarylog {} vfslog.bin + } + + # Set the backtrace depth, if malloc tracing is enabled. + # + if {$cmdlinearg(malloctrace)} { + sqlite3_memdebug_backtrace $cmdlinearg(backtrace) + } + + if {$cmdlinearg(output)!=""} { + puts "Copying output to file $cmdlinearg(output)" + set ::G(output_fd) [open $cmdlinearg(output) w] + fconfigure $::G(output_fd) -buffering line + } + + if {$cmdlinearg(verbose)==""} { + set cmdlinearg(verbose) 1 + } + + if {[info commands vdbe_coverage]!=""} { + vdbe_coverage start + } +} + +# Update the soft-heap-limit each time this script is run. In that +# way if an individual test file changes the soft-heap-limit, it +# will be reset at the start of the next test file. +# +sqlite3_soft_heap_limit64 $cmdlinearg(soft-heap-limit) +sqlite3_hard_heap_limit64 $cmdlinearg(hard-heap-limit) + +# Create a test database +# +proc reset_db {} { + catch {db close} + forcedelete test.db + forcedelete test.db-journal + forcedelete test.db-wal + sqlite3 db ./test.db + set ::DB [sqlite3_connection_pointer db] + if {[info exists ::SETUP_SQL]} { + db eval $::SETUP_SQL + } +} +reset_db + +# Abort early if this script has been run before. +# +if {[info exists TC(count)]} return + +# Make sure memory statistics are enabled. +# +sqlite3_config_memstatus 1 + +# Initialize the test counters and set up commands to access them. +# Or, if this is a slave interpreter, set up aliases to write the +# counters in the parent interpreter. +# +if {0==[info exists ::SLAVE]} { + set TC(errors) 0 + set TC(count) 0 + set TC(fail_list) [list] + set TC(omit_list) [list] + set TC(warn_list) [list] + + proc set_test_counter {counter args} { + if {[llength $args]} { + set ::TC($counter) [lindex $args 0] + } + set ::TC($counter) + } +} + +# Record the fact that a sequence of tests were omitted. +# +proc omit_test {name reason {append 1}} { + set omitList [set_test_counter omit_list] + if {$append} { + lappend omitList [list $name $reason] + } + set_test_counter omit_list $omitList +} + +# Record the fact that a test failed. +# +proc fail_test {name} { + set f [set_test_counter fail_list] + lappend f $name + set_test_counter fail_list $f + set_test_counter errors [expr [set_test_counter errors] + 1] + + set nFail [set_test_counter errors] + if {$nFail>=$::cmdlinearg(maxerror)} { + output2 "*** Giving up..." + finalize_testing + } +} + +# Remember a warning message to be displayed at the conclusion of all testing +# +proc warning {msg {append 1}} { + output2 "Warning: $msg" + set warnList [set_test_counter warn_list] + if {$append} { + lappend warnList $msg + } + set_test_counter warn_list $warnList +} + + +# Increment the number of tests run +# +proc incr_ntest {} { + set_test_counter count [expr [set_test_counter count] + 1] +} + +# Return true if --verbose=1 was specified on the command line. Otherwise, +# return false. +# +proc verbose {} { + return $::cmdlinearg(verbose) +} + +# Use the following commands instead of [puts] for test output within +# this file. Test scripts can still use regular [puts], which is directed +# to stdout and, if one is open, the --output file. +# +# output1: output that should be printed if --verbose=1 was specified. +# output2: output that should be printed unconditionally. +# output2_if_no_verbose: output that should be printed only if --verbose=0. +# +proc output1 {args} { + set v [verbose] + if {$v==1} { + uplevel output2 $args + } elseif {$v==2} { + uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end] + } +} +proc output2 {args} { + set nArg [llength $args] + uplevel puts $args +} +proc output2_if_no_verbose {args} { + set v [verbose] + if {$v==0} { + uplevel output2 $args + } elseif {$v==2} { + uplevel puts [lrange $args 0 end-1] stdout [lrange $args end end] + } +} + +# Override the [puts] command so that if no channel is explicitly +# specified the string is written to both stdout and to the file +# specified by "--output=", if any. +# +proc puts_override {args} { + set nArg [llength $args] + if {$nArg==1 || ($nArg==2 && [string first [lindex $args 0] -nonewline]==0)} { + uplevel puts_original $args + if {[info exists ::G(output_fd)]} { + uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end] + } + } else { + # A channel was explicitly specified. + uplevel puts_original $args + } +} +rename puts puts_original +proc puts {args} { uplevel puts_override $args } + + +# Invoke the do_test procedure to run a single test +# +# The $expected parameter is the expected result. The result is the return +# value from the last TCL command in $cmd. +# +# Normally, $expected must match exactly. But if $expected is of the form +# "/regexp/" then regular expression matching is used. If $expected is +# "~/regexp/" then the regular expression must NOT match. If $expected is +# of the form "#/value-list/" then each term in value-list must be numeric +# and must approximately match the corresponding numeric term in $result. +# Values must match within 10%. Or if the $expected term is A..B then the +# $result term must be in between A and B. +# +proc do_test {name cmd expected} { + global argv cmdlinearg + + fix_testname name + + sqlite3_memdebug_settitle $name + +# if {[llength $argv]==0} { +# set go 1 +# } else { +# set go 0 +# foreach pattern $argv { +# if {[string match $pattern $name]} { +# set go 1 +# break +# } +# } +# } + + if {[info exists ::G(perm:prefix)]} { + set name "$::G(perm:prefix)$name" + } + + incr_ntest + output1 -nonewline $name... + flush stdout + + if {![info exists ::G(match)] || [string match $::G(match) $name]} { + if {[catch {uplevel #0 "$cmd;\n"} result]} { + output2_if_no_verbose -nonewline $name... + output2 "\nError: $result" + fail_test $name + } else { + if {[permutation]=="maindbname"} { + set result [string map [list [string tolower ICECUBE] main] $result] + } + if {[regexp {^[~#]?/.*/$} $expected]} { + # "expected" is of the form "/PATTERN/" then the result if correct if + # regular expression PATTERN matches the result. "~/PATTERN/" means + # the regular expression must not match. + if {[string index $expected 0]=="~"} { + set re [string range $expected 2 end-1] + if {[string index $re 0]=="*"} { + # If the regular expression begins with * then treat it as a glob instead + set ok [string match $re $result] + } else { + set re [string map {# {[-0-9.]+}} $re] + set ok [regexp $re $result] + } + set ok [expr {!$ok}] + } elseif {[string index $expected 0]=="#"} { + # Numeric range value comparison. Each term of the $result is matched + # against one term of $expect. Both $result and $expected terms must be + # numeric. The values must match within 10%. Or if $expected is of the + # form A..B then the $result term must be between A and B. + set e2 [string range $expected 2 end-1] + foreach i $result j $e2 { + if {[regexp {^(-?\d+)\.\.(-?\d)$} $j all A B]} { + set ok [expr {$i+0>=$A && $i+0<=$B}] + } else { + set ok [expr {$i+0>=0.9*$j && $i+0<=1.1*$j}] + } + if {!$ok} break + } + if {$ok && [llength $result]!=[llength $e2]} {set ok 0} + } else { + set re [string range $expected 1 end-1] + if {[string index $re 0]=="*"} { + # If the regular expression begins with * then treat it as a glob instead + set ok [string match $re $result] + } else { + set re [string map {# {[-0-9.]+}} $re] + set ok [regexp $re $result] + } + } + } elseif {[regexp {^~?\*.*\*$} $expected]} { + # "expected" is of the form "*GLOB*" then the result if correct if + # glob pattern GLOB matches the result. "~/GLOB/" means + # the glob must not match. + if {[string index $expected 0]=="~"} { + set e [string range $expected 1 end] + set ok [expr {![string match $e $result]}] + } else { + set ok [string match $expected $result] + } + } else { + set ok [expr {[string compare $result $expected]==0}] + } + if {!$ok} { + # if {![info exists ::testprefix] || $::testprefix eq ""} { + # error "no test prefix" + # } + output1 "" + output2 "! $name expected: \[$expected\]\n! $name got: \[$result\]" + fail_test $name + } else { + output1 " Ok" + } + } + } else { + output1 " Omitted" + omit_test $name "pattern mismatch" 0 + } + flush stdout +} + +proc dumpbytes {s} { + set r "" + for {set i 0} {$i < [string length $s]} {incr i} { + if {$i > 0} {append r " "} + append r [format %02X [scan [string index $s $i] %c]] + } + return $r +} + +proc catchcmd {db {cmd ""}} { + global CLI + set out [open cmds.txt w] + puts $out $cmd + close $out + set line "exec $CLI $db < cmds.txt" + set rc [catch { eval $line } msg] + list $rc $msg +} + +proc catchcmdex {db {cmd ""}} { + global CLI + set out [open cmds.txt w] + fconfigure $out -encoding binary -translation binary + puts -nonewline $out $cmd + close $out + set line "exec -keepnewline -- $CLI $db < cmds.txt" + set chans [list stdin stdout stderr] + foreach chan $chans { + catch { + set modes($chan) [fconfigure $chan] + fconfigure $chan -encoding binary -translation binary -buffering none + } + } + set rc [catch { eval $line } msg] + foreach chan $chans { + catch { + eval fconfigure [list $chan] $modes($chan) + } + } + # puts [dumpbytes $msg] + list $rc $msg +} + +proc filepath_normalize {p} { + # test cases should be written to assume "unix"-like file paths + if {$::tcl_platform(platform)!="unix"} { + string map [list \\ / \{/ / .db\} .db] \ + [regsub -nocase -all {[a-z]:[/\\]+} $p {/}] + } { + set p + } +} +proc do_filepath_test {name cmd expected} { + uplevel [list do_test $name [ + subst -nocommands { filepath_normalize [ $cmd ] } + ] [filepath_normalize $expected]] +} + +proc realnum_normalize {r} { + # different TCL versions display floating point values differently. + string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}] +} +proc do_realnum_test {name cmd expected} { + uplevel [list do_test $name [ + subst -nocommands { realnum_normalize [ $cmd ] } + ] [realnum_normalize $expected]] +} + +proc fix_testname {varname} { + upvar $varname testname + if {[info exists ::testprefix] + && [string is digit [string range $testname 0 0]] + } { + set testname "${::testprefix}-$testname" + } +} + +proc normalize_list {L} { + set L2 [list] + foreach l $L {lappend L2 $l} + set L2 +} + +# Either: +# +# do_execsql_test TESTNAME SQL ?RES? +# do_execsql_test -db DB TESTNAME SQL ?RES? +# +proc do_execsql_test {args} { + set db db + if {[lindex $args 0]=="-db"} { + set db [lindex $args 1] + set args [lrange $args 2 end] + } + + if {[llength $args]==2} { + foreach {testname sql} $args {} + set result "" + } elseif {[llength $args]==3} { + foreach {testname sql result} $args {} + + # With some versions of Tcl on windows, if $result is all whitespace but + # contains some CR/LF characters, the [list {*}$result] below returns a + # copy of $result instead of a zero length string. Not clear exactly why + # this is. The following is a workaround. + if {[llength $result]==0} { set result "" } + } else { + error [string trim { + wrong # args: should be "do_execsql_test ?-db DB? testname sql ?result?" + }] + } + + fix_testname testname + + uplevel do_test \ + [list $testname] \ + [list "execsql {$sql} $db"] \ + [list [list {*}$result]] +} + +proc do_catchsql_test {testname sql result} { + fix_testname testname + uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result] +} +proc do_timed_execsql_test {testname sql {result {}}} { + fix_testname testname + uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\ + [list [list {*}$result]] +} + +# Run an EXPLAIN QUERY PLAN $sql in database "db". Then rewrite the output +# as an ASCII-art graph and return a string that is that graph. +# +# Hexadecimal literals in the output text are converted into "xxxxxx" since those +# literals are pointer values that might very from one run of the test to the +# next, yet we want the output to be consistent. +# +proc query_plan_graph {sql} { + db eval "EXPLAIN QUERY PLAN $sql" { + set dx($id) $detail + lappend cx($parent) $id + } + set a "\n QUERY PLAN\n" + append a [append_graph " " dx cx 0] + regsub -all { 0x[A-F0-9]+\y} $a { xxxxxx} a + regsub -all {(MATERIALIZE|CO-ROUTINE|SUBQUERY) \d+\y} $a {\1 xxxxxx} a + regsub -all {\((join|subquery)-\d+\)} $a {(\1-xxxxxx)} a + return $a +} + +# Helper routine for [query_plan_graph SQL]: +# +# Output rows of the graph that are children of $level. +# +# prefix: Prepend to every output line +# +# dxname: Name of an array variable that stores text describe +# The description for $id is $dx($id) +# +# cxname: Name of an array variable holding children of item. +# Children of $id are $cx($id) +# +# level: Render all lines that are children of $level +# +proc append_graph {prefix dxname cxname level} { + upvar $dxname dx $cxname cx + set a "" + set x $cx($level) + set n [llength $x] + for {set i 0} {$i<$n} {incr i} { + set id [lindex $x $i] + if {$i==$n-1} { + set p1 "`--" + set p2 " " + } else { + set p1 "|--" + set p2 "| " + } + append a $prefix$p1$dx($id)\n + if {[info exists cx($id)]} { + append a [append_graph "$prefix$p2" dx cx $id] + } + } + return $a +} + +# Do an EXPLAIN QUERY PLAN test on input $sql with expected results $res +# +# If $res begins with a "\s+QUERY PLAN\n" then it is assumed to be the +# complete graph which must match the output of [query_plan_graph $sql] +# exactly. +# +# If $res does not begin with "\s+QUERY PLAN\n" then take it is a string +# that must be found somewhere in the query plan output. +# +proc do_eqp_test {name sql res} { + if {[regexp {^\s+QUERY PLAN\n} $res]} { + uplevel do_test $name [list [list query_plan_graph $sql]] [list $res] + } else { + if {[string index $res 0]!="/"} { + set res "/*$res*/" + } + uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res] + } +} + + +#------------------------------------------------------------------------- +# Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST +# +# Where switches are: +# +# -errorformat FMTSTRING +# -count +# -query SQL +# -tclquery TCL +# -repair TCL +# +proc do_select_tests {prefix args} { + + set testlist [lindex $args end] + set switches [lrange $args 0 end-1] + + set errfmt "" + set countonly 0 + set tclquery "" + set repair "" + + for {set i 0} {$i < [llength $switches]} {incr i} { + set s [lindex $switches $i] + set n [string length $s] + if {$n>=2 && [string equal -length $n $s "-query"]} { + set tclquery [list execsql [lindex $switches [incr i]]] + } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} { + set tclquery [lindex $switches [incr i]] + } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} { + set errfmt [lindex $switches [incr i]] + } elseif {$n>=2 && [string equal -length $n $s "-repair"]} { + set repair [lindex $switches [incr i]] + } elseif {$n>=2 && [string equal -length $n $s "-count"]} { + set countonly 1 + } else { + error "unknown switch: $s" + } + } + + if {$countonly && $errfmt!=""} { + error "Cannot use -count and -errorformat together" + } + set nTestlist [llength $testlist] + if {$nTestlist%3 || $nTestlist==0 } { + error "SELECT test list contains [llength $testlist] elements" + } + + eval $repair + foreach {tn sql res} $testlist { + if {$tclquery != ""} { + execsql $sql + uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]] + } elseif {$countonly} { + set nRow 0 + db eval $sql {incr nRow} + uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res] + } elseif {$errfmt==""} { + uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]] + } else { + set res [list 1 [string trim [format $errfmt {*}$res]]] + uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res] + } + eval $repair + } + +} + +proc delete_all_data {} { + db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} { + db eval "DELETE FROM '[string map {' ''} $t]'" + } +} + +# Run an SQL script. +# Return the number of microseconds per statement. +# +proc speed_trial {name numstmt units sql} { + output2 -nonewline [format {%-21.21s } $name...] + flush stdout + set speed [time {sqlite3_exec_nr db $sql}] + set tm [lindex $speed 0] + if {$tm == 0} { + set rate [format %20s "many"] + } else { + set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] + } + set u2 $units/s + output2 [format {%12d uS %s %s} $tm $rate $u2] + global total_time + set total_time [expr {$total_time+$tm}] + lappend ::speed_trial_times $name $tm +} +proc speed_trial_tcl {name numstmt units script} { + output2 -nonewline [format {%-21.21s } $name...] + flush stdout + set speed [time {eval $script}] + set tm [lindex $speed 0] + if {$tm == 0} { + set rate [format %20s "many"] + } else { + set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] + } + set u2 $units/s + output2 [format {%12d uS %s %s} $tm $rate $u2] + global total_time + set total_time [expr {$total_time+$tm}] + lappend ::speed_trial_times $name $tm +} +proc speed_trial_init {name} { + global total_time + set total_time 0 + set ::speed_trial_times [list] + sqlite3 versdb :memory: + set vers [versdb one {SELECT sqlite_source_id()}] + versdb close + output2 "SQLite $vers" +} +proc speed_trial_summary {name} { + global total_time + output2 [format {%-21.21s %12d uS TOTAL} $name $total_time] + + if { 0 } { + sqlite3 versdb :memory: + set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0] + versdb close + output2 "CREATE TABLE IF NOT EXISTS time(version, script, test, us);" + foreach {test us} $::speed_trial_times { + output2 "INSERT INTO time VALUES('$vers', '$name', '$test', $us);" + } + } +} + +# Clear out left-over configuration setup from the end of a test +# +proc finish_test_precleanup {} { + catch {db1 close} + catch {db2 close} + catch {db3 close} + catch {unregister_devsim} + catch {unregister_jt_vfs} + catch {unregister_demovfs} +} + +# Run this routine last +# +proc finish_test {} { + global argv + finish_test_precleanup + if {[llength $argv]>0} { + # If additional test scripts are specified on the command-line, + # run them also, before quitting. + proc finish_test {} { + finish_test_precleanup + return + } + foreach extra $argv { + puts "Running \"$extra\"" + db_delete_and_reopen + uplevel #0 source $extra + } + } + catch {db close} + if {0==[info exists ::SLAVE]} { finalize_testing } +} +proc finalize_testing {} { + global sqlite_open_file_count + + set omitList [set_test_counter omit_list] + + catch {db close} + catch {db2 close} + catch {db3 close} + + vfs_unlink_test + sqlite3 db {} + # sqlite3_clear_tsd_memdebug + db close + sqlite3_reset_auto_extension + + sqlite3_soft_heap_limit64 0 + sqlite3_hard_heap_limit64 0 + set nTest [incr_ntest] + set nErr [set_test_counter errors] + + set nKnown 0 + if {[file readable known-problems.txt]} { + set fd [open known-problems.txt] + set content [read $fd] + close $fd + foreach x $content {set known_error($x) 1} + foreach x [set_test_counter fail_list] { + if {[info exists known_error($x)]} {incr nKnown} + } + } + if {$nKnown>0} { + output2 "[expr {$nErr-$nKnown}] new errors and $nKnown known errors\ + out of $nTest tests" + } else { + set cpuinfo {} + if {[catch {exec hostname} hname]==0} {set cpuinfo [string trim $hname]} + append cpuinfo " $::tcl_platform(os)" + append cpuinfo " [expr {$::tcl_platform(pointerSize)*8}]-bit" + append cpuinfo " [string map {E -e} $::tcl_platform(byteOrder)]" + output2 "SQLite [sqlite3 -sourceid]" + output2 "$nErr errors out of $nTest tests on $cpuinfo" + } + if {$nErr>$nKnown} { + output2 -nonewline "!Failures on these tests:" + foreach x [set_test_counter fail_list] { + if {![info exists known_error($x)]} {output2 -nonewline " $x"} + } + output2 "" + } + foreach warning [set_test_counter warn_list] { + output2 "Warning: $warning" + } + run_thread_tests 1 + if {[llength $omitList]>0} { + output2 "Omitted test cases:" + set prec {} + foreach {rec} [lsort $omitList] { + if {$rec==$prec} continue + set prec $rec + output2 [format {. %-12s %s} [lindex $rec 0] [lindex $rec 1]] + } + } + if {$nErr>0 && ![working_64bit_int]} { + output2 "******************************************************************" + output2 "N.B.: The version of TCL that you used to build this test harness" + output2 "is defective in that it does not support 64-bit integers. Some or" + output2 "all of the test failures above might be a result from this defect" + output2 "in your TCL build." + output2 "******************************************************************" + } + if {$::cmdlinearg(binarylog)} { + vfslog finalize binarylog + } + if {$sqlite_open_file_count} { + output2 "$sqlite_open_file_count files were left open" + incr nErr + } + if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 || + [sqlite3_memory_used]>0} { + output2 "Unfreed memory: [sqlite3_memory_used] bytes in\ + [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations" + incr nErr + ifcapable mem5||(mem3&&debug) { + output2 "Writing unfreed memory log to \"./memleak.txt\"" + sqlite3_memdebug_dump ./memleak.txt + } + } else { + output2 "All memory allocations freed - no leaks" + ifcapable mem5 { + sqlite3_memdebug_dump ./memusage.txt + } + } + show_memstats + output2 "Maximum memory usage: [sqlite3_memory_highwater 1] bytes" + output2 "Current memory usage: [sqlite3_memory_highwater] bytes" + if {[info commands sqlite3_memdebug_malloc_count] ne ""} { + output2 "Number of malloc() : [sqlite3_memdebug_malloc_count] calls" + } + if {$::cmdlinearg(malloctrace)} { + output2 "Writing mallocs.tcl..." + memdebug_log_sql mallocs.tcl + sqlite3_memdebug_log stop + sqlite3_memdebug_log clear + if {[sqlite3_memory_used]>0} { + output2 "Writing leaks.tcl..." + sqlite3_memdebug_log sync + memdebug_log_sql leaks.tcl + } + } + if {[info commands vdbe_coverage]!=""} { + vdbe_coverage_report + } + foreach f [glob -nocomplain test.db-*-journal] { + forcedelete $f + } + foreach f [glob -nocomplain test.db-mj*] { + forcedelete $f + } + exit [expr {$nErr>0}] +} + +proc vdbe_coverage_report {} { + puts "Writing vdbe coverage report to vdbe_coverage.txt" + set lSrc [list] + set iLine 0 + if {[file exists ../sqlite3.c]} { + set fd [open ../sqlite3.c] + set iLine + while { ![eof $fd] } { + set line [gets $fd] + incr iLine + if {[regexp {^/\** Begin file (.*\.c) \**/} $line -> file]} { + lappend lSrc [list $iLine $file] + } + } + close $fd + } + set fd [open vdbe_coverage.txt w] + foreach miss [vdbe_coverage report] { + foreach {line branch never} $miss {} + set nextfile "" + while {[llength $lSrc]>0 && [lindex $lSrc 0 0] < $line} { + set nextfile [lindex $lSrc 0 1] + set lSrc [lrange $lSrc 1 end] + } + if {$nextfile != ""} { + puts $fd "" + puts $fd "### $nextfile ###" + } + puts $fd "Vdbe branch $line: never $never (path $branch)" + } + close $fd +} + +# Display memory statistics for analysis and debugging purposes. +# +proc show_memstats {} { + set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0] + set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0] + set val [format {now %10d max %10d max-size %10d} \ + [lindex $x 1] [lindex $x 2] [lindex $y 2]] + output1 "Memory used: $val" + set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] + set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] + output1 "Allocation count: $val" + set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0] + set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0] + set val [format {now %10d max %10d max-size %10d} \ + [lindex $x 1] [lindex $x 2] [lindex $y 2]] + output1 "Page-cache used: $val" + set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0] + set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] + output1 "Page-cache overflow: $val" + ifcapable yytrackmaxstackdepth { + set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0] + set val [format { max %10d} [lindex $x 2]] + output2 "Parser stack depth: $val" + } +} + +# A procedure to execute SQL +# +proc execsql {sql {db db}} { + # puts "SQL = $sql" + uplevel [list $db eval $sql] +} +proc execsql_timed {sql {db db}} { + set tm [time { + set x [uplevel [list $db eval $sql]] + } 1] + set tm [lindex $tm 0] + output1 -nonewline " ([expr {$tm*0.001}]ms) " + set x +} + +# Execute SQL and catch exceptions. +# +proc catchsql {sql {db db}} { + # puts "SQL = $sql" + set r [catch [list uplevel [list $db eval $sql]] msg] + lappend r $msg + return $r +} + +# Do an VDBE code dump on the SQL given +# +proc explain {sql {db db}} { + output2 "" + output2 "addr opcode p1 p2 p3 p4 p5 #" + output2 "---- ------------ ------ ------ ------ --------------- -- -" + $db eval "explain $sql" {} { + output2 [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \ + $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment + ] + } +} + +proc explain_i {sql {db db}} { + output2 "" + output2 "addr opcode p1 p2 p3 p4 p5 #" + output2 "---- ------------ ------ ------ ------ ---------------- -- -" + + + # Set up colors for the different opcodes. Scheme is as follows: + # + # Red: Opcodes that write to a b-tree. + # Blue: Opcodes that reposition or seek a cursor. + # Green: The ResultRow opcode. + # + if { [catch {fconfigure stdout -mode}]==0 } { + set R "\033\[31;1m" ;# Red fg + set G "\033\[32;1m" ;# Green fg + set B "\033\[34;1m" ;# Red fg + set D "\033\[39;0m" ;# Default fg + } else { + set R "" + set G "" + set B "" + set D "" + } + foreach opcode { + Seek SeekGE SeekGT SeekLE SeekLT NotFound Last Rewind + NoConflict Next Prev VNext VPrev VFilter + SorterSort SorterNext NextIfOpen + } { + set color($opcode) $B + } + foreach opcode {ResultRow} { + set color($opcode) $G + } + foreach opcode {IdxInsert Insert Delete IdxDelete} { + set color($opcode) $R + } + + set bSeenGoto 0 + $db eval "explain $sql" {} { + set x($addr) 0 + set op($addr) $opcode + + if {$opcode == "Goto" && ($bSeenGoto==0 || ($p2 > $addr+10))} { + set linebreak($p2) 1 + set bSeenGoto 1 + } + + if {$opcode=="Once"} { + for {set i $addr} {$i<$p2} {incr i} { + set star($i) $addr + } + } + + if {$opcode=="Next" || $opcode=="Prev" + || $opcode=="VNext" || $opcode=="VPrev" + || $opcode=="SorterNext" || $opcode=="NextIfOpen" + } { + for {set i $p2} {$i<$addr} {incr i} { + incr x($i) 2 + } + } + + if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} { + for {set i [expr $p2+1]} {$i<$addr} {incr i} { + incr x($i) 2 + } + } + + if {$opcode == "Halt" && $comment == "End of coroutine"} { + set linebreak([expr $addr+1]) 1 + } + } + + $db eval "explain $sql" {} { + if {[info exists linebreak($addr)]} { + output2 "" + } + set I [string repeat " " $x($addr)] + + if {[info exists star($addr)]} { + set ii [expr $x($star($addr))] + append I " " + set I [string replace $I $ii $ii *] + } + + set col "" + catch { set col $color($opcode) } + + output2 [format {%-4d %s%s%-12.12s%s %-6d %-6d %-6d % -17s %s %s} \ + $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment + ] + } + output2 "---- ------------ ------ ------ ------ ---------------- -- -" +} + +proc execsql_pp {sql {db db}} { + set nCol 0 + $db eval $sql A { + if {$nCol==0} { + set nCol [llength $A(*)] + foreach c $A(*) { + set aWidth($c) [string length $c] + lappend data $c + } + } + foreach c $A(*) { + set n [string length $A($c)] + if {$n > $aWidth($c)} { + set aWidth($c) $n + } + lappend data $A($c) + } + } + if {$nCol>0} { + set nTotal 0 + foreach e [array names aWidth] { incr nTotal $aWidth($e) } + incr nTotal [expr ($nCol-1) * 3] + incr nTotal 4 + + set fmt "" + foreach c $A(*) { + lappend fmt "% -$aWidth($c)s" + } + set fmt "| [join $fmt { | }] |" + + puts [string repeat - $nTotal] + for {set i 0} {$i < [llength $data]} {incr i $nCol} { + set vals [lrange $data $i [expr $i+$nCol-1]] + puts [format $fmt {*}$vals] + if {$i==0} { puts [string repeat - $nTotal] } + } + puts [string repeat - $nTotal] + } +} + + +# Show the VDBE program for an SQL statement but omit the Trace +# opcode at the beginning. This procedure can be used to prove +# that different SQL statements generate exactly the same VDBE code. +# +proc explain_no_trace {sql} { + set tr [db eval "EXPLAIN $sql"] + return [lrange $tr 7 end] +} + +# Another procedure to execute SQL. This one includes the field +# names in the returned list. +# +proc execsql2 {sql} { + set result {} + db eval $sql data { + foreach f $data(*) { + lappend result $f $data($f) + } + } + return $result +} + +# Use a temporary in-memory database to execute SQL statements +# +proc memdbsql {sql} { + sqlite3 memdb :memory: + set result [memdb eval $sql] + memdb close + return $result +} + +# Use the non-callback API to execute multiple SQL statements +# +proc stepsql {dbptr sql} { + set sql [string trim $sql] + set r 0 + while {[string length $sql]>0} { + if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} { + return [list 1 $vm] + } + set sql [string trim $sqltail] +# while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} { +# foreach v $VAL {lappend r $v} +# } + while {[sqlite3_step $vm]=="SQLITE_ROW"} { + for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} { + lappend r [sqlite3_column_text $vm $i] + } + } + if {[catch {sqlite3_finalize $vm} errmsg]} { + return [list 1 $errmsg] + } + } + return $r +} + +# Do an integrity check of the entire database +# +proc integrity_check {name {db db}} { + ifcapable integrityck { + do_test $name [list execsql {PRAGMA integrity_check} $db] {ok} + } +} + +# Check the extended error code +# +proc verify_ex_errcode {name expected {db db}} { + do_test $name [list sqlite3_extended_errcode $db] $expected +} + + +# Return true if the SQL statement passed as the second argument uses a +# statement transaction. +# +proc sql_uses_stmt {db sql} { + set stmt [sqlite3_prepare $db $sql -1 dummy] + set uses [uses_stmt_journal $stmt] + sqlite3_finalize $stmt + return $uses +} + +proc fix_ifcapable_expr {expr} { + set ret "" + set state 0 + for {set i 0} {$i < [string length $expr]} {incr i} { + set char [string range $expr $i $i] + set newstate [expr {[string is alnum $char] || $char eq "_"}] + if {$newstate && !$state} { + append ret {$::sqlite_options(} + } + if {!$newstate && $state} { + append ret ) + } + append ret $char + set state $newstate + } + if {$state} {append ret )} + return $ret +} + +# Returns non-zero if the capabilities are present; zero otherwise. +# +proc capable {expr} { + set e [fix_ifcapable_expr $expr]; return [expr ($e)] +} + +# Evaluate a boolean expression of capabilities. If true, execute the +# code. Omit the code if false. +# +proc ifcapable {expr code {else ""} {elsecode ""}} { + #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2 + set e2 [fix_ifcapable_expr $expr] + if ($e2) { + set c [catch {uplevel 1 $code} r] + } else { + set c [catch {uplevel 1 $elsecode} r] + } + return -code $c $r +} + +# This proc execs a seperate process that crashes midway through executing +# the SQL script $sql on database test.db. +# +# The crash occurs during a sync() of file $crashfile. When the crash +# occurs a random subset of all unsynced writes made by the process are +# written into the files on disk. Argument $crashdelay indicates the +# number of file syncs to wait before crashing. +# +# The return value is a list of two elements. The first element is a +# boolean, indicating whether or not the process actually crashed or +# reported some other error. The second element in the returned list is the +# error message. This is "child process exited abnormally" if the crash +# occurred. +# +# crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql +# +proc crashsql {args} { + + set blocksize "" + set crashdelay 1 + set prngseed 0 + set opendb { sqlite3 db test.db -vfs crash } + set tclbody {} + set crashfile "" + set dc "" + set dfltvfs 0 + set sql [lindex $args end] + + for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} { + set z [lindex $args $ii] + set n [string length $z] + set z2 [lindex $args [expr $ii+1]] + + if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \ + elseif {$n>1 && [string first $z -opendb]==0} {set opendb $z2} \ + elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \ + elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \ + elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \ + elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \ + elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" }\ + elseif {$n>1 && [string first $z -dfltvfs]==0} {set dfltvfs $z2 }\ + else { error "Unrecognized option: $z" } + } + + if {$crashfile eq ""} { + error "Compulsory option -file missing" + } + + # $crashfile gets compared to the native filename in + # cfSync(), which can be different then what TCL uses by + # default, so here we force it to the "nativename" format. + set cfile [string map {\\ \\\\} [file nativename [file join [get_pwd] $crashfile]]] + + set f [open crash.tcl w] + puts $f "sqlite3_initialize ; sqlite3_shutdown" + puts $f "catch { install_malloc_faultsim 1 }" + puts $f "sqlite3_crash_enable 1 $dfltvfs" + puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile" + puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" + puts $f "autoinstall_test_functions" + + # This block sets the cache size of the main database to 10 + # pages. This is done in case the build is configured to omit + # "PRAGMA cache_size". + if {$opendb!=""} { + puts $f $opendb + puts $f {db eval {SELECT * FROM sqlite_master;}} + puts $f {set bt [btree_from_db db]} + puts $f {btree_set_cache_size $bt 10} + } + + if {$prngseed} { + set seed [expr {$prngseed%10007+1}] + # puts seed=$seed + puts $f "db eval {SELECT randomblob($seed)}" + } + + if {[string length $tclbody]>0} { + puts $f $tclbody + } + if {[string length $sql]>0} { + puts $f "db eval {" + puts $f "$sql" + puts $f "}" + } + close $f + set r [catch { + exec [info nameofexec] crash.tcl >@stdout 2>@stdout + } msg] + + # Windows/ActiveState TCL returns a slightly different + # error message. We map that to the expected message + # so that we don't have to change all of the test + # cases. + if {$::tcl_platform(platform)=="windows"} { + if {$msg=="child killed: unknown signal"} { + set msg "child process exited abnormally" + } + } + if {$r && [string match {*ERROR: LeakSanitizer*} $msg]} { + set msg "child process exited abnormally" + } + + lappend r $msg +} + +# crash_on_write ?-devchar DEVCHAR? CRASHDELAY SQL +# +proc crash_on_write {args} { + + set nArg [llength $args] + if {$nArg<2 || $nArg%2} { + error "bad args: $args" + } + set zSql [lindex $args end] + set nDelay [lindex $args end-1] + + set devchar {} + for {set ii 0} {$ii < $nArg-2} {incr ii 2} { + set opt [lindex $args $ii] + switch -- [lindex $args $ii] { + -devchar { + set devchar [lindex $args [expr $ii+1]] + } + + default { error "unrecognized option: $opt" } + } + } + + set f [open crash.tcl w] + puts $f "sqlite3_crash_on_write $nDelay" + puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" + puts $f "sqlite3 db test.db -vfs writecrash" + puts $f "db eval {$zSql}" + puts $f "set {} {}" + + close $f + set r [catch { + exec [info nameofexec] crash.tcl >@stdout + } msg] + + # Windows/ActiveState TCL returns a slightly different + # error message. We map that to the expected message + # so that we don't have to change all of the test + # cases. + if {$::tcl_platform(platform)=="windows"} { + if {$msg=="child killed: unknown signal"} { + set msg "child process exited abnormally" + } + } + + lappend r $msg +} + +proc run_ioerr_prep {} { + set ::sqlite_io_error_pending 0 + catch {db close} + catch {db2 close} + catch {forcedelete test.db} + catch {forcedelete test.db-journal} + catch {forcedelete test2.db} + catch {forcedelete test2.db-journal} + set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] + sqlite3_extended_result_codes $::DB $::ioerropts(-erc) + if {[info exists ::ioerropts(-tclprep)]} { + eval $::ioerropts(-tclprep) + } + if {[info exists ::ioerropts(-sqlprep)]} { + execsql $::ioerropts(-sqlprep) + } + expr 0 +} + +# Usage: do_ioerr_test <test number> <options...> +# +# This proc is used to implement test cases that check that IO errors +# are correctly handled. The first argument, <test number>, is an integer +# used to name the tests executed by this proc. Options are as follows: +# +# -tclprep TCL script to run to prepare test. +# -sqlprep SQL script to run to prepare test. +# -tclbody TCL script to run with IO error simulation. +# -sqlbody TCL script to run with IO error simulation. +# -exclude List of 'N' values not to test. +# -erc Use extended result codes +# -persist Make simulated I/O errors persistent +# -start Value of 'N' to begin with (default 1) +# +# -cksum Boolean. If true, test that the database does +# not change during the execution of the test case. +# +proc do_ioerr_test {testname args} { + + set ::ioerropts(-start) 1 + set ::ioerropts(-cksum) 0 + set ::ioerropts(-erc) 0 + set ::ioerropts(-count) 100000000 + set ::ioerropts(-persist) 1 + set ::ioerropts(-ckrefcount) 0 + set ::ioerropts(-restoreprng) 1 + array set ::ioerropts $args + + # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are + # a couple of obscure IO errors that do not return them. + set ::ioerropts(-erc) 0 + + # Create a single TCL script from the TCL and SQL specified + # as the body of the test. + set ::ioerrorbody {} + if {[info exists ::ioerropts(-tclbody)]} { + append ::ioerrorbody "$::ioerropts(-tclbody)\n" + } + if {[info exists ::ioerropts(-sqlbody)]} { + append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}" + } + + save_prng_state + if {$::ioerropts(-cksum)} { + run_ioerr_prep + eval $::ioerrorbody + set ::goodcksum [cksum] + } + + set ::go 1 + #reset_prng_state + for {set n $::ioerropts(-start)} {$::go} {incr n} { + set ::TN $n + incr ::ioerropts(-count) -1 + if {$::ioerropts(-count)<0} break + + # Skip this IO error if it was specified with the "-exclude" option. + if {[info exists ::ioerropts(-exclude)]} { + if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue + } + if {$::ioerropts(-restoreprng)} { + restore_prng_state + } + + # Delete the files test.db and test2.db, then execute the TCL and + # SQL (in that order) to prepare for the test case. + do_test $testname.$n.1 { + run_ioerr_prep + } {0} + + # Read the 'checksum' of the database. + if {$::ioerropts(-cksum)} { + set ::checksum [cksum] + } + + # Set the Nth IO error to fail. + do_test $testname.$n.2 [subst { + set ::sqlite_io_error_persist $::ioerropts(-persist) + set ::sqlite_io_error_pending $n + }] $n + + # Execute the TCL script created for the body of this test. If + # at least N IO operations performed by SQLite as a result of + # the script, the Nth will fail. + do_test $testname.$n.3 { + set ::sqlite_io_error_hit 0 + set ::sqlite_io_error_hardhit 0 + set r [catch $::ioerrorbody msg] + set ::errseen $r + if {[info commands db]!=""} { + set rc [sqlite3_errcode db] + if {$::ioerropts(-erc)} { + # If we are in extended result code mode, make sure all of the + # IOERRs we get back really do have their extended code values. + # If an extended result code is returned, the sqlite3_errcode + # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn + # where nnnn is a number + if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} { + return $rc + } + } else { + # If we are not in extended result code mode, make sure no + # extended error codes are returned. + if {[regexp {\+\d} $rc]} { + return $rc + } + } + } + # The test repeats as long as $::go is non-zero. $::go starts out + # as 1. When a test runs to completion without hitting an I/O + # error, that means there is no point in continuing with this test + # case so set $::go to zero. + # + if {$::sqlite_io_error_pending>0} { + set ::go 0 + set q 0 + set ::sqlite_io_error_pending 0 + } else { + set q 1 + } + + set s [expr $::sqlite_io_error_hit==0] + if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} { + set r 1 + } + set ::sqlite_io_error_hit 0 + + # One of two things must have happened. either + # 1. We never hit the IO error and the SQL returned OK + # 2. An IO error was hit and the SQL failed + # + #puts "s=$s r=$r q=$q" + expr { ($s && !$r && !$q) || (!$s && $r && $q) } + } {1} + + set ::sqlite_io_error_hit 0 + set ::sqlite_io_error_pending 0 + + # Check that no page references were leaked. There should be + # a single reference if there is still an active transaction, + # or zero otherwise. + # + # UPDATE: If the IO error occurs after a 'BEGIN' but before any + # locks are established on database files (i.e. if the error + # occurs while attempting to detect a hot-journal file), then + # there may 0 page references and an active transaction according + # to [sqlite3_get_autocommit]. + # + if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} { + do_test $testname.$n.4 { + set bt [btree_from_db db] + db_enter db + array set stats [btree_pager_stats $bt] + db_leave db + set nRef $stats(ref) + expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)} + } {1} + } + + # If there is an open database handle and no open transaction, + # and the pager is not running in exclusive-locking mode, + # check that the pager is in "unlocked" state. Theoretically, + # if a call to xUnlock() failed due to an IO error the underlying + # file may still be locked. + # + ifcapable pragma { + if { [info commands db] ne "" + && $::ioerropts(-ckrefcount) + && [db one {pragma locking_mode}] eq "normal" + && [sqlite3_get_autocommit db] + } { + do_test $testname.$n.5 { + set bt [btree_from_db db] + db_enter db + array set stats [btree_pager_stats $bt] + db_leave db + set stats(state) + } 0 + } + } + + # If an IO error occurred, then the checksum of the database should + # be the same as before the script that caused the IO error was run. + # + if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} { + do_test $testname.$n.6 { + catch {db close} + catch {db2 close} + set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] + set nowcksum [cksum] + set res [expr {$nowcksum==$::checksum || $nowcksum==$::goodcksum}] + if {$res==0} { + output2 "now=$nowcksum" + output2 "the=$::checksum" + output2 "fwd=$::goodcksum" + } + set res + } 1 + } + + set ::sqlite_io_error_hardhit 0 + set ::sqlite_io_error_pending 0 + if {[info exists ::ioerropts(-cleanup)]} { + catch $::ioerropts(-cleanup) + } + } + set ::sqlite_io_error_pending 0 + set ::sqlite_io_error_persist 0 + unset ::ioerropts +} + +# Return a checksum based on the contents of the main database associated +# with connection $db +# +proc cksum {{db db}} { + set txt [$db eval { + SELECT name, type, sql FROM sqlite_master order by name + }]\n + foreach tbl [$db eval { + SELECT name FROM sqlite_master WHERE type='table' order by name + }] { + append txt [$db eval "SELECT * FROM $tbl"]\n + } + foreach prag {default_synchronous default_cache_size} { + append txt $prag-[$db eval "PRAGMA $prag"]\n + } + set cksum [string length $txt]-[md5 $txt] + # puts $cksum-[file size test.db] + return $cksum +} + +# Generate a checksum based on the contents of the main and temp tables +# database $db. If the checksum of two databases is the same, and the +# integrity-check passes for both, the two databases are identical. +# +proc allcksum {{db db}} { + set ret [list] + ifcapable tempdb { + set sql { + SELECT name FROM sqlite_master WHERE type = 'table' UNION + SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION + SELECT 'sqlite_master' UNION + SELECT 'sqlite_temp_master' ORDER BY 1 + } + } else { + set sql { + SELECT name FROM sqlite_master WHERE type = 'table' UNION + SELECT 'sqlite_master' ORDER BY 1 + } + } + set tbllist [$db eval $sql] + set txt {} + foreach tbl $tbllist { + append txt [$db eval "SELECT * FROM $tbl"] + } + foreach prag {default_cache_size} { + append txt $prag-[$db eval "PRAGMA $prag"]\n + } + # puts txt=$txt + return [md5 $txt] +} + +# Generate a checksum based on the contents of a single database with +# a database connection. The name of the database is $dbname. +# Examples of $dbname are "temp" or "main". +# +proc dbcksum {db dbname} { + if {$dbname=="temp"} { + set master sqlite_temp_master + } else { + set master $dbname.sqlite_master + } + set alltab [$db eval "SELECT name FROM $master WHERE type='table'"] + set txt [$db eval "SELECT * FROM $master"]\n + foreach tab $alltab { + append txt [$db eval "SELECT * FROM $dbname.$tab"]\n + } + return [md5 $txt] +} + +proc memdebug_log_sql {filename} { + + set data [sqlite3_memdebug_log dump] + set nFrame [expr [llength [lindex $data 0]]-2] + if {$nFrame < 0} { return "" } + + set database temp + + set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);" + + set sql "" + foreach e $data { + set nCall [lindex $e 0] + set nByte [lindex $e 1] + set lStack [lrange $e 2 end] + append sql "INSERT INTO ${database}.malloc VALUES" + append sql "('test', $nCall, $nByte, '$lStack');\n" + foreach f $lStack { + set frames($f) 1 + } + } + + set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n" + set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n" + + set pid [pid] + + foreach f [array names frames] { + set addr [format %x $f] + set cmd "eu-addr2line --pid=$pid $addr" + set line [eval exec $cmd] + append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n" + + set file [lindex [split $line :] 0] + set files($file) 1 + } + + foreach f [array names files] { + set contents "" + catch { + set fd [open $f] + set contents [read $fd] + close $fd + } + set contents [string map {' ''} $contents] + append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n" + } + + set escaped "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;" + set escaped [string map [list "{" "\\{" "}" "\\}" "\\" "\\\\"] $escaped] + + set fd [open $filename w] + puts $fd "set BUILTIN {" + puts $fd $escaped + puts $fd "}" + puts $fd {set BUILTIN [string map [list "\\{" "{" "\\}" "}" "\\\\" "\\"] $BUILTIN]} + set mtv [open $::testdir/malloctraceviewer.tcl] + set txt [read $mtv] + close $mtv + puts $fd $txt + close $fd +} + +# Drop all tables in database [db] +proc drop_all_tables {{db db}} { + ifcapable trigger&&foreignkey { + set pk [$db one "PRAGMA foreign_keys"] + $db eval "PRAGMA foreign_keys = OFF" + } + foreach {idx name file} [db eval {PRAGMA database_list}] { + if {$idx==1} { + set master sqlite_temp_master + } else { + set master $name.sqlite_master + } + foreach {t type} [$db eval " + SELECT name, type FROM $master + WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X' + "] { + $db eval "DROP $type \"$t\"" + } + } + ifcapable trigger&&foreignkey { + $db eval "PRAGMA foreign_keys = $pk" + } +} + +# Drop all auxiliary indexes from the main database opened by handle [db]. +# +proc drop_all_indexes {{db db}} { + set L [$db eval { + SELECT name FROM sqlite_master WHERE type='index' AND sql LIKE 'create%' + }] + foreach idx $L { $db eval "DROP INDEX $idx" } +} + + +#------------------------------------------------------------------------- +# If a test script is executed with global variable $::G(perm:name) set to +# "wal", then the tests are run in WAL mode. Otherwise, they should be run +# in rollback mode. The following Tcl procs are used to make this less +# intrusive: +# +# wal_set_journal_mode ?DB? +# +# If running a WAL test, execute "PRAGMA journal_mode = wal" using +# connection handle DB. Otherwise, this command is a no-op. +# +# wal_check_journal_mode TESTNAME ?DB? +# +# If running a WAL test, execute a tests case that fails if the main +# database for connection handle DB is not currently a WAL database. +# Otherwise (if not running a WAL permutation) this is a no-op. +# +# wal_is_wal_mode +# +# Returns true if this test should be run in WAL mode. False otherwise. +# +proc wal_is_wal_mode {} { + expr {[permutation] eq "wal"} +} +proc wal_set_journal_mode {{db db}} { + if { [wal_is_wal_mode] } { + $db eval "PRAGMA journal_mode = WAL" + } +} +proc wal_check_journal_mode {testname {db db}} { + if { [wal_is_wal_mode] } { + $db eval { SELECT * FROM sqlite_master } + do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal} + } +} + +proc wal_is_capable {} { + ifcapable !wal { return 0 } + if {[permutation]=="journaltest"} { return 0 } + return 1 +} + +proc permutation {} { + set perm "" + catch {set perm $::G(perm:name)} + set perm +} +proc presql {} { + set presql "" + catch {set presql $::G(perm:presql)} + set presql +} + +proc isquick {} { + set ret 0 + catch {set ret $::G(isquick)} + set ret +} + +#------------------------------------------------------------------------- +# +proc slave_test_script {script} { + + # Create the interpreter used to run the test script. + interp create tinterp + + # Populate some global variables that tester.tcl expects to see. + foreach {var value} [list \ + ::argv0 $::argv0 \ + ::argv {} \ + ::SLAVE 1 \ + ] { + interp eval tinterp [list set $var $value] + } + + # If output is being copied into a file, share the file-descriptor with + # the interpreter. + if {[info exists ::G(output_fd)]} { + interp share {} $::G(output_fd) tinterp + } + + # The alias used to access the global test counters. + tinterp alias set_test_counter set_test_counter + + # Set up the ::cmdlinearg array in the slave. + interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]] + + # Set up the ::G array in the slave. + interp eval tinterp [list array set ::G [array get ::G]] + + # Load the various test interfaces implemented in C. + load_testfixture_extensions tinterp + + # Run the test script. + interp eval tinterp $script + + # Check if the interpreter call [run_thread_tests] + if { [interp eval tinterp {info exists ::run_thread_tests_called}] } { + set ::run_thread_tests_called 1 + } + + # Delete the interpreter used to run the test script. + interp delete tinterp +} + +proc slave_test_file {zFile} { + set tail [file tail $zFile] + + if {[info exists ::G(start:permutation)]} { + if {[permutation] != $::G(start:permutation)} return + unset ::G(start:permutation) + } + if {[info exists ::G(start:file)]} { + if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return + unset ::G(start:file) + } + + # Remember the value of the shared-cache setting. So that it is possible + # to check afterwards that it was not modified by the test script. + # + ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] } + + # Run the test script in a slave interpreter. + # + unset -nocomplain ::run_thread_tests_called + reset_prng_state + set ::sqlite_open_file_count 0 + set time [time { slave_test_script [list source $zFile] }] + set ms [expr [lindex $time 0] / 1000] + + # Test that all files opened by the test script were closed. Omit this + # if the test script has "thread" in its name. The open file counter + # is not thread-safe. + # + if {[info exists ::run_thread_tests_called]==0} { + do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0} + } + set ::sqlite_open_file_count 0 + + # Test that the global "shared-cache" setting was not altered by + # the test script. + # + ifcapable shared_cache { + set res [expr {[sqlite3_enable_shared_cache] == $scs}] + do_test ${tail}-sharedcachesetting [list set {} $res] 1 + } + + # Add some info to the output. + # + output2 "Time: $tail $ms ms" + show_memstats +} + +# Open a new connection on database test.db and execute the SQL script +# supplied as an argument. Before returning, close the new conection and +# restore the 4 byte fields starting at header offsets 28, 92 and 96 +# to the values they held before the SQL was executed. This simulates +# a write by a pre-3.7.0 client. +# +proc sql36231 {sql} { + set B [hexio_read test.db 92 8] + set A [hexio_read test.db 28 4] + sqlite3 db36231 test.db + catch { db36231 func a_string a_string } + execsql $sql db36231 + db36231 close + hexio_write test.db 28 $A + hexio_write test.db 92 $B + return "" +} + +proc db_save {} { + foreach f [glob -nocomplain sv_test.db*] { forcedelete $f } + foreach f [glob -nocomplain test.db*] { + set f2 "sv_$f" + forcecopy $f $f2 + } +} +proc db_save_and_close {} { + db_save + catch { db close } + return "" +} +proc db_restore {} { + foreach f [glob -nocomplain test.db*] { forcedelete $f } + foreach f2 [glob -nocomplain sv_test.db*] { + set f [string range $f2 3 end] + forcecopy $f2 $f + } +} +proc db_restore_and_reopen {{dbfile test.db}} { + catch { db close } + db_restore + sqlite3 db $dbfile +} +proc db_delete_and_reopen {{file test.db}} { + catch { db close } + foreach f [glob -nocomplain test.db*] { forcedelete $f } + sqlite3 db $file +} + +# Close any connections named [db], [db2] or [db3]. Then use sqlite3_config +# to configure the size of the PAGECACHE allocation using the parameters +# provided to this command. Save the old PAGECACHE parameters in a global +# variable so that [test_restore_config_pagecache] can restore the previous +# configuration. +# +# Before returning, reopen connection [db] on file test.db. +# +proc test_set_config_pagecache {sz nPg} { + catch {db close} + catch {db2 close} + catch {db3 close} + + sqlite3_shutdown + set ::old_pagecache_config [sqlite3_config_pagecache $sz $nPg] + sqlite3_initialize + autoinstall_test_functions + reset_db +} + +# Close any connections named [db], [db2] or [db3]. Then use sqlite3_config +# to configure the size of the PAGECACHE allocation to the size saved in +# the global variable by an earlier call to [test_set_config_pagecache]. +# +# Before returning, reopen connection [db] on file test.db. +# +proc test_restore_config_pagecache {} { + catch {db close} + catch {db2 close} + catch {db3 close} + + sqlite3_shutdown + eval sqlite3_config_pagecache $::old_pagecache_config + unset ::old_pagecache_config + sqlite3_initialize + autoinstall_test_functions + sqlite3 db test.db +} + +proc test_binary_name {nm} { + if {$::tcl_platform(platform)=="windows"} { + set ret "$nm.exe" + } else { + set ret $nm + } + file normalize [file join $::cmdlinearg(TESTFIXTURE_HOME) $ret] +} + +proc test_find_binary {nm} { + set ret [test_binary_name $nm] + if {![file executable $ret]} { + finish_test + return "" + } + return $ret +} + +# Find the name of the 'shell' executable (e.g. "sqlite3.exe") to use for +# the tests in shell*.test. If no such executable can be found, invoke +# [finish_test ; return] in the callers context. +# +proc test_find_cli {} { + set prog [test_find_binary sqlite3] + if {$prog==""} { return -code return } + return $prog +} + +# Find invocation of the 'shell' executable (e.g. "sqlite3.exe") to use +# for the tests in shell*.test with optional valgrind prefix when the +# environment variable SQLITE_CLI_VALGRIND_OPT is set. The set value +# operates as follows: +# empty or 0 => no valgrind prefix; +# 1 => valgrind options for memory leak check; +# other => use value as valgrind options. +# If shell not found, invoke [finish_test ; return] in callers context. +# +proc test_cli_invocation {} { + set prog [test_find_binary sqlite3] + if {$prog==""} { return -code return } + set vgrun [expr {[permutation]=="valgrind"}] + if {$vgrun || [info exists ::env(SQLITE_CLI_VALGRIND_OPT)]} { + if {$vgrun} { + set vgo "--quiet" + } else { + set vgo $::env(SQLITE_CLI_VALGRIND_OPT) + } + if {$vgo == 0 || $vgo eq ""} { + return $prog + } elseif {$vgo == 1} { + return "valgrind --quiet --leak-check=yes $prog" + } else { + return "valgrind $vgo $prog" + } + } else { + return $prog + } +} + +# Find the name of the 'sqldiff' executable (e.g. "sqlite3.exe") to use for +# the tests in sqldiff tests. If no such executable can be found, invoke +# [finish_test ; return] in the callers context. +# +proc test_find_sqldiff {} { + set prog [test_find_binary sqldiff] + if {$prog==""} { return -code return } + return $prog +} + +# Call sqlite3_expanded_sql() on all statements associated with database +# connection $db. This sometimes finds use-after-free bugs if run with +# valgrind or address-sanitizer. +proc expand_all_sql {db} { + set stmt "" + while {[set stmt [sqlite3_next_stmt $db $stmt]]!=""} { + sqlite3_expanded_sql $stmt + } +} + + +# If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set +# to non-zero, then set the global variable $AUTOVACUUM to 1. +set AUTOVACUUM $sqlite_options(default_autovacuum) + +# Make sure the FTS enhanced query syntax is disabled. +set sqlite_fts3_enable_parentheses 0 + +# During testing, assume that all database files are well-formed. The +# few test cases that deliberately corrupt database files should rescind +# this setting by invoking "database_can_be_corrupt" +# +database_never_corrupt +extra_schema_checks 1 + +source $testdir/thread_common.tcl +source $testdir/malloc_common.tcl + +set tester_tcl_has_run 1 |