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