Annotation of embedaddon/sqlite3/test/tester.tcl, revision 1.1
1.1 ! misho 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: # copy_file FROM TO
! 23: # delete_file FILENAME
! 24: # drop_all_tables ?DB?
! 25: # forcecopy FROM TO
! 26: # forcedelete FILENAME
! 27: #
! 28: # Test the capability of the SQLite version built into the interpreter to
! 29: # determine if a specific test can be run:
! 30: #
! 31: # ifcapable EXPR
! 32: #
! 33: # Calulate checksums based on database contents:
! 34: #
! 35: # dbcksum DB DBNAME
! 36: # allcksum ?DB?
! 37: # cksum ?DB?
! 38: #
! 39: # Commands to execute/explain SQL statements:
! 40: #
! 41: # stepsql DB SQL
! 42: # execsql2 SQL
! 43: # explain_no_trace SQL
! 44: # explain SQL ?DB?
! 45: # catchsql SQL ?DB?
! 46: # execsql SQL ?DB?
! 47: #
! 48: # Commands to run test cases:
! 49: #
! 50: # do_ioerr_test TESTNAME ARGS...
! 51: # crashsql ARGS...
! 52: # integrity_check TESTNAME ?DB?
! 53: # do_test TESTNAME SCRIPT EXPECTED
! 54: # do_execsql_test TESTNAME SQL EXPECTED
! 55: # do_catchsql_test TESTNAME SQL EXPECTED
! 56: #
! 57: # Commands providing a lower level interface to the global test counters:
! 58: #
! 59: # set_test_counter COUNTER ?VALUE?
! 60: # omit_test TESTNAME REASON ?APPEND?
! 61: # fail_test TESTNAME
! 62: # incr_ntest
! 63: #
! 64: # Command run at the end of each test file:
! 65: #
! 66: # finish_test
! 67: #
! 68: # Commands to help create test files that run with the "WAL" and other
! 69: # permutations (see file permutations.test):
! 70: #
! 71: # wal_is_wal_mode
! 72: # wal_set_journal_mode ?DB?
! 73: # wal_check_journal_mode TESTNAME?DB?
! 74: # permutation
! 75: # presql
! 76: #
! 77:
! 78: # Set the precision of FP arithmatic used by the interpreter. And
! 79: # configure SQLite to take database file locks on the page that begins
! 80: # 64KB into the database file instead of the one 1GB in. This means
! 81: # the code that handles that special case can be tested without creating
! 82: # very large database files.
! 83: #
! 84: set tcl_precision 15
! 85: sqlite3_test_control_pending_byte 0x0010000
! 86:
! 87:
! 88: # If the pager codec is available, create a wrapper for the [sqlite3]
! 89: # command that appends "-key {xyzzy}" to the command line. i.e. this:
! 90: #
! 91: # sqlite3 db test.db
! 92: #
! 93: # becomes
! 94: #
! 95: # sqlite3 db test.db -key {xyzzy}
! 96: #
! 97: if {[info command sqlite_orig]==""} {
! 98: rename sqlite3 sqlite_orig
! 99: proc sqlite3 {args} {
! 100: if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} {
! 101: # This command is opening a new database connection.
! 102: #
! 103: if {[info exists ::G(perm:sqlite3_args)]} {
! 104: set args [concat $args $::G(perm:sqlite3_args)]
! 105: }
! 106: if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} {
! 107: lappend args -key {xyzzy}
! 108: }
! 109:
! 110: set res [uplevel 1 sqlite_orig $args]
! 111: if {[info exists ::G(perm:presql)]} {
! 112: [lindex $args 0] eval $::G(perm:presql)
! 113: }
! 114: if {[info exists ::G(perm:dbconfig)]} {
! 115: set ::dbhandle [lindex $args 0]
! 116: uplevel #0 $::G(perm:dbconfig)
! 117: }
! 118: set res
! 119: } else {
! 120: # This command is not opening a new database connection. Pass the
! 121: # arguments through to the C implemenation as the are.
! 122: #
! 123: uplevel 1 sqlite_orig $args
! 124: }
! 125: }
! 126: }
! 127:
! 128: proc getFileRetries {} {
! 129: if {![info exists ::G(file-retries)]} {
! 130: #
! 131: # NOTE: Return the default number of retries for [file] operations. A
! 132: # value of zero or less here means "disabled".
! 133: #
! 134: return [expr {$::tcl_platform(platform) eq "windows" ? 10 : 0}]
! 135: }
! 136: return $::G(file-retries)
! 137: }
! 138:
! 139: proc getFileRetryDelay {} {
! 140: if {![info exists ::G(file-retry-delay)]} {
! 141: #
! 142: # NOTE: Return the default number of milliseconds to wait when retrying
! 143: # failed [file] operations. A value of zero or less means "do not
! 144: # wait".
! 145: #
! 146: return 100; # TODO: Good default?
! 147: }
! 148: return $::G(file-retry-delay)
! 149: }
! 150:
! 151: # Copy file $from into $to. This is used because some versions of
! 152: # TCL for windows (notably the 8.4.1 binary package shipped with the
! 153: # current mingw release) have a broken "file copy" command.
! 154: #
! 155: proc copy_file {from to} {
! 156: do_copy_file false $from $to
! 157: }
! 158:
! 159: proc forcecopy {from to} {
! 160: do_copy_file true $from $to
! 161: }
! 162:
! 163: proc do_copy_file {force from to} {
! 164: set nRetry [getFileRetries] ;# Maximum number of retries.
! 165: set nDelay [getFileRetryDelay] ;# Delay in ms before retrying.
! 166:
! 167: # On windows, sometimes even a [file copy -force] can fail. The cause is
! 168: # usually "tag-alongs" - programs like anti-virus software, automatic backup
! 169: # tools and various explorer extensions that keep a file open a little longer
! 170: # than we expect, causing the delete to fail.
! 171: #
! 172: # The solution is to wait a short amount of time before retrying the copy.
! 173: #
! 174: if {$nRetry > 0} {
! 175: for {set i 0} {$i<$nRetry} {incr i} {
! 176: set rc [catch {
! 177: if {$force} {
! 178: file copy -force $from $to
! 179: } else {
! 180: file copy $from $to
! 181: }
! 182: } msg]
! 183: if {$rc==0} break
! 184: if {$nDelay > 0} { after $nDelay }
! 185: }
! 186: if {$rc} { error $msg }
! 187: } else {
! 188: if {$force} {
! 189: file copy -force $from $to
! 190: } else {
! 191: file copy $from $to
! 192: }
! 193: }
! 194: }
! 195:
! 196: # Delete a file or directory
! 197: #
! 198: proc delete_file {args} {
! 199: do_delete_file false {*}$args
! 200: }
! 201:
! 202: proc forcedelete {args} {
! 203: do_delete_file true {*}$args
! 204: }
! 205:
! 206: proc do_delete_file {force args} {
! 207: set nRetry [getFileRetries] ;# Maximum number of retries.
! 208: set nDelay [getFileRetryDelay] ;# Delay in ms before retrying.
! 209:
! 210: foreach filename $args {
! 211: # On windows, sometimes even a [file delete -force] can fail just after
! 212: # a file is closed. The cause is usually "tag-alongs" - programs like
! 213: # anti-virus software, automatic backup tools and various explorer
! 214: # extensions that keep a file open a little longer than we expect, causing
! 215: # the delete to fail.
! 216: #
! 217: # The solution is to wait a short amount of time before retrying the
! 218: # delete.
! 219: #
! 220: if {$nRetry > 0} {
! 221: for {set i 0} {$i<$nRetry} {incr i} {
! 222: set rc [catch {
! 223: if {$force} {
! 224: file delete -force $filename
! 225: } else {
! 226: file delete $filename
! 227: }
! 228: } msg]
! 229: if {$rc==0} break
! 230: if {$nDelay > 0} { after $nDelay }
! 231: }
! 232: if {$rc} { error $msg }
! 233: } else {
! 234: if {$force} {
! 235: file delete -force $filename
! 236: } else {
! 237: file delete $filename
! 238: }
! 239: }
! 240: }
! 241: }
! 242:
! 243: proc execpresql {handle args} {
! 244: trace remove execution $handle enter [list execpresql $handle]
! 245: if {[info exists ::G(perm:presql)]} {
! 246: $handle eval $::G(perm:presql)
! 247: }
! 248: }
! 249:
! 250: # This command should be called after loading tester.tcl from within
! 251: # all test scripts that are incompatible with encryption codecs.
! 252: #
! 253: proc do_not_use_codec {} {
! 254: set ::do_not_use_codec 1
! 255: reset_db
! 256: }
! 257:
! 258: # The following block only runs the first time this file is sourced. It
! 259: # does not run in slave interpreters (since the ::cmdlinearg array is
! 260: # populated before the test script is run in slave interpreters).
! 261: #
! 262: if {[info exists cmdlinearg]==0} {
! 263:
! 264: # Parse any options specified in the $argv array. This script accepts the
! 265: # following options:
! 266: #
! 267: # --pause
! 268: # --soft-heap-limit=NN
! 269: # --maxerror=NN
! 270: # --malloctrace=N
! 271: # --backtrace=N
! 272: # --binarylog=N
! 273: # --soak=N
! 274: # --file-retries=N
! 275: # --file-retry-delay=N
! 276: # --start=[$permutation:]$testfile
! 277: # --match=$pattern
! 278: #
! 279: set cmdlinearg(soft-heap-limit) 0
! 280: set cmdlinearg(maxerror) 1000
! 281: set cmdlinearg(malloctrace) 0
! 282: set cmdlinearg(backtrace) 10
! 283: set cmdlinearg(binarylog) 0
! 284: set cmdlinearg(soak) 0
! 285: set cmdlinearg(file-retries) 0
! 286: set cmdlinearg(file-retry-delay) 0
! 287: set cmdlinearg(start) ""
! 288: set cmdlinearg(match) ""
! 289:
! 290: set leftover [list]
! 291: foreach a $argv {
! 292: switch -regexp -- $a {
! 293: {^-+pause$} {
! 294: # Wait for user input before continuing. This is to give the user an
! 295: # opportunity to connect profiling tools to the process.
! 296: puts -nonewline "Press RETURN to begin..."
! 297: flush stdout
! 298: gets stdin
! 299: }
! 300: {^-+soft-heap-limit=.+$} {
! 301: foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break
! 302: }
! 303: {^-+maxerror=.+$} {
! 304: foreach {dummy cmdlinearg(maxerror)} [split $a =] break
! 305: }
! 306: {^-+malloctrace=.+$} {
! 307: foreach {dummy cmdlinearg(malloctrace)} [split $a =] break
! 308: if {$cmdlinearg(malloctrace)} {
! 309: sqlite3_memdebug_log start
! 310: }
! 311: }
! 312: {^-+backtrace=.+$} {
! 313: foreach {dummy cmdlinearg(backtrace)} [split $a =] break
! 314: sqlite3_memdebug_backtrace $value
! 315: }
! 316: {^-+binarylog=.+$} {
! 317: foreach {dummy cmdlinearg(binarylog)} [split $a =] break
! 318: }
! 319: {^-+soak=.+$} {
! 320: foreach {dummy cmdlinearg(soak)} [split $a =] break
! 321: set ::G(issoak) $cmdlinearg(soak)
! 322: }
! 323: {^-+file-retries=.+$} {
! 324: foreach {dummy cmdlinearg(file-retries)} [split $a =] break
! 325: set ::G(file-retries) $cmdlinearg(file-retries)
! 326: }
! 327: {^-+file-retry-delay=.+$} {
! 328: foreach {dummy cmdlinearg(file-retry-delay)} [split $a =] break
! 329: set ::G(file-retry-delay) $cmdlinearg(file-retry-delay)
! 330: }
! 331: {^-+start=.+$} {
! 332: foreach {dummy cmdlinearg(start)} [split $a =] break
! 333:
! 334: set ::G(start:file) $cmdlinearg(start)
! 335: if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} {
! 336: set ::G(start:permutation) ${s.perm}
! 337: set ::G(start:file) ${s.file}
! 338: }
! 339: if {$::G(start:file) == ""} {unset ::G(start:file)}
! 340: }
! 341: {^-+match=.+$} {
! 342: foreach {dummy cmdlinearg(match)} [split $a =] break
! 343:
! 344: set ::G(match) $cmdlinearg(match)
! 345: if {$::G(match) == ""} {unset ::G(match)}
! 346: }
! 347: default {
! 348: lappend leftover $a
! 349: }
! 350: }
! 351: }
! 352: set argv $leftover
! 353:
! 354: # Install the malloc layer used to inject OOM errors. And the 'automatic'
! 355: # extensions. This only needs to be done once for the process.
! 356: #
! 357: sqlite3_shutdown
! 358: install_malloc_faultsim 1
! 359: sqlite3_initialize
! 360: autoinstall_test_functions
! 361:
! 362: # If the --binarylog option was specified, create the logging VFS. This
! 363: # call installs the new VFS as the default for all SQLite connections.
! 364: #
! 365: if {$cmdlinearg(binarylog)} {
! 366: vfslog new binarylog {} vfslog.bin
! 367: }
! 368:
! 369: # Set the backtrace depth, if malloc tracing is enabled.
! 370: #
! 371: if {$cmdlinearg(malloctrace)} {
! 372: sqlite3_memdebug_backtrace $cmdlinearg(backtrace)
! 373: }
! 374: }
! 375:
! 376: # Update the soft-heap-limit each time this script is run. In that
! 377: # way if an individual test file changes the soft-heap-limit, it
! 378: # will be reset at the start of the next test file.
! 379: #
! 380: sqlite3_soft_heap_limit $cmdlinearg(soft-heap-limit)
! 381:
! 382: # Create a test database
! 383: #
! 384: proc reset_db {} {
! 385: catch {db close}
! 386: forcedelete test.db
! 387: forcedelete test.db-journal
! 388: forcedelete test.db-wal
! 389: sqlite3 db ./test.db
! 390: set ::DB [sqlite3_connection_pointer db]
! 391: if {[info exists ::SETUP_SQL]} {
! 392: db eval $::SETUP_SQL
! 393: }
! 394: }
! 395: reset_db
! 396:
! 397: # Abort early if this script has been run before.
! 398: #
! 399: if {[info exists TC(count)]} return
! 400:
! 401: # Make sure memory statistics are enabled.
! 402: #
! 403: sqlite3_config_memstatus 1
! 404:
! 405: # Initialize the test counters and set up commands to access them.
! 406: # Or, if this is a slave interpreter, set up aliases to write the
! 407: # counters in the parent interpreter.
! 408: #
! 409: if {0==[info exists ::SLAVE]} {
! 410: set TC(errors) 0
! 411: set TC(count) 0
! 412: set TC(fail_list) [list]
! 413: set TC(omit_list) [list]
! 414:
! 415: proc set_test_counter {counter args} {
! 416: if {[llength $args]} {
! 417: set ::TC($counter) [lindex $args 0]
! 418: }
! 419: set ::TC($counter)
! 420: }
! 421: }
! 422:
! 423: # Record the fact that a sequence of tests were omitted.
! 424: #
! 425: proc omit_test {name reason {append 1}} {
! 426: set omitList [set_test_counter omit_list]
! 427: if {$append} {
! 428: lappend omitList [list $name $reason]
! 429: }
! 430: set_test_counter omit_list $omitList
! 431: }
! 432:
! 433: # Record the fact that a test failed.
! 434: #
! 435: proc fail_test {name} {
! 436: set f [set_test_counter fail_list]
! 437: lappend f $name
! 438: set_test_counter fail_list $f
! 439: set_test_counter errors [expr [set_test_counter errors] + 1]
! 440:
! 441: set nFail [set_test_counter errors]
! 442: if {$nFail>=$::cmdlinearg(maxerror)} {
! 443: puts "*** Giving up..."
! 444: finalize_testing
! 445: }
! 446: }
! 447:
! 448: # Increment the number of tests run
! 449: #
! 450: proc incr_ntest {} {
! 451: set_test_counter count [expr [set_test_counter count] + 1]
! 452: }
! 453:
! 454:
! 455: # Invoke the do_test procedure to run a single test
! 456: #
! 457: proc do_test {name cmd expected} {
! 458:
! 459: global argv cmdlinearg
! 460:
! 461: fix_testname name
! 462:
! 463: sqlite3_memdebug_settitle $name
! 464:
! 465: # if {[llength $argv]==0} {
! 466: # set go 1
! 467: # } else {
! 468: # set go 0
! 469: # foreach pattern $argv {
! 470: # if {[string match $pattern $name]} {
! 471: # set go 1
! 472: # break
! 473: # }
! 474: # }
! 475: # }
! 476:
! 477: if {[info exists ::G(perm:prefix)]} {
! 478: set name "$::G(perm:prefix)$name"
! 479: }
! 480:
! 481: incr_ntest
! 482: puts -nonewline $name...
! 483: flush stdout
! 484:
! 485: if {![info exists ::G(match)] || [string match $::G(match) $name]} {
! 486: if {[catch {uplevel #0 "$cmd;\n"} result]} {
! 487: puts "\nError: $result"
! 488: fail_test $name
! 489: } elseif {[string compare $result $expected]} {
! 490: puts "\nExpected: \[$expected\]\n Got: \[$result\]"
! 491: fail_test $name
! 492: } else {
! 493: puts " Ok"
! 494: }
! 495: } else {
! 496: puts " Omitted"
! 497: omit_test $name "pattern mismatch" 0
! 498: }
! 499: flush stdout
! 500: }
! 501:
! 502: proc filepath_normalize {p} {
! 503: # test cases should be written to assume "unix"-like file paths
! 504: if {$::tcl_platform(platform)!="unix"} {
! 505: # lreverse*2 as a hack to remove any unneeded {} after the string map
! 506: lreverse [lreverse [string map {\\ /} [regsub -nocase -all {[a-z]:[/\\]+} $p {/}]]]
! 507: } {
! 508: set p
! 509: }
! 510: }
! 511: proc do_filepath_test {name cmd expected} {
! 512: uplevel [list do_test $name [
! 513: subst -nocommands { filepath_normalize [ $cmd ] }
! 514: ] [filepath_normalize $expected]]
! 515: }
! 516:
! 517: proc realnum_normalize {r} {
! 518: # different TCL versions display floating point values differently.
! 519: string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}]
! 520: }
! 521: proc do_realnum_test {name cmd expected} {
! 522: uplevel [list do_test $name [
! 523: subst -nocommands { realnum_normalize [ $cmd ] }
! 524: ] [realnum_normalize $expected]]
! 525: }
! 526:
! 527: proc fix_testname {varname} {
! 528: upvar $varname testname
! 529: if {[info exists ::testprefix]
! 530: && [string is digit [string range $testname 0 0]]
! 531: } {
! 532: set testname "${::testprefix}-$testname"
! 533: }
! 534: }
! 535:
! 536: proc do_execsql_test {testname sql {result {}}} {
! 537: fix_testname testname
! 538: uplevel do_test [list $testname] [list "execsql {$sql}"] [list [list {*}$result]]
! 539: }
! 540: proc do_catchsql_test {testname sql result} {
! 541: fix_testname testname
! 542: uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result]
! 543: }
! 544: proc do_eqp_test {name sql res} {
! 545: uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res]
! 546: }
! 547:
! 548: #-------------------------------------------------------------------------
! 549: # Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST
! 550: #
! 551: # Where switches are:
! 552: #
! 553: # -errorformat FMTSTRING
! 554: # -count
! 555: # -query SQL
! 556: # -tclquery TCL
! 557: # -repair TCL
! 558: #
! 559: proc do_select_tests {prefix args} {
! 560:
! 561: set testlist [lindex $args end]
! 562: set switches [lrange $args 0 end-1]
! 563:
! 564: set errfmt ""
! 565: set countonly 0
! 566: set tclquery ""
! 567: set repair ""
! 568:
! 569: for {set i 0} {$i < [llength $switches]} {incr i} {
! 570: set s [lindex $switches $i]
! 571: set n [string length $s]
! 572: if {$n>=2 && [string equal -length $n $s "-query"]} {
! 573: set tclquery [list execsql [lindex $switches [incr i]]]
! 574: } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} {
! 575: set tclquery [lindex $switches [incr i]]
! 576: } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} {
! 577: set errfmt [lindex $switches [incr i]]
! 578: } elseif {$n>=2 && [string equal -length $n $s "-repair"]} {
! 579: set repair [lindex $switches [incr i]]
! 580: } elseif {$n>=2 && [string equal -length $n $s "-count"]} {
! 581: set countonly 1
! 582: } else {
! 583: error "unknown switch: $s"
! 584: }
! 585: }
! 586:
! 587: if {$countonly && $errfmt!=""} {
! 588: error "Cannot use -count and -errorformat together"
! 589: }
! 590: set nTestlist [llength $testlist]
! 591: if {$nTestlist%3 || $nTestlist==0 } {
! 592: error "SELECT test list contains [llength $testlist] elements"
! 593: }
! 594:
! 595: eval $repair
! 596: foreach {tn sql res} $testlist {
! 597: if {$tclquery != ""} {
! 598: execsql $sql
! 599: uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]]
! 600: } elseif {$countonly} {
! 601: set nRow 0
! 602: db eval $sql {incr nRow}
! 603: uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res]
! 604: } elseif {$errfmt==""} {
! 605: uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]]
! 606: } else {
! 607: set res [list 1 [string trim [format $errfmt {*}$res]]]
! 608: uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res]
! 609: }
! 610: eval $repair
! 611: }
! 612:
! 613: }
! 614:
! 615: proc delete_all_data {} {
! 616: db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} {
! 617: db eval "DELETE FROM '[string map {' ''} $t]'"
! 618: }
! 619: }
! 620:
! 621: # Run an SQL script.
! 622: # Return the number of microseconds per statement.
! 623: #
! 624: proc speed_trial {name numstmt units sql} {
! 625: puts -nonewline [format {%-21.21s } $name...]
! 626: flush stdout
! 627: set speed [time {sqlite3_exec_nr db $sql}]
! 628: set tm [lindex $speed 0]
! 629: if {$tm == 0} {
! 630: set rate [format %20s "many"]
! 631: } else {
! 632: set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
! 633: }
! 634: set u2 $units/s
! 635: puts [format {%12d uS %s %s} $tm $rate $u2]
! 636: global total_time
! 637: set total_time [expr {$total_time+$tm}]
! 638: lappend ::speed_trial_times $name $tm
! 639: }
! 640: proc speed_trial_tcl {name numstmt units script} {
! 641: puts -nonewline [format {%-21.21s } $name...]
! 642: flush stdout
! 643: set speed [time {eval $script}]
! 644: set tm [lindex $speed 0]
! 645: if {$tm == 0} {
! 646: set rate [format %20s "many"]
! 647: } else {
! 648: set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
! 649: }
! 650: set u2 $units/s
! 651: puts [format {%12d uS %s %s} $tm $rate $u2]
! 652: global total_time
! 653: set total_time [expr {$total_time+$tm}]
! 654: lappend ::speed_trial_times $name $tm
! 655: }
! 656: proc speed_trial_init {name} {
! 657: global total_time
! 658: set total_time 0
! 659: set ::speed_trial_times [list]
! 660: sqlite3 versdb :memory:
! 661: set vers [versdb one {SELECT sqlite_source_id()}]
! 662: versdb close
! 663: puts "SQLite $vers"
! 664: }
! 665: proc speed_trial_summary {name} {
! 666: global total_time
! 667: puts [format {%-21.21s %12d uS TOTAL} $name $total_time]
! 668:
! 669: if { 0 } {
! 670: sqlite3 versdb :memory:
! 671: set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0]
! 672: versdb close
! 673: puts "CREATE TABLE IF NOT EXISTS time(version, script, test, us);"
! 674: foreach {test us} $::speed_trial_times {
! 675: puts "INSERT INTO time VALUES('$vers', '$name', '$test', $us);"
! 676: }
! 677: }
! 678: }
! 679:
! 680: # Run this routine last
! 681: #
! 682: proc finish_test {} {
! 683: catch {db close}
! 684: catch {db2 close}
! 685: catch {db3 close}
! 686: if {0==[info exists ::SLAVE]} { finalize_testing }
! 687: }
! 688: proc finalize_testing {} {
! 689: global sqlite_open_file_count
! 690:
! 691: set omitList [set_test_counter omit_list]
! 692:
! 693: catch {db close}
! 694: catch {db2 close}
! 695: catch {db3 close}
! 696:
! 697: vfs_unlink_test
! 698: sqlite3 db {}
! 699: # sqlite3_clear_tsd_memdebug
! 700: db close
! 701: sqlite3_reset_auto_extension
! 702:
! 703: sqlite3_soft_heap_limit 0
! 704: set nTest [incr_ntest]
! 705: set nErr [set_test_counter errors]
! 706:
! 707: puts "$nErr errors out of $nTest tests"
! 708: if {$nErr>0} {
! 709: puts "Failures on these tests: [set_test_counter fail_list]"
! 710: }
! 711: run_thread_tests 1
! 712: if {[llength $omitList]>0} {
! 713: puts "Omitted test cases:"
! 714: set prec {}
! 715: foreach {rec} [lsort $omitList] {
! 716: if {$rec==$prec} continue
! 717: set prec $rec
! 718: puts [format { %-12s %s} [lindex $rec 0] [lindex $rec 1]]
! 719: }
! 720: }
! 721: if {$nErr>0 && ![working_64bit_int]} {
! 722: puts "******************************************************************"
! 723: puts "N.B.: The version of TCL that you used to build this test harness"
! 724: puts "is defective in that it does not support 64-bit integers. Some or"
! 725: puts "all of the test failures above might be a result from this defect"
! 726: puts "in your TCL build."
! 727: puts "******************************************************************"
! 728: }
! 729: if {$::cmdlinearg(binarylog)} {
! 730: vfslog finalize binarylog
! 731: }
! 732: if {$sqlite_open_file_count} {
! 733: puts "$sqlite_open_file_count files were left open"
! 734: incr nErr
! 735: }
! 736: if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 ||
! 737: [sqlite3_memory_used]>0} {
! 738: puts "Unfreed memory: [sqlite3_memory_used] bytes in\
! 739: [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations"
! 740: incr nErr
! 741: ifcapable memdebug||mem5||(mem3&&debug) {
! 742: puts "Writing unfreed memory log to \"./memleak.txt\""
! 743: sqlite3_memdebug_dump ./memleak.txt
! 744: }
! 745: } else {
! 746: puts "All memory allocations freed - no leaks"
! 747: ifcapable memdebug||mem5 {
! 748: sqlite3_memdebug_dump ./memusage.txt
! 749: }
! 750: }
! 751: show_memstats
! 752: puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
! 753: puts "Current memory usage: [sqlite3_memory_highwater] bytes"
! 754: if {[info commands sqlite3_memdebug_malloc_count] ne ""} {
! 755: puts "Number of malloc() : [sqlite3_memdebug_malloc_count] calls"
! 756: }
! 757: if {$::cmdlinearg(malloctrace)} {
! 758: puts "Writing mallocs.sql..."
! 759: memdebug_log_sql
! 760: sqlite3_memdebug_log stop
! 761: sqlite3_memdebug_log clear
! 762:
! 763: if {[sqlite3_memory_used]>0} {
! 764: puts "Writing leaks.sql..."
! 765: sqlite3_memdebug_log sync
! 766: memdebug_log_sql leaks.sql
! 767: }
! 768: }
! 769: foreach f [glob -nocomplain test.db-*-journal] {
! 770: forcedelete $f
! 771: }
! 772: foreach f [glob -nocomplain test.db-mj*] {
! 773: forcedelete $f
! 774: }
! 775: exit [expr {$nErr>0}]
! 776: }
! 777:
! 778: # Display memory statistics for analysis and debugging purposes.
! 779: #
! 780: proc show_memstats {} {
! 781: set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]
! 782: set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]
! 783: set val [format {now %10d max %10d max-size %10d} \
! 784: [lindex $x 1] [lindex $x 2] [lindex $y 2]]
! 785: puts "Memory used: $val"
! 786: set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0]
! 787: set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]]
! 788: puts "Allocation count: $val"
! 789: set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]
! 790: set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]
! 791: set val [format {now %10d max %10d max-size %10d} \
! 792: [lindex $x 1] [lindex $x 2] [lindex $y 2]]
! 793: puts "Page-cache used: $val"
! 794: set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]
! 795: set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]]
! 796: puts "Page-cache overflow: $val"
! 797: set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]
! 798: set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]]
! 799: puts "Scratch memory used: $val"
! 800: set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]
! 801: set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]
! 802: set val [format {now %10d max %10d max-size %10d} \
! 803: [lindex $x 1] [lindex $x 2] [lindex $y 2]]
! 804: puts "Scratch overflow: $val"
! 805: ifcapable yytrackmaxstackdepth {
! 806: set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]
! 807: set val [format { max %10d} [lindex $x 2]]
! 808: puts "Parser stack depth: $val"
! 809: }
! 810: }
! 811:
! 812: # A procedure to execute SQL
! 813: #
! 814: proc execsql {sql {db db}} {
! 815: # puts "SQL = $sql"
! 816: uplevel [list $db eval $sql]
! 817: }
! 818:
! 819: # Execute SQL and catch exceptions.
! 820: #
! 821: proc catchsql {sql {db db}} {
! 822: # puts "SQL = $sql"
! 823: set r [catch [list uplevel [list $db eval $sql]] msg]
! 824: lappend r $msg
! 825: return $r
! 826: }
! 827:
! 828: # Do an VDBE code dump on the SQL given
! 829: #
! 830: proc explain {sql {db db}} {
! 831: puts ""
! 832: puts "addr opcode p1 p2 p3 p4 p5 #"
! 833: puts "---- ------------ ------ ------ ------ --------------- -- -"
! 834: $db eval "explain $sql" {} {
! 835: puts [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \
! 836: $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
! 837: ]
! 838: }
! 839: }
! 840:
! 841: # Show the VDBE program for an SQL statement but omit the Trace
! 842: # opcode at the beginning. This procedure can be used to prove
! 843: # that different SQL statements generate exactly the same VDBE code.
! 844: #
! 845: proc explain_no_trace {sql} {
! 846: set tr [db eval "EXPLAIN $sql"]
! 847: return [lrange $tr 7 end]
! 848: }
! 849:
! 850: # Another procedure to execute SQL. This one includes the field
! 851: # names in the returned list.
! 852: #
! 853: proc execsql2 {sql} {
! 854: set result {}
! 855: db eval $sql data {
! 856: foreach f $data(*) {
! 857: lappend result $f $data($f)
! 858: }
! 859: }
! 860: return $result
! 861: }
! 862:
! 863: # Use the non-callback API to execute multiple SQL statements
! 864: #
! 865: proc stepsql {dbptr sql} {
! 866: set sql [string trim $sql]
! 867: set r 0
! 868: while {[string length $sql]>0} {
! 869: if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {
! 870: return [list 1 $vm]
! 871: }
! 872: set sql [string trim $sqltail]
! 873: # while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
! 874: # foreach v $VAL {lappend r $v}
! 875: # }
! 876: while {[sqlite3_step $vm]=="SQLITE_ROW"} {
! 877: for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {
! 878: lappend r [sqlite3_column_text $vm $i]
! 879: }
! 880: }
! 881: if {[catch {sqlite3_finalize $vm} errmsg]} {
! 882: return [list 1 $errmsg]
! 883: }
! 884: }
! 885: return $r
! 886: }
! 887:
! 888: # Do an integrity check of the entire database
! 889: #
! 890: proc integrity_check {name {db db}} {
! 891: ifcapable integrityck {
! 892: do_test $name [list execsql {PRAGMA integrity_check} $db] {ok}
! 893: }
! 894: }
! 895:
! 896:
! 897: # Return true if the SQL statement passed as the second argument uses a
! 898: # statement transaction.
! 899: #
! 900: proc sql_uses_stmt {db sql} {
! 901: set stmt [sqlite3_prepare $db $sql -1 dummy]
! 902: set uses [uses_stmt_journal $stmt]
! 903: sqlite3_finalize $stmt
! 904: return $uses
! 905: }
! 906:
! 907: proc fix_ifcapable_expr {expr} {
! 908: set ret ""
! 909: set state 0
! 910: for {set i 0} {$i < [string length $expr]} {incr i} {
! 911: set char [string range $expr $i $i]
! 912: set newstate [expr {[string is alnum $char] || $char eq "_"}]
! 913: if {$newstate && !$state} {
! 914: append ret {$::sqlite_options(}
! 915: }
! 916: if {!$newstate && $state} {
! 917: append ret )
! 918: }
! 919: append ret $char
! 920: set state $newstate
! 921: }
! 922: if {$state} {append ret )}
! 923: return $ret
! 924: }
! 925:
! 926: # Evaluate a boolean expression of capabilities. If true, execute the
! 927: # code. Omit the code if false.
! 928: #
! 929: proc ifcapable {expr code {else ""} {elsecode ""}} {
! 930: #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
! 931: set e2 [fix_ifcapable_expr $expr]
! 932: if ($e2) {
! 933: set c [catch {uplevel 1 $code} r]
! 934: } else {
! 935: set c [catch {uplevel 1 $elsecode} r]
! 936: }
! 937: return -code $c $r
! 938: }
! 939:
! 940: # This proc execs a seperate process that crashes midway through executing
! 941: # the SQL script $sql on database test.db.
! 942: #
! 943: # The crash occurs during a sync() of file $crashfile. When the crash
! 944: # occurs a random subset of all unsynced writes made by the process are
! 945: # written into the files on disk. Argument $crashdelay indicates the
! 946: # number of file syncs to wait before crashing.
! 947: #
! 948: # The return value is a list of two elements. The first element is a
! 949: # boolean, indicating whether or not the process actually crashed or
! 950: # reported some other error. The second element in the returned list is the
! 951: # error message. This is "child process exited abnormally" if the crash
! 952: # occured.
! 953: #
! 954: # crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
! 955: #
! 956: proc crashsql {args} {
! 957:
! 958: set blocksize ""
! 959: set crashdelay 1
! 960: set prngseed 0
! 961: set tclbody {}
! 962: set crashfile ""
! 963: set dc ""
! 964: set sql [lindex $args end]
! 965:
! 966: for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {
! 967: set z [lindex $args $ii]
! 968: set n [string length $z]
! 969: set z2 [lindex $args [expr $ii+1]]
! 970:
! 971: if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \
! 972: elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \
! 973: elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \
! 974: elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \
! 975: elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \
! 976: elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \
! 977: else { error "Unrecognized option: $z" }
! 978: }
! 979:
! 980: if {$crashfile eq ""} {
! 981: error "Compulsory option -file missing"
! 982: }
! 983:
! 984: # $crashfile gets compared to the native filename in
! 985: # cfSync(), which can be different then what TCL uses by
! 986: # default, so here we force it to the "nativename" format.
! 987: set cfile [string map {\\ \\\\} [file nativename [file join [pwd] $crashfile]]]
! 988:
! 989: set f [open crash.tcl w]
! 990: puts $f "sqlite3_crash_enable 1"
! 991: puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
! 992: puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
! 993: puts $f "sqlite3 db test.db -vfs crash"
! 994:
! 995: # This block sets the cache size of the main database to 10
! 996: # pages. This is done in case the build is configured to omit
! 997: # "PRAGMA cache_size".
! 998: puts $f {db eval {SELECT * FROM sqlite_master;}}
! 999: puts $f {set bt [btree_from_db db]}
! 1000: puts $f {btree_set_cache_size $bt 10}
! 1001: if {$prngseed} {
! 1002: set seed [expr {$prngseed%10007+1}]
! 1003: # puts seed=$seed
! 1004: puts $f "db eval {SELECT randomblob($seed)}"
! 1005: }
! 1006:
! 1007: if {[string length $tclbody]>0} {
! 1008: puts $f $tclbody
! 1009: }
! 1010: if {[string length $sql]>0} {
! 1011: puts $f "db eval {"
! 1012: puts $f "$sql"
! 1013: puts $f "}"
! 1014: }
! 1015: close $f
! 1016: set r [catch {
! 1017: exec [info nameofexec] crash.tcl >@stdout
! 1018: } msg]
! 1019:
! 1020: # Windows/ActiveState TCL returns a slightly different
! 1021: # error message. We map that to the expected message
! 1022: # so that we don't have to change all of the test
! 1023: # cases.
! 1024: if {$::tcl_platform(platform)=="windows"} {
! 1025: if {$msg=="child killed: unknown signal"} {
! 1026: set msg "child process exited abnormally"
! 1027: }
! 1028: }
! 1029:
! 1030: lappend r $msg
! 1031: }
! 1032:
! 1033: # Usage: do_ioerr_test <test number> <options...>
! 1034: #
! 1035: # This proc is used to implement test cases that check that IO errors
! 1036: # are correctly handled. The first argument, <test number>, is an integer
! 1037: # used to name the tests executed by this proc. Options are as follows:
! 1038: #
! 1039: # -tclprep TCL script to run to prepare test.
! 1040: # -sqlprep SQL script to run to prepare test.
! 1041: # -tclbody TCL script to run with IO error simulation.
! 1042: # -sqlbody TCL script to run with IO error simulation.
! 1043: # -exclude List of 'N' values not to test.
! 1044: # -erc Use extended result codes
! 1045: # -persist Make simulated I/O errors persistent
! 1046: # -start Value of 'N' to begin with (default 1)
! 1047: #
! 1048: # -cksum Boolean. If true, test that the database does
! 1049: # not change during the execution of the test case.
! 1050: #
! 1051: proc do_ioerr_test {testname args} {
! 1052:
! 1053: set ::ioerropts(-start) 1
! 1054: set ::ioerropts(-cksum) 0
! 1055: set ::ioerropts(-erc) 0
! 1056: set ::ioerropts(-count) 100000000
! 1057: set ::ioerropts(-persist) 1
! 1058: set ::ioerropts(-ckrefcount) 0
! 1059: set ::ioerropts(-restoreprng) 1
! 1060: array set ::ioerropts $args
! 1061:
! 1062: # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
! 1063: # a couple of obscure IO errors that do not return them.
! 1064: set ::ioerropts(-erc) 0
! 1065:
! 1066: set ::go 1
! 1067: #reset_prng_state
! 1068: save_prng_state
! 1069: for {set n $::ioerropts(-start)} {$::go} {incr n} {
! 1070: set ::TN $n
! 1071: incr ::ioerropts(-count) -1
! 1072: if {$::ioerropts(-count)<0} break
! 1073:
! 1074: # Skip this IO error if it was specified with the "-exclude" option.
! 1075: if {[info exists ::ioerropts(-exclude)]} {
! 1076: if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
! 1077: }
! 1078: if {$::ioerropts(-restoreprng)} {
! 1079: restore_prng_state
! 1080: }
! 1081:
! 1082: # Delete the files test.db and test2.db, then execute the TCL and
! 1083: # SQL (in that order) to prepare for the test case.
! 1084: do_test $testname.$n.1 {
! 1085: set ::sqlite_io_error_pending 0
! 1086: catch {db close}
! 1087: catch {db2 close}
! 1088: catch {forcedelete test.db}
! 1089: catch {forcedelete test.db-journal}
! 1090: catch {forcedelete test2.db}
! 1091: catch {forcedelete test2.db-journal}
! 1092: set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
! 1093: sqlite3_extended_result_codes $::DB $::ioerropts(-erc)
! 1094: if {[info exists ::ioerropts(-tclprep)]} {
! 1095: eval $::ioerropts(-tclprep)
! 1096: }
! 1097: if {[info exists ::ioerropts(-sqlprep)]} {
! 1098: execsql $::ioerropts(-sqlprep)
! 1099: }
! 1100: expr 0
! 1101: } {0}
! 1102:
! 1103: # Read the 'checksum' of the database.
! 1104: if {$::ioerropts(-cksum)} {
! 1105: set checksum [cksum]
! 1106: }
! 1107:
! 1108: # Set the Nth IO error to fail.
! 1109: do_test $testname.$n.2 [subst {
! 1110: set ::sqlite_io_error_persist $::ioerropts(-persist)
! 1111: set ::sqlite_io_error_pending $n
! 1112: }] $n
! 1113:
! 1114: # Create a single TCL script from the TCL and SQL specified
! 1115: # as the body of the test.
! 1116: set ::ioerrorbody {}
! 1117: if {[info exists ::ioerropts(-tclbody)]} {
! 1118: append ::ioerrorbody "$::ioerropts(-tclbody)\n"
! 1119: }
! 1120: if {[info exists ::ioerropts(-sqlbody)]} {
! 1121: append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
! 1122: }
! 1123:
! 1124: # Execute the TCL Script created in the above block. If
! 1125: # there are at least N IO operations performed by SQLite as
! 1126: # a result of the script, the Nth will fail.
! 1127: do_test $testname.$n.3 {
! 1128: set ::sqlite_io_error_hit 0
! 1129: set ::sqlite_io_error_hardhit 0
! 1130: set r [catch $::ioerrorbody msg]
! 1131: set ::errseen $r
! 1132: set rc [sqlite3_errcode $::DB]
! 1133: if {$::ioerropts(-erc)} {
! 1134: # If we are in extended result code mode, make sure all of the
! 1135: # IOERRs we get back really do have their extended code values.
! 1136: # If an extended result code is returned, the sqlite3_errcode
! 1137: # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn
! 1138: # where nnnn is a number
! 1139: if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {
! 1140: return $rc
! 1141: }
! 1142: } else {
! 1143: # If we are not in extended result code mode, make sure no
! 1144: # extended error codes are returned.
! 1145: if {[regexp {\+\d} $rc]} {
! 1146: return $rc
! 1147: }
! 1148: }
! 1149: # The test repeats as long as $::go is non-zero. $::go starts out
! 1150: # as 1. When a test runs to completion without hitting an I/O
! 1151: # error, that means there is no point in continuing with this test
! 1152: # case so set $::go to zero.
! 1153: #
! 1154: if {$::sqlite_io_error_pending>0} {
! 1155: set ::go 0
! 1156: set q 0
! 1157: set ::sqlite_io_error_pending 0
! 1158: } else {
! 1159: set q 1
! 1160: }
! 1161:
! 1162: set s [expr $::sqlite_io_error_hit==0]
! 1163: if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
! 1164: set r 1
! 1165: }
! 1166: set ::sqlite_io_error_hit 0
! 1167:
! 1168: # One of two things must have happened. either
! 1169: # 1. We never hit the IO error and the SQL returned OK
! 1170: # 2. An IO error was hit and the SQL failed
! 1171: #
! 1172: #puts "s=$s r=$r q=$q"
! 1173: expr { ($s && !$r && !$q) || (!$s && $r && $q) }
! 1174: } {1}
! 1175:
! 1176: set ::sqlite_io_error_hit 0
! 1177: set ::sqlite_io_error_pending 0
! 1178:
! 1179: # Check that no page references were leaked. There should be
! 1180: # a single reference if there is still an active transaction,
! 1181: # or zero otherwise.
! 1182: #
! 1183: # UPDATE: If the IO error occurs after a 'BEGIN' but before any
! 1184: # locks are established on database files (i.e. if the error
! 1185: # occurs while attempting to detect a hot-journal file), then
! 1186: # there may 0 page references and an active transaction according
! 1187: # to [sqlite3_get_autocommit].
! 1188: #
! 1189: if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
! 1190: do_test $testname.$n.4 {
! 1191: set bt [btree_from_db db]
! 1192: db_enter db
! 1193: array set stats [btree_pager_stats $bt]
! 1194: db_leave db
! 1195: set nRef $stats(ref)
! 1196: expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}
! 1197: } {1}
! 1198: }
! 1199:
! 1200: # If there is an open database handle and no open transaction,
! 1201: # and the pager is not running in exclusive-locking mode,
! 1202: # check that the pager is in "unlocked" state. Theoretically,
! 1203: # if a call to xUnlock() failed due to an IO error the underlying
! 1204: # file may still be locked.
! 1205: #
! 1206: ifcapable pragma {
! 1207: if { [info commands db] ne ""
! 1208: && $::ioerropts(-ckrefcount)
! 1209: && [db one {pragma locking_mode}] eq "normal"
! 1210: && [sqlite3_get_autocommit db]
! 1211: } {
! 1212: do_test $testname.$n.5 {
! 1213: set bt [btree_from_db db]
! 1214: db_enter db
! 1215: array set stats [btree_pager_stats $bt]
! 1216: db_leave db
! 1217: set stats(state)
! 1218: } 0
! 1219: }
! 1220: }
! 1221:
! 1222: # If an IO error occured, then the checksum of the database should
! 1223: # be the same as before the script that caused the IO error was run.
! 1224: #
! 1225: if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
! 1226: do_test $testname.$n.6 {
! 1227: catch {db close}
! 1228: catch {db2 close}
! 1229: set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
! 1230: cksum
! 1231: } $checksum
! 1232: }
! 1233:
! 1234: set ::sqlite_io_error_hardhit 0
! 1235: set ::sqlite_io_error_pending 0
! 1236: if {[info exists ::ioerropts(-cleanup)]} {
! 1237: catch $::ioerropts(-cleanup)
! 1238: }
! 1239: }
! 1240: set ::sqlite_io_error_pending 0
! 1241: set ::sqlite_io_error_persist 0
! 1242: unset ::ioerropts
! 1243: }
! 1244:
! 1245: # Return a checksum based on the contents of the main database associated
! 1246: # with connection $db
! 1247: #
! 1248: proc cksum {{db db}} {
! 1249: set txt [$db eval {
! 1250: SELECT name, type, sql FROM sqlite_master order by name
! 1251: }]\n
! 1252: foreach tbl [$db eval {
! 1253: SELECT name FROM sqlite_master WHERE type='table' order by name
! 1254: }] {
! 1255: append txt [$db eval "SELECT * FROM $tbl"]\n
! 1256: }
! 1257: foreach prag {default_synchronous default_cache_size} {
! 1258: append txt $prag-[$db eval "PRAGMA $prag"]\n
! 1259: }
! 1260: set cksum [string length $txt]-[md5 $txt]
! 1261: # puts $cksum-[file size test.db]
! 1262: return $cksum
! 1263: }
! 1264:
! 1265: # Generate a checksum based on the contents of the main and temp tables
! 1266: # database $db. If the checksum of two databases is the same, and the
! 1267: # integrity-check passes for both, the two databases are identical.
! 1268: #
! 1269: proc allcksum {{db db}} {
! 1270: set ret [list]
! 1271: ifcapable tempdb {
! 1272: set sql {
! 1273: SELECT name FROM sqlite_master WHERE type = 'table' UNION
! 1274: SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION
! 1275: SELECT 'sqlite_master' UNION
! 1276: SELECT 'sqlite_temp_master' ORDER BY 1
! 1277: }
! 1278: } else {
! 1279: set sql {
! 1280: SELECT name FROM sqlite_master WHERE type = 'table' UNION
! 1281: SELECT 'sqlite_master' ORDER BY 1
! 1282: }
! 1283: }
! 1284: set tbllist [$db eval $sql]
! 1285: set txt {}
! 1286: foreach tbl $tbllist {
! 1287: append txt [$db eval "SELECT * FROM $tbl"]
! 1288: }
! 1289: foreach prag {default_cache_size} {
! 1290: append txt $prag-[$db eval "PRAGMA $prag"]\n
! 1291: }
! 1292: # puts txt=$txt
! 1293: return [md5 $txt]
! 1294: }
! 1295:
! 1296: # Generate a checksum based on the contents of a single database with
! 1297: # a database connection. The name of the database is $dbname.
! 1298: # Examples of $dbname are "temp" or "main".
! 1299: #
! 1300: proc dbcksum {db dbname} {
! 1301: if {$dbname=="temp"} {
! 1302: set master sqlite_temp_master
! 1303: } else {
! 1304: set master $dbname.sqlite_master
! 1305: }
! 1306: set alltab [$db eval "SELECT name FROM $master WHERE type='table'"]
! 1307: set txt [$db eval "SELECT * FROM $master"]\n
! 1308: foreach tab $alltab {
! 1309: append txt [$db eval "SELECT * FROM $dbname.$tab"]\n
! 1310: }
! 1311: return [md5 $txt]
! 1312: }
! 1313:
! 1314: proc memdebug_log_sql {{filename mallocs.sql}} {
! 1315:
! 1316: set data [sqlite3_memdebug_log dump]
! 1317: set nFrame [expr [llength [lindex $data 0]]-2]
! 1318: if {$nFrame < 0} { return "" }
! 1319:
! 1320: set database temp
! 1321:
! 1322: set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);"
! 1323:
! 1324: set sql ""
! 1325: foreach e $data {
! 1326: set nCall [lindex $e 0]
! 1327: set nByte [lindex $e 1]
! 1328: set lStack [lrange $e 2 end]
! 1329: append sql "INSERT INTO ${database}.malloc VALUES"
! 1330: append sql "('test', $nCall, $nByte, '$lStack');\n"
! 1331: foreach f $lStack {
! 1332: set frames($f) 1
! 1333: }
! 1334: }
! 1335:
! 1336: set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
! 1337: set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
! 1338:
! 1339: foreach f [array names frames] {
! 1340: set addr [format %x $f]
! 1341: set cmd "addr2line -e [info nameofexec] $addr"
! 1342: set line [eval exec $cmd]
! 1343: append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
! 1344:
! 1345: set file [lindex [split $line :] 0]
! 1346: set files($file) 1
! 1347: }
! 1348:
! 1349: foreach f [array names files] {
! 1350: set contents ""
! 1351: catch {
! 1352: set fd [open $f]
! 1353: set contents [read $fd]
! 1354: close $fd
! 1355: }
! 1356: set contents [string map {' ''} $contents]
! 1357: append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
! 1358: }
! 1359:
! 1360: set fd [open $filename w]
! 1361: puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
! 1362: close $fd
! 1363: }
! 1364:
! 1365: # Drop all tables in database [db]
! 1366: proc drop_all_tables {{db db}} {
! 1367: ifcapable trigger&&foreignkey {
! 1368: set pk [$db one "PRAGMA foreign_keys"]
! 1369: $db eval "PRAGMA foreign_keys = OFF"
! 1370: }
! 1371: foreach {idx name file} [db eval {PRAGMA database_list}] {
! 1372: if {$idx==1} {
! 1373: set master sqlite_temp_master
! 1374: } else {
! 1375: set master $name.sqlite_master
! 1376: }
! 1377: foreach {t type} [$db eval "
! 1378: SELECT name, type FROM $master
! 1379: WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
! 1380: "] {
! 1381: $db eval "DROP $type \"$t\""
! 1382: }
! 1383: }
! 1384: ifcapable trigger&&foreignkey {
! 1385: $db eval "PRAGMA foreign_keys = $pk"
! 1386: }
! 1387: }
! 1388:
! 1389: #-------------------------------------------------------------------------
! 1390: # If a test script is executed with global variable $::G(perm:name) set to
! 1391: # "wal", then the tests are run in WAL mode. Otherwise, they should be run
! 1392: # in rollback mode. The following Tcl procs are used to make this less
! 1393: # intrusive:
! 1394: #
! 1395: # wal_set_journal_mode ?DB?
! 1396: #
! 1397: # If running a WAL test, execute "PRAGMA journal_mode = wal" using
! 1398: # connection handle DB. Otherwise, this command is a no-op.
! 1399: #
! 1400: # wal_check_journal_mode TESTNAME ?DB?
! 1401: #
! 1402: # If running a WAL test, execute a tests case that fails if the main
! 1403: # database for connection handle DB is not currently a WAL database.
! 1404: # Otherwise (if not running a WAL permutation) this is a no-op.
! 1405: #
! 1406: # wal_is_wal_mode
! 1407: #
! 1408: # Returns true if this test should be run in WAL mode. False otherwise.
! 1409: #
! 1410: proc wal_is_wal_mode {} {
! 1411: expr {[permutation] eq "wal"}
! 1412: }
! 1413: proc wal_set_journal_mode {{db db}} {
! 1414: if { [wal_is_wal_mode] } {
! 1415: $db eval "PRAGMA journal_mode = WAL"
! 1416: }
! 1417: }
! 1418: proc wal_check_journal_mode {testname {db db}} {
! 1419: if { [wal_is_wal_mode] } {
! 1420: $db eval { SELECT * FROM sqlite_master }
! 1421: do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal}
! 1422: }
! 1423: }
! 1424:
! 1425: proc permutation {} {
! 1426: set perm ""
! 1427: catch {set perm $::G(perm:name)}
! 1428: set perm
! 1429: }
! 1430: proc presql {} {
! 1431: set presql ""
! 1432: catch {set presql $::G(perm:presql)}
! 1433: set presql
! 1434: }
! 1435:
! 1436: #-------------------------------------------------------------------------
! 1437: #
! 1438: proc slave_test_script {script} {
! 1439:
! 1440: # Create the interpreter used to run the test script.
! 1441: interp create tinterp
! 1442:
! 1443: # Populate some global variables that tester.tcl expects to see.
! 1444: foreach {var value} [list \
! 1445: ::argv0 $::argv0 \
! 1446: ::argv {} \
! 1447: ::SLAVE 1 \
! 1448: ] {
! 1449: interp eval tinterp [list set $var $value]
! 1450: }
! 1451:
! 1452: # The alias used to access the global test counters.
! 1453: tinterp alias set_test_counter set_test_counter
! 1454:
! 1455: # Set up the ::cmdlinearg array in the slave.
! 1456: interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]]
! 1457:
! 1458: # Set up the ::G array in the slave.
! 1459: interp eval tinterp [list array set ::G [array get ::G]]
! 1460:
! 1461: # Load the various test interfaces implemented in C.
! 1462: load_testfixture_extensions tinterp
! 1463:
! 1464: # Run the test script.
! 1465: interp eval tinterp $script
! 1466:
! 1467: # Check if the interpreter call [run_thread_tests]
! 1468: if { [interp eval tinterp {info exists ::run_thread_tests_called}] } {
! 1469: set ::run_thread_tests_called 1
! 1470: }
! 1471:
! 1472: # Delete the interpreter used to run the test script.
! 1473: interp delete tinterp
! 1474: }
! 1475:
! 1476: proc slave_test_file {zFile} {
! 1477: set tail [file tail $zFile]
! 1478:
! 1479: if {[info exists ::G(start:permutation)]} {
! 1480: if {[permutation] != $::G(start:permutation)} return
! 1481: unset ::G(start:permutation)
! 1482: }
! 1483: if {[info exists ::G(start:file)]} {
! 1484: if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return
! 1485: unset ::G(start:file)
! 1486: }
! 1487:
! 1488: # Remember the value of the shared-cache setting. So that it is possible
! 1489: # to check afterwards that it was not modified by the test script.
! 1490: #
! 1491: ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] }
! 1492:
! 1493: # Run the test script in a slave interpreter.
! 1494: #
! 1495: unset -nocomplain ::run_thread_tests_called
! 1496: reset_prng_state
! 1497: set ::sqlite_open_file_count 0
! 1498: set time [time { slave_test_script [list source $zFile] }]
! 1499: set ms [expr [lindex $time 0] / 1000]
! 1500:
! 1501: # Test that all files opened by the test script were closed. Omit this
! 1502: # if the test script has "thread" in its name. The open file counter
! 1503: # is not thread-safe.
! 1504: #
! 1505: if {[info exists ::run_thread_tests_called]==0} {
! 1506: do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0}
! 1507: }
! 1508: set ::sqlite_open_file_count 0
! 1509:
! 1510: # Test that the global "shared-cache" setting was not altered by
! 1511: # the test script.
! 1512: #
! 1513: ifcapable shared_cache {
! 1514: set res [expr {[sqlite3_enable_shared_cache] == $scs}]
! 1515: do_test ${tail}-sharedcachesetting [list set {} $res] 1
! 1516: }
! 1517:
! 1518: # Add some info to the output.
! 1519: #
! 1520: puts "Time: $tail $ms ms"
! 1521: show_memstats
! 1522: }
! 1523:
! 1524: # Open a new connection on database test.db and execute the SQL script
! 1525: # supplied as an argument. Before returning, close the new conection and
! 1526: # restore the 4 byte fields starting at header offsets 28, 92 and 96
! 1527: # to the values they held before the SQL was executed. This simulates
! 1528: # a write by a pre-3.7.0 client.
! 1529: #
! 1530: proc sql36231 {sql} {
! 1531: set B [hexio_read test.db 92 8]
! 1532: set A [hexio_read test.db 28 4]
! 1533: sqlite3 db36231 test.db
! 1534: catch { db36231 func a_string a_string }
! 1535: execsql $sql db36231
! 1536: db36231 close
! 1537: hexio_write test.db 28 $A
! 1538: hexio_write test.db 92 $B
! 1539: return ""
! 1540: }
! 1541:
! 1542: proc db_save {} {
! 1543: foreach f [glob -nocomplain sv_test.db*] { forcedelete $f }
! 1544: foreach f [glob -nocomplain test.db*] {
! 1545: set f2 "sv_$f"
! 1546: forcecopy $f $f2
! 1547: }
! 1548: }
! 1549: proc db_save_and_close {} {
! 1550: db_save
! 1551: catch { db close }
! 1552: return ""
! 1553: }
! 1554: proc db_restore {} {
! 1555: foreach f [glob -nocomplain test.db*] { forcedelete $f }
! 1556: foreach f2 [glob -nocomplain sv_test.db*] {
! 1557: set f [string range $f2 3 end]
! 1558: forcecopy $f2 $f
! 1559: }
! 1560: }
! 1561: proc db_restore_and_reopen {{dbfile test.db}} {
! 1562: catch { db close }
! 1563: db_restore
! 1564: sqlite3 db $dbfile
! 1565: }
! 1566: proc db_delete_and_reopen {{file test.db}} {
! 1567: catch { db close }
! 1568: foreach f [glob -nocomplain test.db*] { forcedelete $f }
! 1569: sqlite3 db $file
! 1570: }
! 1571:
! 1572: # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
! 1573: # to non-zero, then set the global variable $AUTOVACUUM to 1.
! 1574: set AUTOVACUUM $sqlite_options(default_autovacuum)
! 1575:
! 1576: source $testdir/thread_common.tcl
! 1577: source $testdir/malloc_common.tcl
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to tester.tcl CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / sqlite3 / test