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