2498 lines
72 KiB
Tcl
2498 lines
72 KiB
Tcl
# 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
|
|
#
|
|
|
|
# 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 echo %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
|
|
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);"
|
|
}
|
|
}
|
|
}
|
|
|
|
# Run this routine last
|
|
#
|
|
proc finish_test {} {
|
|
catch {db close}
|
|
catch {db1 close}
|
|
catch {db2 close}
|
|
catch {db3 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 "---- ------------ ------ ------ ------ ---------------- -- -"
|
|
}
|
|
|
|
# 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
|
|
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[1-5].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 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
|