#pragma ident "%Z%%M% %I% %E% SMI"
# 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.28 2004/02/14 01:39:50 drh Exp $
# Make sure tclsqlite was compiled correctly. Abort now with an
# error message if not.
#
puts stderr "***** BUILD PROBLEM *****"
puts stderr "$argv0 was linked against an older version"
puts stderr "of TCL that does not support Unicode, but uses a header"
puts stderr "Unicode. This combination causes internal errors."
puts stderr "Recompile using a TCL library and header file that match"
puts stderr "and try again.\n**************************"
exit 1
}
} else {
puts stderr "***** BUILD PROBLEM *****"
puts stderr "$argv0 was linked against an newer version"
puts stderr "of TCL that supports Unicode, but uses a header file"
puts stderr "Unicode. This combination causes internal errors."
puts stderr "Recompile using a TCL library and header file that match"
puts stderr "and try again.\n**************************"
exit 1
}
}
# Use the pager codec if it is available
#
rename sqlite sqlite_orig
}
}
}
# Create a test database
#
catch {db close}
if {[info exists ::SETUP_SQL]} {
db eval $::SETUP_SQL
}
# Abort early if this script has been run before.
#
# Set the test counters to zero
#
set failList {}
# Invoke the do_test procedure to run a single test
#
if {$skip_test} {
return
}
} else {
break
}
}
}
if {!$go} return
incr nTest
flush stdout
if {[catch {uplevel #0 "$cmd;\n"} result]} {
puts "\nError: $result"
incr nErr
lappend ::failList $name
puts "\nExpected: \[$expected\]\n Got: \[$result\]"
incr nErr
lappend ::failList $name
} else {
puts " Ok"
}
}
# Invoke this procedure on a test that is probabilistic
# and might fail sometimes.
#
if {$skip_test} {
return
}
} else {
break
}
}
}
if {!$go} return
incr nTest
flush stdout
if {[catch {uplevel #0 "$cmd;\n"} result]} {
puts "\nError: $result"
incr nErr
puts "\nExpected: \[$expected\]\n Got: \[$result\]"
puts "NOTE: The results of the previous test depend on system load"
puts "and processor speed. The test may sometimes fail even if the"
puts "library is working correctly."
incr nProb
} else {
puts " Ok"
}
}
# The procedure uses the special "sqlite_malloc_stat" command
# (which is only available if SQLite is compiled with -DMEMORY_DEBUG=1)
# to see how many malloc()s have not been free()ed. The number
# of surplus malloc()s is stored in the global variable $::Leak.
# If the value in $::Leak grows, it may mean there is a memory leak
# in the library.
#
proc memleak_check {} {
set r [sqlite_malloc_stat]
}
}
# Run this routine last
#
proc finish_test {} {
}
proc finalize_testing {} {
if {$nErr==0} memleak_check
catch {db close}
puts "$nErr errors out of $nTest tests"
puts "Failures on these tests: $::failList"
puts "$nProb probabilistic tests also failed, but this does"
puts "not necessarily indicate a malfunction."
}
if {$sqlite_open_file_count} {
puts "$sqlite_open_file_count files were left open"
incr nErr
}
}
# A procedure to execute SQL
#
# puts "SQL = $sql"
}
# Execute SQL and catch exceptions.
#
# puts "SQL = $sql"
return $r
}
# Do an VDBE code dump on the SQL given
#
puts ""
puts "addr opcode p1 p2 p3 "
puts "---- ------------ ------ ------ ---------------"
$db eval "explain $sql" {} {
}
}
# Another procedure to execute SQL. This one includes the field
# names in the returned list.
#
set result {}
}
}
return $result
}
# Use the non-callback API to execute multiple SQL statements
#
}
}
}
}
return $r
}
# Delete a file or directory
#
proc forcedelete {filename} {
}
}
# Do an integrity check of the entire database
#
} {ok}
}