1# 2001 September 15 2# 3# The author disclaims copyright to this source code. In place of 4# 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 regression 12# testing the SQLite library 13# 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 creating 18# test cases are as follows: 19# 20# Commands to manipulate the db and the file-system at a high level: 21# 22# is_relative_file 23# test_pwd 24# get_pwd 25# copy_file FROM TO 26# delete_file FILENAME 27# drop_all_tables ?DB? 28# drop_all_indexes ?DB? 29# forcecopy FROM TO 30# forcedelete FILENAME 31# 32# Test the capability of the SQLite version built into the interpreter to 33# determine if a specific test can be run: 34# 35# capable EXPR 36# ifcapable EXPR 37# 38# Calulate checksums based on database contents: 39# 40# dbcksum DB DBNAME 41# allcksum ?DB? 42# cksum ?DB? 43# 44# Commands to execute/explain SQL statements: 45# 46# memdbsql SQL 47# stepsql DB SQL 48# execsql2 SQL 49# explain_no_trace SQL 50# 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 EXPECTED 61# do_execsql_test TESTNAME SQL EXPECTED 62# do_catchsql_test TESTNAME SQL EXPECTED 63# do_timed_execsql_test TESTNAME SQL EXPECTED 64# 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 TESTNAME 70# incr_ntest 71# 72# Command run at the end of each test file: 73# 74# finish_test 75# 76# Commands to help create test files that run with the "WAL" and other 77# permutations (see file permutations.test): 78# 79# wal_is_wal_mode 80# wal_set_journal_mode ?DB? 81# wal_check_journal_mode TESTNAME?DB? 82# permutation 83# presql 84# 85# Command to test whether or not --verbose=1 was specified on the command 86# line (returns 0 for not-verbose, 1 for verbose and 2 for "verbose in the 87# output file only"). 88# 89# verbose 90# 91 92# Set the precision of FP arithmatic used by the interpreter. And 93# configure SQLite to take database file locks on the page that begins 94# 64KB into the database file instead of the one 1GB in. This means 95# the code that handles that special case can be tested without creating 96# very large database files. 97# 98set tcl_precision 15 99sqlite3_test_control_pending_byte 0x0010000 100 101 102# If the pager codec is available, create a wrapper for the [sqlite3] 103# command that appends "-key {xyzzy}" to the command line. i.e. this: 104# 105# sqlite3 db test.db 106# 107# becomes 108# 109# sqlite3 db test.db -key {xyzzy} 110# 111if {[info command sqlite_orig]==""} { 112 rename sqlite3 sqlite_orig 113 proc sqlite3 {args} { 114 if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} { 115 # This command is opening a new database connection. 116 # 117 if {[info exists ::G(perm:sqlite3_args)]} { 118 set args [concat $args $::G(perm:sqlite3_args)] 119 } 120 if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} { 121 lappend args -key {xyzzy} 122 } 123 124 set res [uplevel 1 sqlite_orig $args] 125 if {[info exists ::G(perm:presql)]} { 126 [lindex $args 0] eval $::G(perm:presql) 127 } 128 if {[info exists ::G(perm:dbconfig)]} { 129 set ::dbhandle [lindex $args 0] 130 uplevel #0 $::G(perm:dbconfig) 131 } 132 set res 133 } else { 134 # This command is not opening a new database connection. Pass the 135 # arguments through to the C implementation as the are. 136 # 137 uplevel 1 sqlite_orig $args 138 } 139 } 140} 141 142proc getFileRetries {} { 143 if {![info exists ::G(file-retries)]} { 144 # 145 # NOTE: Return the default number of retries for [file] operations. A 146 # value of zero or less here means "disabled". 147 # 148 return [expr {$::tcl_platform(platform) eq "windows" ? 50 : 0}] 149 } 150 return $::G(file-retries) 151} 152 153proc getFileRetryDelay {} { 154 if {![info exists ::G(file-retry-delay)]} { 155 # 156 # NOTE: Return the default number of milliseconds to wait when retrying 157 # failed [file] operations. A value of zero or less means "do not 158 # wait". 159 # 160 return 100; # TODO: Good default? 161 } 162 return $::G(file-retry-delay) 163} 164 165# Return the string representing the name of the current directory. On 166# Windows, the result is "normalized" to whatever our parent command shell 167# is using to prevent case-mismatch issues. 168# 169proc get_pwd {} { 170 if {$::tcl_platform(platform) eq "windows"} { 171 # 172 # NOTE: Cannot use [file normalize] here because it would alter the 173 # case of the result to what Tcl considers canonical, which would 174 # defeat the purpose of this procedure. 175 # 176 return [string map [list \\ /] \ 177 [string trim [exec -- $::env(ComSpec) /c echo %CD%]]] 178 } else { 179 return [pwd] 180 } 181} 182 183# Copy file $from into $to. This is used because some versions of 184# TCL for windows (notably the 8.4.1 binary package shipped with the 185# current mingw release) have a broken "file copy" command. 186# 187proc copy_file {from to} { 188 do_copy_file false $from $to 189} 190 191proc forcecopy {from to} { 192 do_copy_file true $from $to 193} 194 195proc do_copy_file {force from to} { 196 set nRetry [getFileRetries] ;# Maximum number of retries. 197 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. 198 199 # On windows, sometimes even a [file copy -force] can fail. The cause is 200 # usually "tag-alongs" - programs like anti-virus software, automatic backup 201 # tools and various explorer extensions that keep a file open a little longer 202 # than we expect, causing the delete to fail. 203 # 204 # The solution is to wait a short amount of time before retrying the copy. 205 # 206 if {$nRetry > 0} { 207 for {set i 0} {$i<$nRetry} {incr i} { 208 set rc [catch { 209 if {$force} { 210 file copy -force $from $to 211 } else { 212 file copy $from $to 213 } 214 } msg] 215 if {$rc==0} break 216 if {$nDelay > 0} { after $nDelay } 217 } 218 if {$rc} { error $msg } 219 } else { 220 if {$force} { 221 file copy -force $from $to 222 } else { 223 file copy $from $to 224 } 225 } 226} 227 228# Check if a file name is relative 229# 230proc is_relative_file { file } { 231 return [expr {[file pathtype $file] != "absolute"}] 232} 233 234# If the VFS supports using the current directory, returns [pwd]; 235# otherwise, it returns only the provided suffix string (which is 236# empty by default). 237# 238proc test_pwd { args } { 239 if {[llength $args] > 0} { 240 set suffix1 [lindex $args 0] 241 if {[llength $args] > 1} { 242 set suffix2 [lindex $args 1] 243 } else { 244 set suffix2 $suffix1 245 } 246 } else { 247 set suffix1 ""; set suffix2 "" 248 } 249 ifcapable curdir { 250 return "[get_pwd]$suffix1" 251 } else { 252 return $suffix2 253 } 254} 255 256# Delete a file or directory 257# 258proc delete_file {args} { 259 do_delete_file false {*}$args 260} 261 262proc forcedelete {args} { 263 do_delete_file true {*}$args 264} 265 266proc do_delete_file {force args} { 267 set nRetry [getFileRetries] ;# Maximum number of retries. 268 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. 269 270 foreach filename $args { 271 # On windows, sometimes even a [file delete -force] can fail just after 272 # a file is closed. The cause is usually "tag-alongs" - programs like 273 # anti-virus software, automatic backup tools and various explorer 274 # extensions that keep a file open a little longer than we expect, causing 275 # the delete to fail. 276 # 277 # The solution is to wait a short amount of time before retrying the 278 # delete. 279 # 280 if {$nRetry > 0} { 281 for {set i 0} {$i<$nRetry} {incr i} { 282 set rc [catch { 283 if {$force} { 284 file delete -force $filename 285 } else { 286 file delete $filename 287 } 288 } msg] 289 if {$rc==0} break 290 if {$nDelay > 0} { after $nDelay } 291 } 292 if {$rc} { error $msg } 293 } else { 294 if {$force} { 295 file delete -force $filename 296 } else { 297 file delete $filename 298 } 299 } 300 } 301} 302 303if {$::tcl_platform(platform) eq "windows"} { 304 proc do_remove_win32_dir {args} { 305 set nRetry [getFileRetries] ;# Maximum number of retries. 306 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. 307 308 foreach dirName $args { 309 # On windows, sometimes even a [remove_win32_dir] can fail just after 310 # a directory is emptied. The cause is usually "tag-alongs" - programs 311 # like anti-virus software, automatic backup tools and various explorer 312 # extensions that keep a file open a little longer than we expect, 313 # causing the delete to fail. 314 # 315 # The solution is to wait a short amount of time before retrying the 316 # removal. 317 # 318 if {$nRetry > 0} { 319 for {set i 0} {$i < $nRetry} {incr i} { 320 set rc [catch { 321 remove_win32_dir $dirName 322 } msg] 323 if {$rc == 0} break 324 if {$nDelay > 0} { after $nDelay } 325 } 326 if {$rc} { error $msg } 327 } else { 328 remove_win32_dir $dirName 329 } 330 } 331 } 332 333 proc do_delete_win32_file {args} { 334 set nRetry [getFileRetries] ;# Maximum number of retries. 335 set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. 336 337 foreach fileName $args { 338 # On windows, sometimes even a [delete_win32_file] can fail just after 339 # a file is closed. The cause is usually "tag-alongs" - programs like 340 # anti-virus software, automatic backup tools and various explorer 341 # extensions that keep a file open a little longer than we expect, 342 # causing the delete to fail. 343 # 344 # The solution is to wait a short amount of time before retrying the 345 # delete. 346 # 347 if {$nRetry > 0} { 348 for {set i 0} {$i < $nRetry} {incr i} { 349 set rc [catch { 350 delete_win32_file $fileName 351 } msg] 352 if {$rc == 0} break 353 if {$nDelay > 0} { after $nDelay } 354 } 355 if {$rc} { error $msg } 356 } else { 357 delete_win32_file $fileName 358 } 359 } 360 } 361} 362 363proc execpresql {handle args} { 364 trace remove execution $handle enter [list execpresql $handle] 365 if {[info exists ::G(perm:presql)]} { 366 $handle eval $::G(perm:presql) 367 } 368} 369 370# This command should be called after loading tester.tcl from within 371# all test scripts that are incompatible with encryption codecs. 372# 373proc do_not_use_codec {} { 374 set ::do_not_use_codec 1 375 reset_db 376} 377unset -nocomplain do_not_use_codec 378 379# Return true if the "reserved_bytes" integer on database files is non-zero. 380# 381proc nonzero_reserved_bytes {} { 382 return [sqlite3 -has-codec] 383} 384 385# Print a HELP message and exit 386# 387proc print_help_and_quit {} { 388 puts {Options: 389 --pause Wait for user input before continuing 390 --soft-heap-limit=N Set the soft-heap-limit to N 391 --maxerror=N Quit after N errors 392 --verbose=(0|1) Control the amount of output. Default '1' 393 --output=FILE set --verbose=2 and output to FILE. Implies -q 394 -q Shorthand for --verbose=0 395 --help This message 396} 397 exit 1 398} 399 400# The following block only runs the first time this file is sourced. It 401# does not run in slave interpreters (since the ::cmdlinearg array is 402# populated before the test script is run in slave interpreters). 403# 404if {[info exists cmdlinearg]==0} { 405 406 # Parse any options specified in the $argv array. This script accepts the 407 # following options: 408 # 409 # --pause 410 # --soft-heap-limit=NN 411 # --maxerror=NN 412 # --malloctrace=N 413 # --backtrace=N 414 # --binarylog=N 415 # --soak=N 416 # --file-retries=N 417 # --file-retry-delay=N 418 # --start=[$permutation:]$testfile 419 # --match=$pattern 420 # --verbose=$val 421 # --output=$filename 422 # -q Reduce output 423 # --testdir=$dir Run tests in subdirectory $dir 424 # --help 425 # 426 set cmdlinearg(soft-heap-limit) 0 427 set cmdlinearg(maxerror) 1000 428 set cmdlinearg(malloctrace) 0 429 set cmdlinearg(backtrace) 10 430 set cmdlinearg(binarylog) 0 431 set cmdlinearg(soak) 0 432 set cmdlinearg(file-retries) 0 433 set cmdlinearg(file-retry-delay) 0 434 set cmdlinearg(start) "" 435 set cmdlinearg(match) "" 436 set cmdlinearg(verbose) "" 437 set cmdlinearg(output) "" 438 set cmdlinearg(testdir) "testdir" 439 440 set leftover [list] 441 foreach a $argv { 442 switch -regexp -- $a { 443 {^-+pause$} { 444 # Wait for user input before continuing. This is to give the user an 445 # opportunity to connect profiling tools to the process. 446 puts -nonewline "Press RETURN to begin..." 447 flush stdout 448 gets stdin 449 } 450 {^-+soft-heap-limit=.+$} { 451 foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break 452 } 453 {^-+maxerror=.+$} { 454 foreach {dummy cmdlinearg(maxerror)} [split $a =] break 455 } 456 {^-+malloctrace=.+$} { 457 foreach {dummy cmdlinearg(malloctrace)} [split $a =] break 458 if {$cmdlinearg(malloctrace)} { 459 sqlite3_memdebug_log start 460 } 461 } 462 {^-+backtrace=.+$} { 463 foreach {dummy cmdlinearg(backtrace)} [split $a =] break 464 sqlite3_memdebug_backtrace $cmdlinearg(backtrace) 465 } 466 {^-+binarylog=.+$} { 467 foreach {dummy cmdlinearg(binarylog)} [split $a =] break 468 set cmdlinearg(binarylog) [file normalize $cmdlinearg(binarylog)] 469 } 470 {^-+soak=.+$} { 471 foreach {dummy cmdlinearg(soak)} [split $a =] break 472 set ::G(issoak) $cmdlinearg(soak) 473 } 474 {^-+file-retries=.+$} { 475 foreach {dummy cmdlinearg(file-retries)} [split $a =] break 476 set ::G(file-retries) $cmdlinearg(file-retries) 477 } 478 {^-+file-retry-delay=.+$} { 479 foreach {dummy cmdlinearg(file-retry-delay)} [split $a =] break 480 set ::G(file-retry-delay) $cmdlinearg(file-retry-delay) 481 } 482 {^-+start=.+$} { 483 foreach {dummy cmdlinearg(start)} [split $a =] break 484 485 set ::G(start:file) $cmdlinearg(start) 486 if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} { 487 set ::G(start:permutation) ${s.perm} 488 set ::G(start:file) ${s.file} 489 } 490 if {$::G(start:file) == ""} {unset ::G(start:file)} 491 } 492 {^-+match=.+$} { 493 foreach {dummy cmdlinearg(match)} [split $a =] break 494 495 set ::G(match) $cmdlinearg(match) 496 if {$::G(match) == ""} {unset ::G(match)} 497 } 498 499 {^-+output=.+$} { 500 foreach {dummy cmdlinearg(output)} [split $a =] break 501 set cmdlinearg(output) [file normalize $cmdlinearg(output)] 502 if {$cmdlinearg(verbose)==""} { 503 set cmdlinearg(verbose) 2 504 } 505 } 506 {^-+verbose=.+$} { 507 foreach {dummy cmdlinearg(verbose)} [split $a =] break 508 if {$cmdlinearg(verbose)=="file"} { 509 set cmdlinearg(verbose) 2 510 } elseif {[string is boolean -strict $cmdlinearg(verbose)]==0} { 511 error "option --verbose= must be set to a boolean or to \"file\"" 512 } 513 } 514 {^-+testdir=.*$} { 515 foreach {dummy cmdlinearg(testdir)} [split $a =] break 516 } 517 {.*help.*} { 518 print_help_and_quit 519 } 520 {^-q$} { 521 set cmdlinearg(output) test-out.txt 522 set cmdlinearg(verbose) 2 523 } 524 525 default { 526 if {[file tail $a]==$a} { 527 lappend leftover $a 528 } else { 529 lappend leftover [file normalize $a] 530 } 531 } 532 } 533 } 534 set testdir [file normalize $testdir] 535 set cmdlinearg(TESTFIXTURE_HOME) [pwd] 536 set cmdlinearg(INFO_SCRIPT) [file normalize [info script]] 537 set argv0 [file normalize $argv0] 538 if {$cmdlinearg(testdir)!=""} { 539 file mkdir $cmdlinearg(testdir) 540 cd $cmdlinearg(testdir) 541 } 542 set argv $leftover 543 544 # Install the malloc layer used to inject OOM errors. And the 'automatic' 545 # extensions. This only needs to be done once for the process. 546 # 547 sqlite3_shutdown 548 install_malloc_faultsim 1 549 sqlite3_initialize 550 autoinstall_test_functions 551 552 # If the --binarylog option was specified, create the logging VFS. This 553 # call installs the new VFS as the default for all SQLite connections. 554 # 555 if {$cmdlinearg(binarylog)} { 556 vfslog new binarylog {} vfslog.bin 557 } 558 559 # Set the backtrace depth, if malloc tracing is enabled. 560 # 561 if {$cmdlinearg(malloctrace)} { 562 sqlite3_memdebug_backtrace $cmdlinearg(backtrace) 563 } 564 565 if {$cmdlinearg(output)!=""} { 566 puts "Copying output to file $cmdlinearg(output)" 567 set ::G(output_fd) [open $cmdlinearg(output) w] 568 fconfigure $::G(output_fd) -buffering line 569 } 570 571 if {$cmdlinearg(verbose)==""} { 572 set cmdlinearg(verbose) 1 573 } 574} 575 576# Update the soft-heap-limit each time this script is run. In that 577# way if an individual test file changes the soft-heap-limit, it 578# will be reset at the start of the next test file. 579# 580sqlite3_soft_heap_limit $cmdlinearg(soft-heap-limit) 581 582# Create a test database 583# 584proc reset_db {} { 585 catch {db close} 586 forcedelete test.db 587 forcedelete test.db-journal 588 forcedelete test.db-wal 589 sqlite3 db ./test.db 590 set ::DB [sqlite3_connection_pointer db] 591 if {[info exists ::SETUP_SQL]} { 592 db eval $::SETUP_SQL 593 } 594} 595reset_db 596 597# Abort early if this script has been run before. 598# 599if {[info exists TC(count)]} return 600 601# Make sure memory statistics are enabled. 602# 603sqlite3_config_memstatus 1 604 605# Initialize the test counters and set up commands to access them. 606# Or, if this is a slave interpreter, set up aliases to write the 607# counters in the parent interpreter. 608# 609if {0==[info exists ::SLAVE]} { 610 set TC(errors) 0 611 set TC(count) 0 612 set TC(fail_list) [list] 613 set TC(omit_list) [list] 614 set TC(warn_list) [list] 615 616 proc set_test_counter {counter args} { 617 if {[llength $args]} { 618 set ::TC($counter) [lindex $args 0] 619 } 620 set ::TC($counter) 621 } 622} 623 624# Record the fact that a sequence of tests were omitted. 625# 626proc omit_test {name reason {append 1}} { 627 set omitList [set_test_counter omit_list] 628 if {$append} { 629 lappend omitList [list $name $reason] 630 } 631 set_test_counter omit_list $omitList 632} 633 634# Record the fact that a test failed. 635# 636proc fail_test {name} { 637 set f [set_test_counter fail_list] 638 lappend f $name 639 set_test_counter fail_list $f 640 set_test_counter errors [expr [set_test_counter errors] + 1] 641 642 set nFail [set_test_counter errors] 643 if {$nFail>=$::cmdlinearg(maxerror)} { 644 output2 "*** Giving up..." 645 finalize_testing 646 } 647} 648 649# Remember a warning message to be displayed at the conclusion of all testing 650# 651proc warning {msg {append 1}} { 652 output2 "Warning: $msg" 653 set warnList [set_test_counter warn_list] 654 if {$append} { 655 lappend warnList $msg 656 } 657 set_test_counter warn_list $warnList 658} 659 660 661# Increment the number of tests run 662# 663proc incr_ntest {} { 664 set_test_counter count [expr [set_test_counter count] + 1] 665} 666 667# Return true if --verbose=1 was specified on the command line. Otherwise, 668# return false. 669# 670proc verbose {} { 671 return $::cmdlinearg(verbose) 672} 673 674# Use the following commands instead of [puts] for test output within 675# this file. Test scripts can still use regular [puts], which is directed 676# to stdout and, if one is open, the --output file. 677# 678# output1: output that should be printed if --verbose=1 was specified. 679# output2: output that should be printed unconditionally. 680# output2_if_no_verbose: output that should be printed only if --verbose=0. 681# 682proc output1 {args} { 683 set v [verbose] 684 if {$v==1} { 685 uplevel output2 $args 686 } elseif {$v==2} { 687 uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end] 688 } 689} 690proc output2 {args} { 691 set nArg [llength $args] 692 uplevel puts $args 693} 694proc output2_if_no_verbose {args} { 695 set v [verbose] 696 if {$v==0} { 697 uplevel output2 $args 698 } elseif {$v==2} { 699 uplevel puts [lrange $args 0 end-1] stdout [lrange $args end end] 700 } 701} 702 703# Override the [puts] command so that if no channel is explicitly 704# specified the string is written to both stdout and to the file 705# specified by "--output=", if any. 706# 707proc puts_override {args} { 708 set nArg [llength $args] 709 if {$nArg==1 || ($nArg==2 && [string first [lindex $args 0] -nonewline]==0)} { 710 uplevel puts_original $args 711 if {[info exists ::G(output_fd)]} { 712 uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end] 713 } 714 } else { 715 # A channel was explicitly specified. 716 uplevel puts_original $args 717 } 718} 719rename puts puts_original 720proc puts {args} { uplevel puts_override $args } 721 722 723# Invoke the do_test procedure to run a single test 724# 725# The $expected parameter is the expected result. The result is the return 726# value from the last TCL command in $cmd. 727# 728# Normally, $expected must match exactly. But if $expected is of the form 729# "/regexp/" then regular expression matching is used. If $expected is 730# "~/regexp/" then the regular expression must NOT match. If $expected is 731# of the form "#/value-list/" then each term in value-list must be numeric 732# and must approximately match the corresponding numeric term in $result. 733# Values must match within 10%. Or if the $expected term is A..B then the 734# $result term must be in between A and B. 735# 736proc do_test {name cmd expected} { 737 global argv cmdlinearg 738 739 fix_testname name 740 741 sqlite3_memdebug_settitle $name 742 743# if {[llength $argv]==0} { 744# set go 1 745# } else { 746# set go 0 747# foreach pattern $argv { 748# if {[string match $pattern $name]} { 749# set go 1 750# break 751# } 752# } 753# } 754 755 if {[info exists ::G(perm:prefix)]} { 756 set name "$::G(perm:prefix)$name" 757 } 758 759 incr_ntest 760 output1 -nonewline $name... 761 flush stdout 762 763 if {![info exists ::G(match)] || [string match $::G(match) $name]} { 764 if {[catch {uplevel #0 "$cmd;\n"} result]} { 765 output2_if_no_verbose -nonewline $name... 766 output2 "\nError: $result" 767 fail_test $name 768 } else { 769 if {[regexp {^[~#]?/.*/$} $expected]} { 770 # "expected" is of the form "/PATTERN/" then the result if correct if 771 # regular expression PATTERN matches the result. "~/PATTERN/" means 772 # the regular expression must not match. 773 if {[string index $expected 0]=="~"} { 774 set re [string range $expected 2 end-1] 775 if {[string index $re 0]=="*"} { 776 # If the regular expression begins with * then treat it as a glob instead 777 set ok [string match $re $result] 778 } else { 779 set re [string map {# {[-0-9.]+}} $re] 780 set ok [regexp $re $result] 781 } 782 set ok [expr {!$ok}] 783 } elseif {[string index $expected 0]=="#"} { 784 # Numeric range value comparison. Each term of the $result is matched 785 # against one term of $expect. Both $result and $expected terms must be 786 # numeric. The values must match within 10%. Or if $expected is of the 787 # form A..B then the $result term must be between A and B. 788 set e2 [string range $expected 2 end-1] 789 foreach i $result j $e2 { 790 if {[regexp {^(-?\d+)\.\.(-?\d)$} $j all A B]} { 791 set ok [expr {$i+0>=$A && $i+0<=$B}] 792 } else { 793 set ok [expr {$i+0>=0.9*$j && $i+0<=1.1*$j}] 794 } 795 if {!$ok} break 796 } 797 if {$ok && [llength $result]!=[llength $e2]} {set ok 0} 798 } else { 799 set re [string range $expected 1 end-1] 800 if {[string index $re 0]=="*"} { 801 # If the regular expression begins with * then treat it as a glob instead 802 set ok [string match $re $result] 803 } else { 804 set re [string map {# {[-0-9.]+}} $re] 805 set ok [regexp $re $result] 806 } 807 } 808 } elseif {[regexp {^~?\*.*\*$} $expected]} { 809 # "expected" is of the form "*GLOB*" then the result if correct if 810 # glob pattern GLOB matches the result. "~/GLOB/" means 811 # the glob must not match. 812 if {[string index $expected 0]=="~"} { 813 set e [string range $expected 1 end] 814 set ok [expr {![string match $e $result]}] 815 } else { 816 set ok [string match $expected $result] 817 } 818 } else { 819 set ok [expr {[string compare $result $expected]==0}] 820 } 821 if {!$ok} { 822 # if {![info exists ::testprefix] || $::testprefix eq ""} { 823 # error "no test prefix" 824 # } 825 output1 "" 826 output2 "! $name expected: \[$expected\]\n! $name got: \[$result\]" 827 fail_test $name 828 } else { 829 output1 " Ok" 830 } 831 } 832 } else { 833 output1 " Omitted" 834 omit_test $name "pattern mismatch" 0 835 } 836 flush stdout 837} 838 839proc dumpbytes {s} { 840 set r "" 841 for {set i 0} {$i < [string length $s]} {incr i} { 842 if {$i > 0} {append r " "} 843 append r [format %02X [scan [string index $s $i] %c]] 844 } 845 return $r 846} 847 848proc catchcmd {db {cmd ""}} { 849 global CLI 850 set out [open cmds.txt w] 851 puts $out $cmd 852 close $out 853 set line "exec $CLI $db < cmds.txt" 854 set rc [catch { eval $line } msg] 855 list $rc $msg 856} 857 858proc catchcmdex {db {cmd ""}} { 859 global CLI 860 set out [open cmds.txt w] 861 fconfigure $out -encoding binary -translation binary 862 puts -nonewline $out $cmd 863 close $out 864 set line "exec -keepnewline -- $CLI $db < cmds.txt" 865 set chans [list stdin stdout stderr] 866 foreach chan $chans { 867 catch { 868 set modes($chan) [fconfigure $chan] 869 fconfigure $chan -encoding binary -translation binary -buffering none 870 } 871 } 872 set rc [catch { eval $line } msg] 873 foreach chan $chans { 874 catch { 875 eval fconfigure [list $chan] $modes($chan) 876 } 877 } 878 # puts [dumpbytes $msg] 879 list $rc $msg 880} 881 882proc filepath_normalize {p} { 883 # test cases should be written to assume "unix"-like file paths 884 if {$::tcl_platform(platform)!="unix"} { 885 # lreverse*2 as a hack to remove any unneeded {} after the string map 886 lreverse [lreverse [string map {\\ /} [regsub -nocase -all {[a-z]:[/\\]+} $p {/}]]] 887 } { 888 set p 889 } 890} 891proc do_filepath_test {name cmd expected} { 892 uplevel [list do_test $name [ 893 subst -nocommands { filepath_normalize [ $cmd ] } 894 ] [filepath_normalize $expected]] 895} 896 897proc realnum_normalize {r} { 898 # different TCL versions display floating point values differently. 899 string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}] 900} 901proc do_realnum_test {name cmd expected} { 902 uplevel [list do_test $name [ 903 subst -nocommands { realnum_normalize [ $cmd ] } 904 ] [realnum_normalize $expected]] 905} 906 907proc fix_testname {varname} { 908 upvar $varname testname 909 if {[info exists ::testprefix] 910 && [string is digit [string range $testname 0 0]] 911 } { 912 set testname "${::testprefix}-$testname" 913 } 914} 915 916proc normalize_list {L} { 917 set L2 [list] 918 foreach l $L {lappend L2 $l} 919 set L2 920} 921 922# Either: 923# 924# do_execsql_test TESTNAME SQL ?RES? 925# do_execsql_test -db DB TESTNAME SQL ?RES? 926# 927proc do_execsql_test {args} { 928 set db db 929 if {[lindex $args 0]=="-db"} { 930 set db [lindex $args 1] 931 set args [lrange $args 2 end] 932 } 933 934 if {[llength $args]==2} { 935 foreach {testname sql} $args {} 936 set result "" 937 } elseif {[llength $args]==3} { 938 foreach {testname sql result} $args {} 939 } else { 940 error [string trim { 941 wrong # args: should be "do_execsql_test ?-db DB? testname sql ?result?" 942 }] 943 } 944 945 fix_testname testname 946 947 uplevel do_test \ 948 [list $testname] \ 949 [list "execsql {$sql} $db"] \ 950 [list [list {*}$result]] 951} 952 953proc do_catchsql_test {testname sql result} { 954 fix_testname testname 955 uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result] 956} 957proc do_timed_execsql_test {testname sql {result {}}} { 958 fix_testname testname 959 uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\ 960 [list [list {*}$result]] 961} 962proc do_eqp_test {name sql res} { 963 uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res] 964} 965 966#------------------------------------------------------------------------- 967# Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST 968# 969# Where switches are: 970# 971# -errorformat FMTSTRING 972# -count 973# -query SQL 974# -tclquery TCL 975# -repair TCL 976# 977proc do_select_tests {prefix args} { 978 979 set testlist [lindex $args end] 980 set switches [lrange $args 0 end-1] 981 982 set errfmt "" 983 set countonly 0 984 set tclquery "" 985 set repair "" 986 987 for {set i 0} {$i < [llength $switches]} {incr i} { 988 set s [lindex $switches $i] 989 set n [string length $s] 990 if {$n>=2 && [string equal -length $n $s "-query"]} { 991 set tclquery [list execsql [lindex $switches [incr i]]] 992 } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} { 993 set tclquery [lindex $switches [incr i]] 994 } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} { 995 set errfmt [lindex $switches [incr i]] 996 } elseif {$n>=2 && [string equal -length $n $s "-repair"]} { 997 set repair [lindex $switches [incr i]] 998 } elseif {$n>=2 && [string equal -length $n $s "-count"]} { 999 set countonly 1 1000 } else { 1001 error "unknown switch: $s" 1002 } 1003 } 1004 1005 if {$countonly && $errfmt!=""} { 1006 error "Cannot use -count and -errorformat together" 1007 } 1008 set nTestlist [llength $testlist] 1009 if {$nTestlist%3 || $nTestlist==0 } { 1010 error "SELECT test list contains [llength $testlist] elements" 1011 } 1012 1013 eval $repair 1014 foreach {tn sql res} $testlist { 1015 if {$tclquery != ""} { 1016 execsql $sql 1017 uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]] 1018 } elseif {$countonly} { 1019 set nRow 0 1020 db eval $sql {incr nRow} 1021 uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res] 1022 } elseif {$errfmt==""} { 1023 uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]] 1024 } else { 1025 set res [list 1 [string trim [format $errfmt {*}$res]]] 1026 uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res] 1027 } 1028 eval $repair 1029 } 1030 1031} 1032 1033proc delete_all_data {} { 1034 db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} { 1035 db eval "DELETE FROM '[string map {' ''} $t]'" 1036 } 1037} 1038 1039# Run an SQL script. 1040# Return the number of microseconds per statement. 1041# 1042proc speed_trial {name numstmt units sql} { 1043 output2 -nonewline [format {%-21.21s } $name...] 1044 flush stdout 1045 set speed [time {sqlite3_exec_nr db $sql}] 1046 set tm [lindex $speed 0] 1047 if {$tm == 0} { 1048 set rate [format %20s "many"] 1049 } else { 1050 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] 1051 } 1052 set u2 $units/s 1053 output2 [format {%12d uS %s %s} $tm $rate $u2] 1054 global total_time 1055 set total_time [expr {$total_time+$tm}] 1056 lappend ::speed_trial_times $name $tm 1057} 1058proc speed_trial_tcl {name numstmt units script} { 1059 output2 -nonewline [format {%-21.21s } $name...] 1060 flush stdout 1061 set speed [time {eval $script}] 1062 set tm [lindex $speed 0] 1063 if {$tm == 0} { 1064 set rate [format %20s "many"] 1065 } else { 1066 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] 1067 } 1068 set u2 $units/s 1069 output2 [format {%12d uS %s %s} $tm $rate $u2] 1070 global total_time 1071 set total_time [expr {$total_time+$tm}] 1072 lappend ::speed_trial_times $name $tm 1073} 1074proc speed_trial_init {name} { 1075 global total_time 1076 set total_time 0 1077 set ::speed_trial_times [list] 1078 sqlite3 versdb :memory: 1079 set vers [versdb one {SELECT sqlite_source_id()}] 1080 versdb close 1081 output2 "SQLite $vers" 1082} 1083proc speed_trial_summary {name} { 1084 global total_time 1085 output2 [format {%-21.21s %12d uS TOTAL} $name $total_time] 1086 1087 if { 0 } { 1088 sqlite3 versdb :memory: 1089 set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0] 1090 versdb close 1091 output2 "CREATE TABLE IF NOT EXISTS time(version, script, test, us);" 1092 foreach {test us} $::speed_trial_times { 1093 output2 "INSERT INTO time VALUES('$vers', '$name', '$test', $us);" 1094 } 1095 } 1096} 1097 1098# Run this routine last 1099# 1100proc finish_test {} { 1101 catch {db close} 1102 catch {db1 close} 1103 catch {db2 close} 1104 catch {db3 close} 1105 if {0==[info exists ::SLAVE]} { finalize_testing } 1106} 1107proc finalize_testing {} { 1108 global sqlite_open_file_count 1109 1110 set omitList [set_test_counter omit_list] 1111 1112 catch {db close} 1113 catch {db2 close} 1114 catch {db3 close} 1115 1116 vfs_unlink_test 1117 sqlite3 db {} 1118 # sqlite3_clear_tsd_memdebug 1119 db close 1120 sqlite3_reset_auto_extension 1121 1122 sqlite3_soft_heap_limit 0 1123 set nTest [incr_ntest] 1124 set nErr [set_test_counter errors] 1125 1126 set nKnown 0 1127 if {[file readable known-problems.txt]} { 1128 set fd [open known-problems.txt] 1129 set content [read $fd] 1130 close $fd 1131 foreach x $content {set known_error($x) 1} 1132 foreach x [set_test_counter fail_list] { 1133 if {[info exists known_error($x)]} {incr nKnown} 1134 } 1135 } 1136 if {$nKnown>0} { 1137 output2 "[expr {$nErr-$nKnown}] new errors and $nKnown known errors\ 1138 out of $nTest tests" 1139 } else { 1140 set cpuinfo {} 1141 if {[catch {exec hostname} hname]==0} {set cpuinfo [string trim $hname]} 1142 append cpuinfo " $::tcl_platform(os)" 1143 append cpuinfo " [expr {$::tcl_platform(pointerSize)*8}]-bit" 1144 append cpuinfo " [string map {E -e} $::tcl_platform(byteOrder)]" 1145 output2 "SQLite [sqlite3 -sourceid]" 1146 output2 "$nErr errors out of $nTest tests on $cpuinfo" 1147 } 1148 if {$nErr>$nKnown} { 1149 output2 -nonewline "!Failures on these tests:" 1150 foreach x [set_test_counter fail_list] { 1151 if {![info exists known_error($x)]} {output2 -nonewline " $x"} 1152 } 1153 output2 "" 1154 } 1155 foreach warning [set_test_counter warn_list] { 1156 output2 "Warning: $warning" 1157 } 1158 run_thread_tests 1 1159 if {[llength $omitList]>0} { 1160 output2 "Omitted test cases:" 1161 set prec {} 1162 foreach {rec} [lsort $omitList] { 1163 if {$rec==$prec} continue 1164 set prec $rec 1165 output2 [format {. %-12s %s} [lindex $rec 0] [lindex $rec 1]] 1166 } 1167 } 1168 if {$nErr>0 && ![working_64bit_int]} { 1169 output2 "******************************************************************" 1170 output2 "N.B.: The version of TCL that you used to build this test harness" 1171 output2 "is defective in that it does not support 64-bit integers. Some or" 1172 output2 "all of the test failures above might be a result from this defect" 1173 output2 "in your TCL build." 1174 output2 "******************************************************************" 1175 } 1176 if {$::cmdlinearg(binarylog)} { 1177 vfslog finalize binarylog 1178 } 1179 if {$sqlite_open_file_count} { 1180 output2 "$sqlite_open_file_count files were left open" 1181 incr nErr 1182 } 1183 if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 || 1184 [sqlite3_memory_used]>0} { 1185 output2 "Unfreed memory: [sqlite3_memory_used] bytes in\ 1186 [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations" 1187 incr nErr 1188 ifcapable memdebug||mem5||(mem3&&debug) { 1189 output2 "Writing unfreed memory log to \"./memleak.txt\"" 1190 sqlite3_memdebug_dump ./memleak.txt 1191 } 1192 } else { 1193 output2 "All memory allocations freed - no leaks" 1194 ifcapable memdebug||mem5 { 1195 sqlite3_memdebug_dump ./memusage.txt 1196 } 1197 } 1198 show_memstats 1199 output2 "Maximum memory usage: [sqlite3_memory_highwater 1] bytes" 1200 output2 "Current memory usage: [sqlite3_memory_highwater] bytes" 1201 if {[info commands sqlite3_memdebug_malloc_count] ne ""} { 1202 output2 "Number of malloc() : [sqlite3_memdebug_malloc_count] calls" 1203 } 1204 if {$::cmdlinearg(malloctrace)} { 1205 output2 "Writing mallocs.sql..." 1206 memdebug_log_sql 1207 sqlite3_memdebug_log stop 1208 sqlite3_memdebug_log clear 1209 1210 if {[sqlite3_memory_used]>0} { 1211 output2 "Writing leaks.sql..." 1212 sqlite3_memdebug_log sync 1213 memdebug_log_sql leaks.sql 1214 } 1215 } 1216 foreach f [glob -nocomplain test.db-*-journal] { 1217 forcedelete $f 1218 } 1219 foreach f [glob -nocomplain test.db-mj*] { 1220 forcedelete $f 1221 } 1222 exit [expr {$nErr>0}] 1223} 1224 1225# Display memory statistics for analysis and debugging purposes. 1226# 1227proc show_memstats {} { 1228 set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0] 1229 set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0] 1230 set val [format {now %10d max %10d max-size %10d} \ 1231 [lindex $x 1] [lindex $x 2] [lindex $y 2]] 1232 output1 "Memory used: $val" 1233 set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1234 set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] 1235 output1 "Allocation count: $val" 1236 set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0] 1237 set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0] 1238 set val [format {now %10d max %10d max-size %10d} \ 1239 [lindex $x 1] [lindex $x 2] [lindex $y 2]] 1240 output1 "Page-cache used: $val" 1241 set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0] 1242 set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] 1243 output1 "Page-cache overflow: $val" 1244 set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0] 1245 set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] 1246 output1 "Scratch memory used: $val" 1247 set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0] 1248 set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0] 1249 set val [format {now %10d max %10d max-size %10d} \ 1250 [lindex $x 1] [lindex $x 2] [lindex $y 2]] 1251 output1 "Scratch overflow: $val" 1252 ifcapable yytrackmaxstackdepth { 1253 set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0] 1254 set val [format { max %10d} [lindex $x 2]] 1255 output2 "Parser stack depth: $val" 1256 } 1257} 1258 1259# A procedure to execute SQL 1260# 1261proc execsql {sql {db db}} { 1262 # puts "SQL = $sql" 1263 uplevel [list $db eval $sql] 1264} 1265proc execsql_timed {sql {db db}} { 1266 set tm [time { 1267 set x [uplevel [list $db eval $sql]] 1268 } 1] 1269 set tm [lindex $tm 0] 1270 output1 -nonewline " ([expr {$tm*0.001}]ms) " 1271 set x 1272} 1273 1274# Execute SQL and catch exceptions. 1275# 1276proc catchsql {sql {db db}} { 1277 # puts "SQL = $sql" 1278 set r [catch [list uplevel [list $db eval $sql]] msg] 1279 lappend r $msg 1280 return $r 1281} 1282 1283# Do an VDBE code dump on the SQL given 1284# 1285proc explain {sql {db db}} { 1286 output2 "" 1287 output2 "addr opcode p1 p2 p3 p4 p5 #" 1288 output2 "---- ------------ ------ ------ ------ --------------- -- -" 1289 $db eval "explain $sql" {} { 1290 output2 [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \ 1291 $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment 1292 ] 1293 } 1294} 1295 1296proc explain_i {sql {db db}} { 1297 output2 "" 1298 output2 "addr opcode p1 p2 p3 p4 p5 #" 1299 output2 "---- ------------ ------ ------ ------ ---------------- -- -" 1300 1301 1302 # Set up colors for the different opcodes. Scheme is as follows: 1303 # 1304 # Red: Opcodes that write to a b-tree. 1305 # Blue: Opcodes that reposition or seek a cursor. 1306 # Green: The ResultRow opcode. 1307 # 1308 if { [catch {fconfigure stdout -mode}]==0 } { 1309 set R "\033\[31;1m" ;# Red fg 1310 set G "\033\[32;1m" ;# Green fg 1311 set B "\033\[34;1m" ;# Red fg 1312 set D "\033\[39;0m" ;# Default fg 1313 } else { 1314 set R "" 1315 set G "" 1316 set B "" 1317 set D "" 1318 } 1319 foreach opcode { 1320 Seek SeekGE SeekGT SeekLE SeekLT NotFound Last Rewind 1321 NoConflict Next Prev VNext VPrev VFilter 1322 SorterSort SorterNext NextIfOpen 1323 } { 1324 set color($opcode) $B 1325 } 1326 foreach opcode {ResultRow} { 1327 set color($opcode) $G 1328 } 1329 foreach opcode {IdxInsert Insert Delete IdxDelete} { 1330 set color($opcode) $R 1331 } 1332 1333 set bSeenGoto 0 1334 $db eval "explain $sql" {} { 1335 set x($addr) 0 1336 set op($addr) $opcode 1337 1338 if {$opcode == "Goto" && ($bSeenGoto==0 || ($p2 > $addr+10))} { 1339 set linebreak($p2) 1 1340 set bSeenGoto 1 1341 } 1342 1343 if {$opcode=="Once"} { 1344 for {set i $addr} {$i<$p2} {incr i} { 1345 set star($i) $addr 1346 } 1347 } 1348 1349 if {$opcode=="Next" || $opcode=="Prev" 1350 || $opcode=="VNext" || $opcode=="VPrev" 1351 || $opcode=="SorterNext" || $opcode=="NextIfOpen" 1352 } { 1353 for {set i $p2} {$i<$addr} {incr i} { 1354 incr x($i) 2 1355 } 1356 } 1357 1358 if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} { 1359 for {set i [expr $p2+1]} {$i<$addr} {incr i} { 1360 incr x($i) 2 1361 } 1362 } 1363 1364 if {$opcode == "Halt" && $comment == "End of coroutine"} { 1365 set linebreak([expr $addr+1]) 1 1366 } 1367 } 1368 1369 $db eval "explain $sql" {} { 1370 if {[info exists linebreak($addr)]} { 1371 output2 "" 1372 } 1373 set I [string repeat " " $x($addr)] 1374 1375 if {[info exists star($addr)]} { 1376 set ii [expr $x($star($addr))] 1377 append I " " 1378 set I [string replace $I $ii $ii *] 1379 } 1380 1381 set col "" 1382 catch { set col $color($opcode) } 1383 1384 output2 [format {%-4d %s%s%-12.12s%s %-6d %-6d %-6d % -17s %s %s} \ 1385 $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment 1386 ] 1387 } 1388 output2 "---- ------------ ------ ------ ------ ---------------- -- -" 1389} 1390 1391# Show the VDBE program for an SQL statement but omit the Trace 1392# opcode at the beginning. This procedure can be used to prove 1393# that different SQL statements generate exactly the same VDBE code. 1394# 1395proc explain_no_trace {sql} { 1396 set tr [db eval "EXPLAIN $sql"] 1397 return [lrange $tr 7 end] 1398} 1399 1400# Another procedure to execute SQL. This one includes the field 1401# names in the returned list. 1402# 1403proc execsql2 {sql} { 1404 set result {} 1405 db eval $sql data { 1406 foreach f $data(*) { 1407 lappend result $f $data($f) 1408 } 1409 } 1410 return $result 1411} 1412 1413# Use a temporary in-memory database to execute SQL statements 1414# 1415proc memdbsql {sql} { 1416 sqlite3 memdb :memory: 1417 set result [memdb eval $sql] 1418 memdb close 1419 return $result 1420} 1421 1422# Use the non-callback API to execute multiple SQL statements 1423# 1424proc stepsql {dbptr sql} { 1425 set sql [string trim $sql] 1426 set r 0 1427 while {[string length $sql]>0} { 1428 if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} { 1429 return [list 1 $vm] 1430 } 1431 set sql [string trim $sqltail] 1432# while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} { 1433# foreach v $VAL {lappend r $v} 1434# } 1435 while {[sqlite3_step $vm]=="SQLITE_ROW"} { 1436 for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} { 1437 lappend r [sqlite3_column_text $vm $i] 1438 } 1439 } 1440 if {[catch {sqlite3_finalize $vm} errmsg]} { 1441 return [list 1 $errmsg] 1442 } 1443 } 1444 return $r 1445} 1446 1447# Do an integrity check of the entire database 1448# 1449proc integrity_check {name {db db}} { 1450 ifcapable integrityck { 1451 do_test $name [list execsql {PRAGMA integrity_check} $db] {ok} 1452 } 1453} 1454 1455# Check the extended error code 1456# 1457proc verify_ex_errcode {name expected {db db}} { 1458 do_test $name [list sqlite3_extended_errcode $db] $expected 1459} 1460 1461 1462# Return true if the SQL statement passed as the second argument uses a 1463# statement transaction. 1464# 1465proc sql_uses_stmt {db sql} { 1466 set stmt [sqlite3_prepare $db $sql -1 dummy] 1467 set uses [uses_stmt_journal $stmt] 1468 sqlite3_finalize $stmt 1469 return $uses 1470} 1471 1472proc fix_ifcapable_expr {expr} { 1473 set ret "" 1474 set state 0 1475 for {set i 0} {$i < [string length $expr]} {incr i} { 1476 set char [string range $expr $i $i] 1477 set newstate [expr {[string is alnum $char] || $char eq "_"}] 1478 if {$newstate && !$state} { 1479 append ret {$::sqlite_options(} 1480 } 1481 if {!$newstate && $state} { 1482 append ret ) 1483 } 1484 append ret $char 1485 set state $newstate 1486 } 1487 if {$state} {append ret )} 1488 return $ret 1489} 1490 1491# Returns non-zero if the capabilities are present; zero otherwise. 1492# 1493proc capable {expr} { 1494 set e [fix_ifcapable_expr $expr]; return [expr ($e)] 1495} 1496 1497# Evaluate a boolean expression of capabilities. If true, execute the 1498# code. Omit the code if false. 1499# 1500proc ifcapable {expr code {else ""} {elsecode ""}} { 1501 #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2 1502 set e2 [fix_ifcapable_expr $expr] 1503 if ($e2) { 1504 set c [catch {uplevel 1 $code} r] 1505 } else { 1506 set c [catch {uplevel 1 $elsecode} r] 1507 } 1508 return -code $c $r 1509} 1510 1511# This proc execs a seperate process that crashes midway through executing 1512# the SQL script $sql on database test.db. 1513# 1514# The crash occurs during a sync() of file $crashfile. When the crash 1515# occurs a random subset of all unsynced writes made by the process are 1516# written into the files on disk. Argument $crashdelay indicates the 1517# number of file syncs to wait before crashing. 1518# 1519# The return value is a list of two elements. The first element is a 1520# boolean, indicating whether or not the process actually crashed or 1521# reported some other error. The second element in the returned list is the 1522# error message. This is "child process exited abnormally" if the crash 1523# occurred. 1524# 1525# crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql 1526# 1527proc crashsql {args} { 1528 1529 set blocksize "" 1530 set crashdelay 1 1531 set prngseed 0 1532 set opendb { sqlite3 db test.db -vfs crash } 1533 set tclbody {} 1534 set crashfile "" 1535 set dc "" 1536 set dfltvfs 0 1537 set sql [lindex $args end] 1538 1539 for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} { 1540 set z [lindex $args $ii] 1541 set n [string length $z] 1542 set z2 [lindex $args [expr $ii+1]] 1543 1544 if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \ 1545 elseif {$n>1 && [string first $z -opendb]==0} {set opendb $z2} \ 1546 elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \ 1547 elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \ 1548 elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \ 1549 elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \ 1550 elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" }\ 1551 elseif {$n>1 && [string first $z -dfltvfs]==0} {set dfltvfs $z2 }\ 1552 else { error "Unrecognized option: $z" } 1553 } 1554 1555 if {$crashfile eq ""} { 1556 error "Compulsory option -file missing" 1557 } 1558 1559 # $crashfile gets compared to the native filename in 1560 # cfSync(), which can be different then what TCL uses by 1561 # default, so here we force it to the "nativename" format. 1562 set cfile [string map {\\ \\\\} [file nativename [file join [get_pwd] $crashfile]]] 1563 1564 set f [open crash.tcl w] 1565 puts $f "sqlite3_crash_enable 1 $dfltvfs" 1566 puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile" 1567 puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" 1568 1569 # This block sets the cache size of the main database to 10 1570 # pages. This is done in case the build is configured to omit 1571 # "PRAGMA cache_size". 1572 if {$opendb!=""} { 1573 puts $f $opendb 1574 puts $f {db eval {SELECT * FROM sqlite_master;}} 1575 puts $f {set bt [btree_from_db db]} 1576 puts $f {btree_set_cache_size $bt 10} 1577 } 1578 1579 if {$prngseed} { 1580 set seed [expr {$prngseed%10007+1}] 1581 # puts seed=$seed 1582 puts $f "db eval {SELECT randomblob($seed)}" 1583 } 1584 1585 if {[string length $tclbody]>0} { 1586 puts $f $tclbody 1587 } 1588 if {[string length $sql]>0} { 1589 puts $f "db eval {" 1590 puts $f "$sql" 1591 puts $f "}" 1592 } 1593 close $f 1594 set r [catch { 1595 exec [info nameofexec] crash.tcl >@stdout 1596 } msg] 1597 1598 # Windows/ActiveState TCL returns a slightly different 1599 # error message. We map that to the expected message 1600 # so that we don't have to change all of the test 1601 # cases. 1602 if {$::tcl_platform(platform)=="windows"} { 1603 if {$msg=="child killed: unknown signal"} { 1604 set msg "child process exited abnormally" 1605 } 1606 } 1607 1608 lappend r $msg 1609} 1610 1611proc run_ioerr_prep {} { 1612 set ::sqlite_io_error_pending 0 1613 catch {db close} 1614 catch {db2 close} 1615 catch {forcedelete test.db} 1616 catch {forcedelete test.db-journal} 1617 catch {forcedelete test2.db} 1618 catch {forcedelete test2.db-journal} 1619 set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] 1620 sqlite3_extended_result_codes $::DB $::ioerropts(-erc) 1621 if {[info exists ::ioerropts(-tclprep)]} { 1622 eval $::ioerropts(-tclprep) 1623 } 1624 if {[info exists ::ioerropts(-sqlprep)]} { 1625 execsql $::ioerropts(-sqlprep) 1626 } 1627 expr 0 1628} 1629 1630# Usage: do_ioerr_test <test number> <options...> 1631# 1632# This proc is used to implement test cases that check that IO errors 1633# are correctly handled. The first argument, <test number>, is an integer 1634# used to name the tests executed by this proc. Options are as follows: 1635# 1636# -tclprep TCL script to run to prepare test. 1637# -sqlprep SQL script to run to prepare test. 1638# -tclbody TCL script to run with IO error simulation. 1639# -sqlbody TCL script to run with IO error simulation. 1640# -exclude List of 'N' values not to test. 1641# -erc Use extended result codes 1642# -persist Make simulated I/O errors persistent 1643# -start Value of 'N' to begin with (default 1) 1644# 1645# -cksum Boolean. If true, test that the database does 1646# not change during the execution of the test case. 1647# 1648proc do_ioerr_test {testname args} { 1649 1650 set ::ioerropts(-start) 1 1651 set ::ioerropts(-cksum) 0 1652 set ::ioerropts(-erc) 0 1653 set ::ioerropts(-count) 100000000 1654 set ::ioerropts(-persist) 1 1655 set ::ioerropts(-ckrefcount) 0 1656 set ::ioerropts(-restoreprng) 1 1657 array set ::ioerropts $args 1658 1659 # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are 1660 # a couple of obscure IO errors that do not return them. 1661 set ::ioerropts(-erc) 0 1662 1663 # Create a single TCL script from the TCL and SQL specified 1664 # as the body of the test. 1665 set ::ioerrorbody {} 1666 if {[info exists ::ioerropts(-tclbody)]} { 1667 append ::ioerrorbody "$::ioerropts(-tclbody)\n" 1668 } 1669 if {[info exists ::ioerropts(-sqlbody)]} { 1670 append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}" 1671 } 1672 1673 save_prng_state 1674 if {$::ioerropts(-cksum)} { 1675 run_ioerr_prep 1676 eval $::ioerrorbody 1677 set ::goodcksum [cksum] 1678 } 1679 1680 set ::go 1 1681 #reset_prng_state 1682 for {set n $::ioerropts(-start)} {$::go} {incr n} { 1683 set ::TN $n 1684 incr ::ioerropts(-count) -1 1685 if {$::ioerropts(-count)<0} break 1686 1687 # Skip this IO error if it was specified with the "-exclude" option. 1688 if {[info exists ::ioerropts(-exclude)]} { 1689 if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue 1690 } 1691 if {$::ioerropts(-restoreprng)} { 1692 restore_prng_state 1693 } 1694 1695 # Delete the files test.db and test2.db, then execute the TCL and 1696 # SQL (in that order) to prepare for the test case. 1697 do_test $testname.$n.1 { 1698 run_ioerr_prep 1699 } {0} 1700 1701 # Read the 'checksum' of the database. 1702 if {$::ioerropts(-cksum)} { 1703 set ::checksum [cksum] 1704 } 1705 1706 # Set the Nth IO error to fail. 1707 do_test $testname.$n.2 [subst { 1708 set ::sqlite_io_error_persist $::ioerropts(-persist) 1709 set ::sqlite_io_error_pending $n 1710 }] $n 1711 1712 # Execute the TCL script created for the body of this test. If 1713 # at least N IO operations performed by SQLite as a result of 1714 # the script, the Nth will fail. 1715 do_test $testname.$n.3 { 1716 set ::sqlite_io_error_hit 0 1717 set ::sqlite_io_error_hardhit 0 1718 set r [catch $::ioerrorbody msg] 1719 set ::errseen $r 1720 set rc [sqlite3_errcode $::DB] 1721 if {$::ioerropts(-erc)} { 1722 # If we are in extended result code mode, make sure all of the 1723 # IOERRs we get back really do have their extended code values. 1724 # If an extended result code is returned, the sqlite3_errcode 1725 # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn 1726 # where nnnn is a number 1727 if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} { 1728 return $rc 1729 } 1730 } else { 1731 # If we are not in extended result code mode, make sure no 1732 # extended error codes are returned. 1733 if {[regexp {\+\d} $rc]} { 1734 return $rc 1735 } 1736 } 1737 # The test repeats as long as $::go is non-zero. $::go starts out 1738 # as 1. When a test runs to completion without hitting an I/O 1739 # error, that means there is no point in continuing with this test 1740 # case so set $::go to zero. 1741 # 1742 if {$::sqlite_io_error_pending>0} { 1743 set ::go 0 1744 set q 0 1745 set ::sqlite_io_error_pending 0 1746 } else { 1747 set q 1 1748 } 1749 1750 set s [expr $::sqlite_io_error_hit==0] 1751 if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} { 1752 set r 1 1753 } 1754 set ::sqlite_io_error_hit 0 1755 1756 # One of two things must have happened. either 1757 # 1. We never hit the IO error and the SQL returned OK 1758 # 2. An IO error was hit and the SQL failed 1759 # 1760 #puts "s=$s r=$r q=$q" 1761 expr { ($s && !$r && !$q) || (!$s && $r && $q) } 1762 } {1} 1763 1764 set ::sqlite_io_error_hit 0 1765 set ::sqlite_io_error_pending 0 1766 1767 # Check that no page references were leaked. There should be 1768 # a single reference if there is still an active transaction, 1769 # or zero otherwise. 1770 # 1771 # UPDATE: If the IO error occurs after a 'BEGIN' but before any 1772 # locks are established on database files (i.e. if the error 1773 # occurs while attempting to detect a hot-journal file), then 1774 # there may 0 page references and an active transaction according 1775 # to [sqlite3_get_autocommit]. 1776 # 1777 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} { 1778 do_test $testname.$n.4 { 1779 set bt [btree_from_db db] 1780 db_enter db 1781 array set stats [btree_pager_stats $bt] 1782 db_leave db 1783 set nRef $stats(ref) 1784 expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)} 1785 } {1} 1786 } 1787 1788 # If there is an open database handle and no open transaction, 1789 # and the pager is not running in exclusive-locking mode, 1790 # check that the pager is in "unlocked" state. Theoretically, 1791 # if a call to xUnlock() failed due to an IO error the underlying 1792 # file may still be locked. 1793 # 1794 ifcapable pragma { 1795 if { [info commands db] ne "" 1796 && $::ioerropts(-ckrefcount) 1797 && [db one {pragma locking_mode}] eq "normal" 1798 && [sqlite3_get_autocommit db] 1799 } { 1800 do_test $testname.$n.5 { 1801 set bt [btree_from_db db] 1802 db_enter db 1803 array set stats [btree_pager_stats $bt] 1804 db_leave db 1805 set stats(state) 1806 } 0 1807 } 1808 } 1809 1810 # If an IO error occurred, then the checksum of the database should 1811 # be the same as before the script that caused the IO error was run. 1812 # 1813 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} { 1814 do_test $testname.$n.6 { 1815 catch {db close} 1816 catch {db2 close} 1817 set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] 1818 set nowcksum [cksum] 1819 set res [expr {$nowcksum==$::checksum || $nowcksum==$::goodcksum}] 1820 if {$res==0} { 1821 output2 "now=$nowcksum" 1822 output2 "the=$::checksum" 1823 output2 "fwd=$::goodcksum" 1824 } 1825 set res 1826 } 1 1827 } 1828 1829 set ::sqlite_io_error_hardhit 0 1830 set ::sqlite_io_error_pending 0 1831 if {[info exists ::ioerropts(-cleanup)]} { 1832 catch $::ioerropts(-cleanup) 1833 } 1834 } 1835 set ::sqlite_io_error_pending 0 1836 set ::sqlite_io_error_persist 0 1837 unset ::ioerropts 1838} 1839 1840# Return a checksum based on the contents of the main database associated 1841# with connection $db 1842# 1843proc cksum {{db db}} { 1844 set txt [$db eval { 1845 SELECT name, type, sql FROM sqlite_master order by name 1846 }]\n 1847 foreach tbl [$db eval { 1848 SELECT name FROM sqlite_master WHERE type='table' order by name 1849 }] { 1850 append txt [$db eval "SELECT * FROM $tbl"]\n 1851 } 1852 foreach prag {default_synchronous default_cache_size} { 1853 append txt $prag-[$db eval "PRAGMA $prag"]\n 1854 } 1855 set cksum [string length $txt]-[md5 $txt] 1856 # puts $cksum-[file size test.db] 1857 return $cksum 1858} 1859 1860# Generate a checksum based on the contents of the main and temp tables 1861# database $db. If the checksum of two databases is the same, and the 1862# integrity-check passes for both, the two databases are identical. 1863# 1864proc allcksum {{db db}} { 1865 set ret [list] 1866 ifcapable tempdb { 1867 set sql { 1868 SELECT name FROM sqlite_master WHERE type = 'table' UNION 1869 SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION 1870 SELECT 'sqlite_master' UNION 1871 SELECT 'sqlite_temp_master' ORDER BY 1 1872 } 1873 } else { 1874 set sql { 1875 SELECT name FROM sqlite_master WHERE type = 'table' UNION 1876 SELECT 'sqlite_master' ORDER BY 1 1877 } 1878 } 1879 set tbllist [$db eval $sql] 1880 set txt {} 1881 foreach tbl $tbllist { 1882 append txt [$db eval "SELECT * FROM $tbl"] 1883 } 1884 foreach prag {default_cache_size} { 1885 append txt $prag-[$db eval "PRAGMA $prag"]\n 1886 } 1887 # puts txt=$txt 1888 return [md5 $txt] 1889} 1890 1891# Generate a checksum based on the contents of a single database with 1892# a database connection. The name of the database is $dbname. 1893# Examples of $dbname are "temp" or "main". 1894# 1895proc dbcksum {db dbname} { 1896 if {$dbname=="temp"} { 1897 set master sqlite_temp_master 1898 } else { 1899 set master $dbname.sqlite_master 1900 } 1901 set alltab [$db eval "SELECT name FROM $master WHERE type='table'"] 1902 set txt [$db eval "SELECT * FROM $master"]\n 1903 foreach tab $alltab { 1904 append txt [$db eval "SELECT * FROM $dbname.$tab"]\n 1905 } 1906 return [md5 $txt] 1907} 1908 1909proc memdebug_log_sql {{filename mallocs.sql}} { 1910 1911 set data [sqlite3_memdebug_log dump] 1912 set nFrame [expr [llength [lindex $data 0]]-2] 1913 if {$nFrame < 0} { return "" } 1914 1915 set database temp 1916 1917 set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);" 1918 1919 set sql "" 1920 foreach e $data { 1921 set nCall [lindex $e 0] 1922 set nByte [lindex $e 1] 1923 set lStack [lrange $e 2 end] 1924 append sql "INSERT INTO ${database}.malloc VALUES" 1925 append sql "('test', $nCall, $nByte, '$lStack');\n" 1926 foreach f $lStack { 1927 set frames($f) 1 1928 } 1929 } 1930 1931 set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n" 1932 set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n" 1933 1934 foreach f [array names frames] { 1935 set addr [format %x $f] 1936 set cmd "addr2line -e [info nameofexec] $addr" 1937 set line [eval exec $cmd] 1938 append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n" 1939 1940 set file [lindex [split $line :] 0] 1941 set files($file) 1 1942 } 1943 1944 foreach f [array names files] { 1945 set contents "" 1946 catch { 1947 set fd [open $f] 1948 set contents [read $fd] 1949 close $fd 1950 } 1951 set contents [string map {' ''} $contents] 1952 append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n" 1953 } 1954 1955 set fd [open $filename w] 1956 puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;" 1957 close $fd 1958} 1959 1960# Drop all tables in database [db] 1961proc drop_all_tables {{db db}} { 1962 ifcapable trigger&&foreignkey { 1963 set pk [$db one "PRAGMA foreign_keys"] 1964 $db eval "PRAGMA foreign_keys = OFF" 1965 } 1966 foreach {idx name file} [db eval {PRAGMA database_list}] { 1967 if {$idx==1} { 1968 set master sqlite_temp_master 1969 } else { 1970 set master $name.sqlite_master 1971 } 1972 foreach {t type} [$db eval " 1973 SELECT name, type FROM $master 1974 WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X' 1975 "] { 1976 $db eval "DROP $type \"$t\"" 1977 } 1978 } 1979 ifcapable trigger&&foreignkey { 1980 $db eval "PRAGMA foreign_keys = $pk" 1981 } 1982} 1983 1984# Drop all auxiliary indexes from the main database opened by handle [db]. 1985# 1986proc drop_all_indexes {{db db}} { 1987 set L [$db eval { 1988 SELECT name FROM sqlite_master WHERE type='index' AND sql LIKE 'create%' 1989 }] 1990 foreach idx $L { $db eval "DROP INDEX $idx" } 1991} 1992 1993 1994#------------------------------------------------------------------------- 1995# If a test script is executed with global variable $::G(perm:name) set to 1996# "wal", then the tests are run in WAL mode. Otherwise, they should be run 1997# in rollback mode. The following Tcl procs are used to make this less 1998# intrusive: 1999# 2000# wal_set_journal_mode ?DB? 2001# 2002# If running a WAL test, execute "PRAGMA journal_mode = wal" using 2003# connection handle DB. Otherwise, this command is a no-op. 2004# 2005# wal_check_journal_mode TESTNAME ?DB? 2006# 2007# If running a WAL test, execute a tests case that fails if the main 2008# database for connection handle DB is not currently a WAL database. 2009# Otherwise (if not running a WAL permutation) this is a no-op. 2010# 2011# wal_is_wal_mode 2012# 2013# Returns true if this test should be run in WAL mode. False otherwise. 2014# 2015proc wal_is_wal_mode {} { 2016 expr {[permutation] eq "wal"} 2017} 2018proc wal_set_journal_mode {{db db}} { 2019 if { [wal_is_wal_mode] } { 2020 $db eval "PRAGMA journal_mode = WAL" 2021 } 2022} 2023proc wal_check_journal_mode {testname {db db}} { 2024 if { [wal_is_wal_mode] } { 2025 $db eval { SELECT * FROM sqlite_master } 2026 do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal} 2027 } 2028} 2029 2030proc wal_is_capable {} { 2031 ifcapable !wal { return 0 } 2032 if {[permutation]=="journaltest"} { return 0 } 2033 return 1 2034} 2035 2036proc permutation {} { 2037 set perm "" 2038 catch {set perm $::G(perm:name)} 2039 set perm 2040} 2041proc presql {} { 2042 set presql "" 2043 catch {set presql $::G(perm:presql)} 2044 set presql 2045} 2046 2047proc isquick {} { 2048 set ret 0 2049 catch {set ret $::G(isquick)} 2050 set ret 2051} 2052 2053#------------------------------------------------------------------------- 2054# 2055proc slave_test_script {script} { 2056 2057 # Create the interpreter used to run the test script. 2058 interp create tinterp 2059 2060 # Populate some global variables that tester.tcl expects to see. 2061 foreach {var value} [list \ 2062 ::argv0 $::argv0 \ 2063 ::argv {} \ 2064 ::SLAVE 1 \ 2065 ] { 2066 interp eval tinterp [list set $var $value] 2067 } 2068 2069 # If output is being copied into a file, share the file-descriptor with 2070 # the interpreter. 2071 if {[info exists ::G(output_fd)]} { 2072 interp share {} $::G(output_fd) tinterp 2073 } 2074 2075 # The alias used to access the global test counters. 2076 tinterp alias set_test_counter set_test_counter 2077 2078 # Set up the ::cmdlinearg array in the slave. 2079 interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]] 2080 2081 # Set up the ::G array in the slave. 2082 interp eval tinterp [list array set ::G [array get ::G]] 2083 2084 # Load the various test interfaces implemented in C. 2085 load_testfixture_extensions tinterp 2086 2087 # Run the test script. 2088 interp eval tinterp $script 2089 2090 # Check if the interpreter call [run_thread_tests] 2091 if { [interp eval tinterp {info exists ::run_thread_tests_called}] } { 2092 set ::run_thread_tests_called 1 2093 } 2094 2095 # Delete the interpreter used to run the test script. 2096 interp delete tinterp 2097} 2098 2099proc slave_test_file {zFile} { 2100 set tail [file tail $zFile] 2101 2102 if {[info exists ::G(start:permutation)]} { 2103 if {[permutation] != $::G(start:permutation)} return 2104 unset ::G(start:permutation) 2105 } 2106 if {[info exists ::G(start:file)]} { 2107 if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return 2108 unset ::G(start:file) 2109 } 2110 2111 # Remember the value of the shared-cache setting. So that it is possible 2112 # to check afterwards that it was not modified by the test script. 2113 # 2114 ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] } 2115 2116 # Run the test script in a slave interpreter. 2117 # 2118 unset -nocomplain ::run_thread_tests_called 2119 reset_prng_state 2120 set ::sqlite_open_file_count 0 2121 set time [time { slave_test_script [list source $zFile] }] 2122 set ms [expr [lindex $time 0] / 1000] 2123 2124 # Test that all files opened by the test script were closed. Omit this 2125 # if the test script has "thread" in its name. The open file counter 2126 # is not thread-safe. 2127 # 2128 if {[info exists ::run_thread_tests_called]==0} { 2129 do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0} 2130 } 2131 set ::sqlite_open_file_count 0 2132 2133 # Test that the global "shared-cache" setting was not altered by 2134 # the test script. 2135 # 2136 ifcapable shared_cache { 2137 set res [expr {[sqlite3_enable_shared_cache] == $scs}] 2138 do_test ${tail}-sharedcachesetting [list set {} $res] 1 2139 } 2140 2141 # Add some info to the output. 2142 # 2143 output2 "Time: $tail $ms ms" 2144 show_memstats 2145} 2146 2147# Open a new connection on database test.db and execute the SQL script 2148# supplied as an argument. Before returning, close the new conection and 2149# restore the 4 byte fields starting at header offsets 28, 92 and 96 2150# to the values they held before the SQL was executed. This simulates 2151# a write by a pre-3.7.0 client. 2152# 2153proc sql36231 {sql} { 2154 set B [hexio_read test.db 92 8] 2155 set A [hexio_read test.db 28 4] 2156 sqlite3 db36231 test.db 2157 catch { db36231 func a_string a_string } 2158 execsql $sql db36231 2159 db36231 close 2160 hexio_write test.db 28 $A 2161 hexio_write test.db 92 $B 2162 return "" 2163} 2164 2165proc db_save {} { 2166 foreach f [glob -nocomplain sv_test.db*] { forcedelete $f } 2167 foreach f [glob -nocomplain test.db*] { 2168 set f2 "sv_$f" 2169 forcecopy $f $f2 2170 } 2171} 2172proc db_save_and_close {} { 2173 db_save 2174 catch { db close } 2175 return "" 2176} 2177proc db_restore {} { 2178 foreach f [glob -nocomplain test.db*] { forcedelete $f } 2179 foreach f2 [glob -nocomplain sv_test.db*] { 2180 set f [string range $f2 3 end] 2181 forcecopy $f2 $f 2182 } 2183} 2184proc db_restore_and_reopen {{dbfile test.db}} { 2185 catch { db close } 2186 db_restore 2187 sqlite3 db $dbfile 2188} 2189proc db_delete_and_reopen {{file test.db}} { 2190 catch { db close } 2191 foreach f [glob -nocomplain test.db*] { forcedelete $f } 2192 sqlite3 db $file 2193} 2194 2195# Close any connections named [db], [db2] or [db3]. Then use sqlite3_config 2196# to configure the size of the PAGECACHE allocation using the parameters 2197# provided to this command. Save the old PAGECACHE parameters in a global 2198# variable so that [test_restore_config_pagecache] can restore the previous 2199# configuration. 2200# 2201# Before returning, reopen connection [db] on file test.db. 2202# 2203proc test_set_config_pagecache {sz nPg} { 2204 catch {db close} 2205 catch {db2 close} 2206 catch {db3 close} 2207 2208 sqlite3_shutdown 2209 set ::old_pagecache_config [sqlite3_config_pagecache $sz $nPg] 2210 sqlite3_initialize 2211 autoinstall_test_functions 2212 reset_db 2213} 2214 2215# Close any connections named [db], [db2] or [db3]. Then use sqlite3_config 2216# to configure the size of the PAGECACHE allocation to the size saved in 2217# the global variable by an earlier call to [test_set_config_pagecache]. 2218# 2219# Before returning, reopen connection [db] on file test.db. 2220# 2221proc test_restore_config_pagecache {} { 2222 catch {db close} 2223 catch {db2 close} 2224 catch {db3 close} 2225 2226 sqlite3_shutdown 2227 eval sqlite3_config_pagecache $::old_pagecache_config 2228 unset ::old_pagecache_config 2229 sqlite3_initialize 2230 autoinstall_test_functions 2231 sqlite3 db test.db 2232} 2233 2234proc test_find_binary {nm} { 2235 if {$::tcl_platform(platform)=="windows"} { 2236 set ret "$nm.exe" 2237 } else { 2238 set ret $nm 2239 } 2240 set ret [file normalize [file join $::cmdlinearg(TESTFIXTURE_HOME) $ret]] 2241 if {![file executable $ret]} { 2242 finish_test 2243 return "" 2244 } 2245 return $ret 2246} 2247 2248# Find the name of the 'shell' executable (e.g. "sqlite3.exe") to use for 2249# the tests in shell[1-5].test. If no such executable can be found, invoke 2250# [finish_test ; return] in the callers context. 2251# 2252proc test_find_cli {} { 2253 set prog [test_find_binary sqlite3] 2254 if {$prog==""} { return -code return } 2255 return $prog 2256} 2257 2258# Find the name of the 'sqldiff' executable (e.g. "sqlite3.exe") to use for 2259# the tests in sqldiff tests. If no such executable can be found, invoke 2260# [finish_test ; return] in the callers context. 2261# 2262proc test_find_sqldiff {} { 2263 set prog [test_find_binary sqldiff] 2264 if {$prog==""} { return -code return } 2265 return $prog 2266} 2267 2268 2269# If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set 2270# to non-zero, then set the global variable $AUTOVACUUM to 1. 2271set AUTOVACUUM $sqlite_options(default_autovacuum) 2272 2273# Make sure the FTS enhanced query syntax is disabled. 2274set sqlite_fts3_enable_parentheses 0 2275 2276# During testing, assume that all database files are well-formed. The 2277# few test cases that deliberately corrupt database files should rescind 2278# this setting by invoking "database_can_be_corrupt" 2279# 2280database_never_corrupt 2281 2282source $testdir/thread_common.tcl 2283source $testdir/malloc_common.tcl 2284