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