AryaWu/sqlite
0
1# 2001 September 152#3# The author disclaims copyright to this source code. In place of4# a legal notice, here is a blessing:5#6# May you do good and not evil.7# May you find forgiveness for yourself and forgive others.8# May you share freely, never taking more than you give.9#10#***********************************************************************11# This file implements some common TCL routines used for regression12# testing the SQLite library13#14# $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $15 16#-------------------------------------------------------------------------17# The commands provided by the code in this file to help with creating18# test cases are as follows:19#20# Commands to manipulate the db and the file-system at a high level:21#22# is_relative_file23# test_pwd24# get_pwd25# copy_file FROM TO26# delete_file FILENAME27# drop_all_tables ?DB?28# drop_all_indexes ?DB?29# forcecopy FROM TO30# forcedelete FILENAME31#32# Test the capability of the SQLite version built into the interpreter to33# determine if a specific test can be run:34#35# capable EXPR36# ifcapable EXPR37#38# Calulate checksums based on database contents:39#40# dbcksum DB DBNAME41# allcksum ?DB?42# cksum ?DB?43#44# Commands to execute/explain SQL statements:45#46# memdbsql SQL47# stepsql DB SQL48# execsql2 SQL49# explain_no_trace SQL50# explain SQL ?DB?51# catchsql SQL ?DB?52# execsql SQL ?DB?53#54# Commands to run test cases:55#56# do_ioerr_test TESTNAME ARGS...57# crashsql ARGS...58# integrity_check TESTNAME ?DB?59# verify_ex_errcode TESTNAME EXPECTED ?DB?60# do_test TESTNAME SCRIPT EXPECTED61# do_execsql_test TESTNAME SQL EXPECTED62# do_catchsql_test TESTNAME SQL EXPECTED63# do_timed_execsql_test TESTNAME SQL EXPECTED64#65# Commands providing a lower level interface to the global test counters:66#67# set_test_counter COUNTER ?VALUE?68# omit_test TESTNAME REASON ?APPEND?69# fail_test TESTNAME70# incr_ntest71#72# Command run at the end of each test file:73#74# finish_test75#76# Commands to help create test files that run with the "WAL" and other77# permutations (see file permutations.test):78#79# wal_is_wal_mode80# wal_set_journal_mode ?DB?81# wal_check_journal_mode TESTNAME?DB?82# permutation83# presql84#85# Command to test whether or not --verbose=1 was specified on the command86# line (returns 0 for not-verbose, 1 for verbose and 2 for "verbose in the87# output file only").88#89# verbose90#91 92# Only run this script once. If sourced a second time, make it a no-op93if {[info exists ::tester_tcl_has_run]} return94 95# Set the precision of FP arithmatic used by the interpreter. And96# configure SQLite to take database file locks on the page that begins97# 64KB into the database file instead of the one 1GB in. This means98# the code that handles that special case can be tested without creating99# very large database files.100#101set tcl_precision 15102sqlite3_test_control_pending_byte 0x0010000103 104 105# If the pager codec is available, create a wrapper for the [sqlite3]106# command that appends "-key {xyzzy}" to the command line. i.e. this:107#108# sqlite3 db test.db109#110# becomes111#112# sqlite3 db test.db -key {xyzzy}113#114if {[info command sqlite_orig]==""} {115 rename sqlite3 sqlite_orig116 proc sqlite3 {args} {117 if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} {118 # This command is opening a new database connection.119 #120 if {[info exists ::G(perm:sqlite3_args)]} {121 set args [concat $args $::G(perm:sqlite3_args)]122 }123 if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} {124 lappend args -key {xyzzy}125 }126 127 set res [uplevel 1 sqlite_orig $args]128 if {[info exists ::G(perm:presql)]} {129 [lindex $args 0] eval $::G(perm:presql)130 }131 if {[info exists ::G(perm:dbconfig)]} {132 set ::dbhandle [lindex $args 0]133 uplevel #0 $::G(perm:dbconfig)134 }135 [lindex $args 0] cache size 3136 set res137 } else {138 # This command is not opening a new database connection. Pass the139 # arguments through to the C implementation as the are.140 #141 uplevel 1 sqlite_orig $args142 }143 }144}145 146proc getFileRetries {} {147 if {![info exists ::G(file-retries)]} {148 #149 # NOTE: Return the default number of retries for [file] operations. A150 # value of zero or less here means "disabled".151 #152 return [expr {$::tcl_platform(platform) eq "windows" ? 50 : 0}]153 }154 return $::G(file-retries)155}156 157proc getFileRetryDelay {} {158 if {![info exists ::G(file-retry-delay)]} {159 #160 # NOTE: Return the default number of milliseconds to wait when retrying161 # failed [file] operations. A value of zero or less means "do not162 # wait".163 #164 return 100; # TODO: Good default?165 }166 return $::G(file-retry-delay)167}168 169# Return the string representing the name of the current directory. On170# Windows, the result is "normalized" to whatever our parent command shell171# is using to prevent case-mismatch issues.172#173proc get_pwd {} {174 if {$::tcl_platform(platform) eq "windows"} {175 #176 # NOTE: Cannot use [file normalize] here because it would alter the177 # case of the result to what Tcl considers canonical, which would178 # defeat the purpose of this procedure.179 #180 if {[info exists ::env(ComSpec)]} {181 set comSpec $::env(ComSpec)182 } else {183 # NOTE: Hard-code the typical default value.184 set comSpec {C:\Windows\system32\cmd.exe}185 }186 return [string map [list \\ /] \187 [string trim [exec -- $comSpec /c CD]]]188 } else {189 return [pwd]190 }191}192 193# Copy file $from into $to. This is used because some versions of194# TCL for windows (notably the 8.4.1 binary package shipped with the195# current mingw release) have a broken "file copy" command.196#197proc copy_file {from to} {198 do_copy_file false $from $to199}200 201proc forcecopy {from to} {202 do_copy_file true $from $to203}204 205proc do_copy_file {force from to} {206 set nRetry [getFileRetries] ;# Maximum number of retries.207 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying.208 209 # On windows, sometimes even a [file copy -force] can fail. The cause is210 # usually "tag-alongs" - programs like anti-virus software, automatic backup211 # tools and various explorer extensions that keep a file open a little longer212 # than we expect, causing the delete to fail.213 #214 # The solution is to wait a short amount of time before retrying the copy.215 #216 if {$nRetry > 0} {217 for {set i 0} {$i<$nRetry} {incr i} {218 set rc [catch {219 if {$force} {220 file copy -force $from $to221 } else {222 file copy $from $to223 }224 } msg]225 if {$rc==0} break226 if {$nDelay > 0} { after $nDelay }227 }228 if {$rc} { error $msg }229 } else {230 if {$force} {231 file copy -force $from $to232 } else {233 file copy $from $to234 }235 }236}237 238# Check if a file name is relative239#240proc is_relative_file { file } {241 return [expr {[file pathtype $file] != "absolute"}]242}243 244# If the VFS supports using the current directory, returns [pwd];245# otherwise, it returns only the provided suffix string (which is246# empty by default).247#248proc test_pwd { args } {249 if {[llength $args] > 0} {250 set suffix1 [lindex $args 0]251 if {[llength $args] > 1} {252 set suffix2 [lindex $args 1]253 } else {254 set suffix2 $suffix1255 }256 } else {257 set suffix1 ""; set suffix2 ""258 }259 ifcapable curdir {260 return "[get_pwd]$suffix1"261 } else {262 return $suffix2263 }264}265 266# Delete a file or directory267#268proc delete_file {args} {269 do_delete_file false {*}$args270}271 272proc forcedelete {args} {273 do_delete_file true {*}$args274}275 276proc do_delete_file {force args} {277 set nRetry [getFileRetries] ;# Maximum number of retries.278 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying.279 280 foreach filename $args {281 # On windows, sometimes even a [file delete -force] can fail just after282 # a file is closed. The cause is usually "tag-alongs" - programs like283 # anti-virus software, automatic backup tools and various explorer284 # extensions that keep a file open a little longer than we expect, causing285 # the delete to fail.286 #287 # The solution is to wait a short amount of time before retrying the288 # delete.289 #290 if {$nRetry > 0} {291 for {set i 0} {$i<$nRetry} {incr i} {292 set rc [catch {293 if {$force} {294 file delete -force $filename295 } else {296 file delete $filename297 }298 } msg]299 if {$rc==0} break300 if {$nDelay > 0} { after $nDelay }301 }302 if {$rc} { error $msg }303 } else {304 if {$force} {305 file delete -force $filename306 } else {307 file delete $filename308 }309 }310 }311}312 313proc execpresql {handle args} {314 trace remove execution $handle enter [list execpresql $handle]315 if {[info exists ::G(perm:presql)]} {316 $handle eval $::G(perm:presql)317 }318}319 320# This command should be called after loading tester.tcl from within321# all test scripts that are incompatible with encryption codecs.322#323proc do_not_use_codec {} {324 set ::do_not_use_codec 1325 reset_db326}327unset -nocomplain do_not_use_codec328 329# Return true if the "reserved_bytes" integer on database files is non-zero.330#331proc nonzero_reserved_bytes {} {332 return [sqlite3 -has-codec]333}334 335# Print a HELP message and exit336#337proc print_help_and_quit {} {338 puts {Options:339 --pause Wait for user input before continuing340 --soft-heap-limit=N Set the soft-heap-limit to N341 --hard-heap-limit=N Set the hard-heap-limit to N342 --maxerror=N Quit after N errors343 --verbose=(0|1) Control the amount of output. Default '1'344 --output=FILE set --verbose=2 and output to FILE. Implies -q345 -q Shorthand for --verbose=0346 --help This message347}348 exit 1349}350 351# The following block only runs the first time this file is sourced. It352# does not run in slave interpreters (since the ::cmdlinearg array is353# populated before the test script is run in slave interpreters).354#355if {[info exists cmdlinearg]==0} {356 357 # Parse any options specified in the $argv array. This script accepts the358 # following options:359 #360 # --pause361 # --soft-heap-limit=NN362 # --hard-heap-limit=NN363 # --maxerror=NN364 # --malloctrace=N365 # --backtrace=N366 # --binarylog=N367 # --soak=N368 # --file-retries=N369 # --file-retry-delay=N370 # --start=[$permutation:]$testfile371 # --match=$pattern372 # --verbose=$val373 # --output=$filename374 # -q Reduce output375 # --testdir=$dir Run tests in subdirectory $dir376 # --help377 #378 set cmdlinearg(soft-heap-limit) 0379 set cmdlinearg(hard-heap-limit) 0380 set cmdlinearg(maxerror) 1000381 set cmdlinearg(malloctrace) 0382 set cmdlinearg(backtrace) 10383 set cmdlinearg(binarylog) 0384 set cmdlinearg(soak) 0385 set cmdlinearg(file-retries) 0386 set cmdlinearg(file-retry-delay) 0387 set cmdlinearg(start) ""388 set cmdlinearg(match) ""389 set cmdlinearg(verbose) ""390 set cmdlinearg(output) ""391 set cmdlinearg(testdir) "testdir"392 393 set leftover [list]394 foreach a $argv {395 switch -regexp -- $a {396 {^-+pause$} {397 # Wait for user input before continuing. This is to give the user an398 # opportunity to connect profiling tools to the process.399 puts -nonewline "Press RETURN to begin..."400 flush stdout401 gets stdin402 }403 {^-+soft-heap-limit=.+$} {404 foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break405 }406 {^-+hard-heap-limit=.+$} {407 foreach {dummy cmdlinearg(hard-heap-limit)} [split $a =] break408 }409 {^-+maxerror=.+$} {410 foreach {dummy cmdlinearg(maxerror)} [split $a =] break411 }412 {^-+malloctrace=.+$} {413 foreach {dummy cmdlinearg(malloctrace)} [split $a =] break414 if {$cmdlinearg(malloctrace)} {415 if {0==$::sqlite_options(memdebug)} {416 set err "Error: --malloctrace=1 requires an SQLITE_MEMDEBUG build"417 puts stderr $err418 exit 1419 }420 sqlite3_memdebug_log start421 }422 }423 {^-+backtrace=.+$} {424 foreach {dummy cmdlinearg(backtrace)} [split $a =] break425 sqlite3_memdebug_backtrace $cmdlinearg(backtrace)426 }427 {^-+binarylog=.+$} {428 foreach {dummy cmdlinearg(binarylog)} [split $a =] break429 set cmdlinearg(binarylog) [file normalize $cmdlinearg(binarylog)]430 }431 {^-+soak=.+$} {432 foreach {dummy cmdlinearg(soak)} [split $a =] break433 set ::G(issoak) $cmdlinearg(soak)434 }435 {^-+file-retries=.+$} {436 foreach {dummy cmdlinearg(file-retries)} [split $a =] break437 set ::G(file-retries) $cmdlinearg(file-retries)438 }439 {^-+file-retry-delay=.+$} {440 foreach {dummy cmdlinearg(file-retry-delay)} [split $a =] break441 set ::G(file-retry-delay) $cmdlinearg(file-retry-delay)442 }443 {^-+start=.+$} {444 foreach {dummy cmdlinearg(start)} [split $a =] break445 446 set ::G(start:file) $cmdlinearg(start)447 if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} {448 set ::G(start:permutation) ${s.perm}449 set ::G(start:file) ${s.file}450 }451 if {$::G(start:file) == ""} {unset ::G(start:file)}452 }453 {^-+match=.+$} {454 foreach {dummy cmdlinearg(match)} [split $a =] break455 456 set ::G(match) $cmdlinearg(match)457 if {$::G(match) == ""} {unset ::G(match)}458 }459 460 {^-+output=.+$} {461 foreach {dummy cmdlinearg(output)} [split $a =] break462 set cmdlinearg(output) [file normalize $cmdlinearg(output)]463 if {$cmdlinearg(verbose)==""} {464 set cmdlinearg(verbose) 2465 }466 }467 {^-+verbose=.+$} {468 foreach {dummy cmdlinearg(verbose)} [split $a =] break469 if {$cmdlinearg(verbose)=="file"} {470 set cmdlinearg(verbose) 2471 } elseif {[string is boolean -strict $cmdlinearg(verbose)]==0} {472 error "option --verbose= must be set to a boolean or to \"file\""473 }474 }475 {^-+testdir=.*$} {476 foreach {dummy cmdlinearg(testdir)} [split $a =] break477 }478 {.*help.*} {479 print_help_and_quit480 }481 {^-q$} {482 set cmdlinearg(output) test-out.txt483 set cmdlinearg(verbose) 2484 }485 486 default {487 if {[file tail $a]==$a} {488 lappend leftover $a489 } else {490 lappend leftover [file normalize $a]491 }492 }493 }494 }495 unset -nocomplain a496 set testdir [file normalize $testdir]497 set cmdlinearg(TESTFIXTURE_HOME) [file dirname [info nameofexec]]498 set cmdlinearg(INFO_SCRIPT) [file normalize [info script]]499 set argv0 [file normalize $argv0]500 if {$cmdlinearg(testdir)!=""} {501 file mkdir $cmdlinearg(testdir)502 cd $cmdlinearg(testdir)503 }504 set argv $leftover505 506 # Install the malloc layer used to inject OOM errors. And the 'automatic'507 # extensions. This only needs to be done once for the process.508 #509 sqlite3_shutdown510 install_malloc_faultsim 1511 sqlite3_initialize512 autoinstall_test_functions513 514 # If the --binarylog option was specified, create the logging VFS. This515 # call installs the new VFS as the default for all SQLite connections.516 #517 if {$cmdlinearg(binarylog)} {518 vfslog new binarylog {} vfslog.bin519 }520 521 # Set the backtrace depth, if malloc tracing is enabled.522 #523 if {$cmdlinearg(malloctrace)} {524 sqlite3_memdebug_backtrace $cmdlinearg(backtrace)525 }526 527 if {$cmdlinearg(output)!=""} {528 puts "Copying output to file $cmdlinearg(output)"529 set ::G(output_fd) [open $cmdlinearg(output) w]530 fconfigure $::G(output_fd) -buffering line531 }532 533 if {$cmdlinearg(verbose)==""} {534 set cmdlinearg(verbose) 1535 }536 537 if {[info commands vdbe_coverage]!=""} {538 vdbe_coverage start539 }540}541 542# Update the soft-heap-limit each time this script is run. In that543# way if an individual test file changes the soft-heap-limit, it544# will be reset at the start of the next test file.545#546sqlite3_soft_heap_limit64 $cmdlinearg(soft-heap-limit)547sqlite3_hard_heap_limit64 $cmdlinearg(hard-heap-limit)548 549# Create a test database550#551proc reset_db {} {552 catch {db close}553 forcedelete test.db554 forcedelete test.db-journal555 forcedelete test.db-wal556 sqlite3 db ./test.db557 set ::DB [sqlite3_connection_pointer db]558 if {[info exists ::SETUP_SQL]} {559 db eval $::SETUP_SQL560 }561}562reset_db563 564# Abort early if this script has been run before.565#566if {[info exists TC(count)]} return567 568# Make sure memory statistics are enabled.569#570sqlite3_config_memstatus 1571 572# Initialize the test counters and set up commands to access them.573# Or, if this is a slave interpreter, set up aliases to write the574# counters in the parent interpreter.575#576if {0==[info exists ::SLAVE]} {577 set TC(errors) 0578 set TC(count) 0579 set TC(fail_list) [list]580 set TC(omit_list) [list]581 set TC(warn_list) [list]582 583 proc set_test_counter {counter args} {584 if {[llength $args]} {585 set ::TC($counter) [lindex $args 0]586 }587 set ::TC($counter)588 }589}590 591# Record the fact that a sequence of tests were omitted.592#593proc omit_test {name reason {append 1}} {594 set omitList [set_test_counter omit_list]595 if {$append} {596 lappend omitList [list $name $reason]597 }598 set_test_counter omit_list $omitList599}600 601# Record the fact that a test failed.602#603proc fail_test {name} {604 set f [set_test_counter fail_list]605 lappend f $name606 set_test_counter fail_list $f607 set_test_counter errors [expr [set_test_counter errors] + 1]608 609 set nFail [set_test_counter errors]610 if {$nFail>=$::cmdlinearg(maxerror)} {611 output2 "*** Giving up..."612 finalize_testing613 }614}615 616# Remember a warning message to be displayed at the conclusion of all testing617#618proc warning {msg {append 1}} {619 output2 "Warning: $msg"620 set warnList [set_test_counter warn_list]621 if {$append} {622 lappend warnList $msg623 }624 set_test_counter warn_list $warnList625}626 627 628# Increment the number of tests run629#630proc incr_ntest {} {631 set_test_counter count [expr [set_test_counter count] + 1]632}633 634# Return true if --verbose=1 was specified on the command line. Otherwise,635# return false.636#637proc verbose {} {638 return $::cmdlinearg(verbose)639}640 641# Use the following commands instead of [puts] for test output within642# this file. Test scripts can still use regular [puts], which is directed643# to stdout and, if one is open, the --output file.644#645# output1: output that should be printed if --verbose=1 was specified.646# output2: output that should be printed unconditionally.647# output2_if_no_verbose: output that should be printed only if --verbose=0.648#649proc output1 {args} {650 set v [verbose]651 if {$v==1} {652 uplevel output2 $args653 } elseif {$v==2} {654 uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end]655 }656}657proc output2 {args} {658 set nArg [llength $args]659 uplevel puts $args660}661proc output2_if_no_verbose {args} {662 set v [verbose]663 if {$v==0} {664 uplevel output2 $args665 } elseif {$v==2} {666 uplevel puts [lrange $args 0 end-1] stdout [lrange $args end end]667 }668}669 670# Override the [puts] command so that if no channel is explicitly 671# specified the string is written to both stdout and to the file 672# specified by "--output=", if any.673#674proc puts_override {args} {675 set nArg [llength $args]676 if {$nArg==1 || ($nArg==2 && [string first [lindex $args 0] -nonewline]==0)} {677 uplevel puts_original $args678 if {[info exists ::G(output_fd)]} {679 uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end]680 }681 } else {682 # A channel was explicitly specified.683 uplevel puts_original $args684 }685}686rename puts puts_original687proc puts {args} { uplevel puts_override $args }688 689 690# Invoke the do_test procedure to run a single test691#692# The $expected parameter is the expected result. The result is the return693# value from the last TCL command in $cmd.694#695# Normally, $expected must match exactly. But if $expected is of the form696# "/regexp/" then regular expression matching is used. If $expected is697# "~/regexp/" then the regular expression must NOT match. If $expected is698# of the form "#/value-list/" then each term in value-list must be numeric699# and must approximately match the corresponding numeric term in $result.700# Values must match within 10%. Or if the $expected term is A..B then the701# $result term must be in between A and B.702#703proc do_test {name cmd expected} {704 global argv cmdlinearg705 706 fix_testname name707 708 sqlite3_memdebug_settitle $name709 710# if {[llength $argv]==0} {711# set go 1712# } else {713# set go 0714# foreach pattern $argv {715# if {[string match $pattern $name]} {716# set go 1717# break718# }719# }720# }721 722 if {[info exists ::G(perm:prefix)]} {723 set name "$::G(perm:prefix)$name"724 }725 726 incr_ntest727 output1 -nonewline $name...728 flush stdout729 730 if {![info exists ::G(match)] || [string match $::G(match) $name]} {731 if {[catch {uplevel #0 "$cmd;\n"} result]} {732 output2_if_no_verbose -nonewline $name...733 output2 "\nError: $result"734 fail_test $name735 } else {736 if {[permutation]=="maindbname"} {737 set result [string map [list [string tolower ICECUBE] main] $result]738 }739 if {[regexp {^[~#]?/.*/$} $expected]} {740 # "expected" is of the form "/PATTERN/" then the result if correct if741 # regular expression PATTERN matches the result. "~/PATTERN/" means742 # the regular expression must not match.743 if {[string index $expected 0]=="~"} {744 set re [string range $expected 2 end-1]745 if {[string index $re 0]=="*"} {746 # If the regular expression begins with * then treat it as a glob instead747 set ok [string match $re $result]748 } else {749 set re [string map {# {[-0-9.]+}} $re]750 set ok [regexp $re $result]751 }752 set ok [expr {!$ok}]753 } elseif {[string index $expected 0]=="#"} {754 # Numeric range value comparison. Each term of the $result is matched755 # against one term of $expect. Both $result and $expected terms must be756 # numeric. The values must match within 10%. Or if $expected is of the757 # form A..B then the $result term must be between A and B.758 set e2 [string range $expected 2 end-1]759 foreach i $result j $e2 {760 if {[regexp {^(-?\d+)\.\.(-?\d)$} $j all A B]} {761 set ok [expr {$i+0>=$A && $i+0<=$B}]762 } else {763 set ok [expr {$i+0>=0.9*$j && $i+0<=1.1*$j}]764 }765 if {!$ok} break766 }767 if {$ok && [llength $result]!=[llength $e2]} {set ok 0}768 } else {769 set re [string range $expected 1 end-1]770 if {[string index $re 0]=="*"} {771 # If the regular expression begins with * then treat it as a glob instead772 set ok [string match $re $result]773 } else {774 set re [string map {# {[-0-9.]+}} $re]775 set ok [regexp $re $result]776 }777 }778 } elseif {[regexp {^~?\*.*\*$} $expected]} {779 # "expected" is of the form "*GLOB*" then the result if correct if780 # glob pattern GLOB matches the result. "~/GLOB/" means781 # the glob must not match.782 if {[string index $expected 0]=="~"} {783 set e [string range $expected 1 end]784 set ok [expr {![string match $e $result]}]785 } else {786 set ok [string match $expected $result]787 }788 } else {789 set ok [expr {[string compare $result $expected]==0}]790 if {!$ok} {791 set ok [fpnum_compare $result $expected]792 }793 }794 if {!$ok} {795 # if {![info exists ::testprefix] || $::testprefix eq ""} {796 # error "no test prefix"797 # }798 output1 ""799 output2 "! $name expected: \[$expected\]\n! $name got: \[$result\]"800 fail_test $name801 } else {802 output1 " Ok"803 }804 }805 } else {806 output1 " Omitted"807 omit_test $name "pattern mismatch" 0808 }809 flush stdout810}811 812# Like do_test except the test is not run in a slave interpreter813# on Windows because of issues with ANSI and UTF8 I/O on Win11.814#815proc do_test_with_ansi_output {name cmd expected} {816 if {![info exists ::SLAVE] || $::tcl_platform(platform) ne "windows"} {817 uplevel 1 [list do_test $name $cmd $expected]818 }819}820 821proc dumpbytes {s} {822 set r ""823 for {set i 0} {$i < [string length $s]} {incr i} {824 if {$i > 0} {append r " "}825 append r [format %02X [scan [string index $s $i] %c]]826 }827 return $r828}829 830proc catchcmd {db {cmd ""}} {831 global CLI832 set out [open cmds.txt w]833 puts $out $cmd834 close $out835 set line "exec $CLI $db < cmds.txt"836 set rc [catch { eval $line } msg]837 list $rc $msg838}839proc catchsafecmd {db {cmd ""}} {840 global CLI841 set out [open cmds.txt w]842 puts $out $cmd843 close $out844 set line "exec $CLI -safe $db < cmds.txt"845 set rc [catch { eval $line } msg]846 list $rc $msg847}848 849proc catchcmdex {db {cmd ""}} {850 global CLI851 set out [open cmds.txt w]852 fconfigure $out -translation binary853 puts -nonewline $out $cmd854 close $out855 set line "exec -keepnewline -- $CLI $db < cmds.txt"856 set chans [list stdin stdout stderr]857 foreach chan $chans {858 catch {859 set modes($chan) [fconfigure $chan]860 fconfigure $chan -translation binary -buffering none861 }862 }863 set rc [catch { eval $line } msg]864 foreach chan $chans {865 catch {866 eval fconfigure [list $chan] $modes($chan)867 }868 }869 # puts [dumpbytes $msg]870 list $rc $msg871}872 873proc filepath_normalize {p} {874 # test cases should be written to assume "unix"-like file paths875 if {$::tcl_platform(platform) ne "unix"} {876 string map [list \\ / \{/ / .db\} .db] \877 [regsub -nocase -all {[a-z]:[/\\]+} $p {/}]878 } {879 set p880 }881}882proc do_filepath_test {name cmd expected} {883 uplevel [list do_test $name [884 subst -nocommands { filepath_normalize [ $cmd ] }885 ] [filepath_normalize $expected]]886}887 888proc realnum_normalize {r} {889 # different TCL versions display floating point values differently.890 string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}]891}892proc do_realnum_test {name cmd expected} {893 uplevel [list do_test $name [894 subst -nocommands { realnum_normalize [ $cmd ] }895 ] [realnum_normalize $expected]]896}897 898proc fix_testname {varname} {899 upvar $varname testname900 if {[info exists ::testprefix]901 && [string is digit [string range $testname 0 0]]902 } {903 set testname "${::testprefix}-$testname"904 }905}906 907proc normalize_list {L} {908 set L2 [list]909 foreach l $L {lappend L2 $l}910 set L2911}912 913# Run SQL and verify that the number of "vmsteps" required is greater914# than or less than some constant.915#916proc do_vmstep_test {tn sql nstep {res {}}} {917 uplevel [list do_execsql_test $tn.0 $sql $res]918 919 set vmstep [db status vmstep]920 if {[string range $nstep 0 0]=="+"} {921 set body "if {$vmstep<$nstep} {922 error \"got $vmstep, expected more than [string range $nstep 1 end]\"923 }"924 } else {925 set body "if {$vmstep>$nstep} {926 error \"got $vmstep, expected less than $nstep\"927 }"928 }929 930 # set name "$tn.vmstep=$vmstep,expect=$nstep"931 set name "$tn.1"932 uplevel [list do_test $name $body {}]933}934 935 936# Either:937#938# do_execsql_test TESTNAME SQL ?RES?939# do_execsql_test -db DB TESTNAME SQL ?RES?940#941proc do_execsql_test {args} {942 set db db943 if {[lindex $args 0]=="-db"} {944 set db [lindex $args 1]945 set args [lrange $args 2 end]946 }947 948 if {[llength $args]==2} {949 foreach {testname sql} $args {}950 set result ""951 } elseif {[llength $args]==3} {952 foreach {testname sql result} $args {}953 954 # With some versions of Tcl on windows, if $result is all whitespace but955 # contains some CR/LF characters, the [list {*}$result] below returns a956 # copy of $result instead of a zero length string. Not clear exactly why957 # this is. The following is a workaround.958 if {[llength $result]==0} { set result "" }959 } else {960 error [string trim {961 wrong # args: should be "do_execsql_test ?-db DB? testname sql ?result?"962 }]963 }964 965 fix_testname testname966 967 uplevel do_test \968 [list $testname] \969 [list "execsql {$sql} $db"] \970 [list [list {*}$result]]971}972 973proc do_catchsql_test {testname sql result} {974 fix_testname testname975 uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result]976}977proc do_timed_execsql_test {testname sql {result {}}} {978 fix_testname testname979 uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\980 [list [list {*}$result]]981}982 983# Run an EXPLAIN QUERY PLAN $sql in database "db". Then rewrite the output984# as an ASCII-art graph and return a string that is that graph.985#986# Hexadecimal literals in the output text are converted into "xxxxxx" since those987# literals are pointer values that might very from one run of the test to the988# next, yet we want the output to be consistent.989#990proc query_plan_graph {sql} {991 db eval "EXPLAIN QUERY PLAN $sql" {992 set dx($id) $detail993 lappend cx($parent) $id994 }995 set a "\n QUERY PLAN\n"996 append a [append_graph " " dx cx 0]997 regsub -all {SUBQUERY 0x[A-F0-9]+\y} $a {SUBQUERY xxxxxx} a998 regsub -all {(MATERIALIZE|CO-ROUTINE|SUBQUERY) \d+\y} $a {\1 xxxxxx} a999 regsub -all {\((join|subquery)-\d+\)} $a {(\1-xxxxxx)} a1000 return $a1001}1002 1003# Helper routine for [query_plan_graph SQL]:1004#1005# Output rows of the graph that are children of $level.1006#1007# prefix: Prepend to every output line1008#1009# dxname: Name of an array variable that stores text describe1010# The description for $id is $dx($id)1011#1012# cxname: Name of an array variable holding children of item.1013# Children of $id are $cx($id)1014#1015# level: Render all lines that are children of $level1016# 1017proc append_graph {prefix dxname cxname level} {1018 upvar $dxname dx $cxname cx1019 set a ""1020 set x $cx($level)1021 set n [llength $x]1022 for {set i 0} {$i<$n} {incr i} {1023 set id [lindex $x $i]1024 if {$i==$n-1} {1025 set p1 "`--"1026 set p2 " "1027 } else {1028 set p1 "|--"1029 set p2 "| "1030 }1031 append a $prefix$p1$dx($id)\n1032 if {[info exists cx($id)]} {1033 append a [append_graph "$prefix$p2" dx cx $id]1034 }1035 }1036 return $a1037}1038 1039# Do an EXPLAIN QUERY PLAN test on input $sql with expected results $res1040#1041# If $res begins with a "\s+QUERY PLAN\n" then it is assumed to be the 1042# complete graph which must match the output of [query_plan_graph $sql]1043# exactly.1044#1045# If $res does not begin with "\s+QUERY PLAN\n" then take it is a string1046# that must be found somewhere in the query plan output.1047#1048proc do_eqp_test {name sql res} {1049 if {[regexp {^\s+QUERY PLAN\n} $res]} {1050 1051 set query_plan [query_plan_graph $sql]1052 1053 if {[list {*}$query_plan]==[list {*}$res]} {1054 uplevel [list do_test $name [list set {} ok] ok]1055 } else {1056 uplevel [list \1057 do_test $name [list query_plan_graph $sql] $res1058 ]1059 }1060 } else {1061 if {[string index $res 0]!="/"} {1062 set res "/*$res*/"1063 }1064 uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res]1065 }1066}1067 1068# Do both an eqp_test and an execsql_test on the same SQL.1069#1070proc do_eqp_execsql_test {name sql res1 res2} {1071 if {[regexp {^\s+QUERY PLAN\n} $res1]} {1072 1073 set query_plan [query_plan_graph $sql]1074 1075 if {[list {*}$query_plan]==[list {*}$res1]} {1076 uplevel [list do_test ${name}a [list set {} ok] ok]1077 } else {1078 uplevel [list \1079 do_test ${name}a [list query_plan_graph $sql] $res11080 ]1081 }1082 } else {1083 if {[string index $res 0]!="/"} {1084 set res1 "/*$res1*/"1085 }1086 uplevel do_execsql_test ${name}a [list "EXPLAIN QUERY PLAN $sql"] [list $res1]1087 }1088 uplevel do_execsql_test ${name}b [list $sql] [list $res2]1089}1090 1091 1092#-------------------------------------------------------------------------1093# Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST1094#1095# Where switches are:1096#1097# -errorformat FMTSTRING1098# -count1099# -query SQL1100# -tclquery TCL1101# -repair TCL1102#1103proc do_select_tests {prefix args} {1104 1105 set testlist [lindex $args end]1106 set switches [lrange $args 0 end-1]1107 1108 set errfmt ""1109 set countonly 01110 set tclquery ""1111 set repair ""1112 1113 for {set i 0} {$i < [llength $switches]} {incr i} {1114 set s [lindex $switches $i]1115 set n [string length $s]1116 if {$n>=2 && [string equal -length $n $s "-query"]} {1117 set tclquery [list execsql [lindex $switches [incr i]]]1118 } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} {1119 set tclquery [lindex $switches [incr i]]1120 } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} {1121 set errfmt [lindex $switches [incr i]]1122 } elseif {$n>=2 && [string equal -length $n $s "-repair"]} {1123 set repair [lindex $switches [incr i]]1124 } elseif {$n>=2 && [string equal -length $n $s "-count"]} {1125 set countonly 11126 } else {1127 error "unknown switch: $s"1128 }1129 }1130 1131 if {$countonly && $errfmt!=""} {1132 error "Cannot use -count and -errorformat together"1133 }1134 set nTestlist [llength $testlist]1135 if {$nTestlist%3 || $nTestlist==0 } {1136 error "SELECT test list contains [llength $testlist] elements"1137 }1138 1139 eval $repair1140 foreach {tn sql res} $testlist {1141 if {$tclquery != ""} {1142 execsql $sql1143 uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]]1144 } elseif {$countonly} {1145 set nRow 01146 db eval $sql {incr nRow}1147 uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res]1148 } elseif {$errfmt==""} {1149 uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]]1150 } else {1151 set res [list 1 [string trim [format $errfmt {*}$res]]]1152 uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res]1153 }1154 eval $repair1155 }1156 1157}1158 1159proc delete_all_data {} {1160 db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} {1161 db eval "DELETE FROM '[string map {' ''} $t]'"1162 }1163}1164 1165# Run an SQL script.1166# Return the number of microseconds per statement.1167#1168proc speed_trial {name numstmt units sql} {1169 output2 -nonewline [format {%-21.21s } $name...]1170 flush stdout1171 set speed [time {sqlite3_exec_nr db $sql}]1172 set tm [lindex $speed 0]1173 if {$tm == 0} {1174 set rate [format %20s "many"]1175 } else {1176 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]1177 }1178 set u2 $units/s1179 output2 [format {%12d uS %s %s} $tm $rate $u2]1180 global total_time1181 set total_time [expr {$total_time+$tm}]1182 lappend ::speed_trial_times $name $tm1183}1184proc speed_trial_tcl {name numstmt units script} {1185 output2 -nonewline [format {%-21.21s } $name...]1186 flush stdout1187 set speed [time {eval $script}]1188 set tm [lindex $speed 0]1189 if {$tm == 0} {1190 set rate [format %20s "many"]1191 } else {1192 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]1193 }1194 set u2 $units/s1195 output2 [format {%12d uS %s %s} $tm $rate $u2]1196 global total_time1197 set total_time [expr {$total_time+$tm}]1198 lappend ::speed_trial_times $name $tm1199}1200proc speed_trial_init {name} {