1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TclScript/tester.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1012 @@
1.4 +# 2001 September 15
1.5 +#
1.6 +# Portions Copyright (c) 2007-2010 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.7 +#
1.8 +# The author disclaims copyright to this source code. In place of
1.9 +# a legal notice, here is a blessing:
1.10 +#
1.11 +# May you do good and not evil.
1.12 +# May you find forgiveness for yourself and forgive others.
1.13 +# May you share freely, never taking more than you give.
1.14 +#
1.15 +#***********************************************************************
1.16 +# This file implements some common TCL routines used for regression
1.17 +# testing the SQLite library
1.18 +#
1.19 +# $Id: tester.tcl,v 1.134 2008/08/05 17:53:24 drh Exp $
1.20 +
1.21 +#
1.22 +# What for user input before continuing. This gives an opportunity
1.23 +# to connect profiling tools to the process.
1.24 +#
1.25 +for {set i 0} {$i<[llength $argv]} {incr i} {
1.26 + if {[regexp {^-+pause$} [lindex $argv $i] all value]} {
1.27 + puts -nonewline "Press RETURN to begin..."
1.28 + flush stdout
1.29 + gets stdin
1.30 + set argv [lreplace $argv $i $i]
1.31 + }
1.32 +}
1.33 +
1.34 +set tcl_precision 15
1.35 +set sqlite_pending_byte 0x0010000
1.36 +
1.37 +#
1.38 +# Check the command-line arguments for a default soft-heap-limit.
1.39 +# Store this default value in the global variable ::soft_limit and
1.40 +# update the soft-heap-limit each time this script is run. In that
1.41 +# way if an individual test file changes the soft-heap-limit, it
1.42 +# will be reset at the start of the next test file.
1.43 +#
1.44 +if {![info exists soft_limit]} {
1.45 + set soft_limit 0
1.46 + for {set i 0} {$i<[llength $argv]} {incr i} {
1.47 + if {[regexp {^--soft-heap-limit=(.+)$} [lindex $argv $i] all value]} {
1.48 + if {$value!="off"} {
1.49 + set soft_limit $value
1.50 + }
1.51 + set argv [lreplace $argv $i $i]
1.52 + }
1.53 + }
1.54 +}
1.55 +sqlite3_soft_heap_limit $soft_limit
1.56 +
1.57 +#
1.58 +# Check the command-line arguments to set the memory debugger
1.59 +# backtrace depth.
1.60 +#
1.61 +# See the sqlite3_memdebug_backtrace() function in mem2.c or
1.62 +# test_malloc.c for additional information.
1.63 +#
1.64 +for {set i 0} {$i<[llength $argv]} {incr i} {
1.65 + if {[lindex $argv $i] eq "--malloctrace"} {
1.66 + set argv [lreplace $argv $i $i]
1.67 + sqlite3_memdebug_backtrace 10
1.68 + sqlite3_memdebug_log start
1.69 + set tester_do_malloctrace 1
1.70 + }
1.71 +}
1.72 +for {set i 0} {$i<[llength $argv]} {incr i} {
1.73 + if {[regexp {^--backtrace=(\d+)$} [lindex $argv $i] all value]} {
1.74 + sqlite3_memdebug_backtrace $value
1.75 + set argv [lreplace $argv $i $i]
1.76 + }
1.77 +}
1.78 +
1.79 +
1.80 +proc ostrace_call {zCall nClick zFile i32 i64} {
1.81 + set s "INSERT INTO ostrace VALUES('$zCall', $nClick, '$zFile', $i32, $i64);"
1.82 + puts $::ostrace_fd $s
1.83 +}
1.84 +
1.85 +for {set i 0} {$i<[llength $argv]} {incr i} {
1.86 + if {[lindex $argv $i] eq "--ossummary" || [lindex $argv $i] eq "--ostrace"} {
1.87 + sqlite3_instvfs create -default ostrace
1.88 + set tester_do_ostrace 1
1.89 + set ostrace_fd [open ostrace.sql w]
1.90 + puts $ostrace_fd "BEGIN;"
1.91 + if {[lindex $argv $i] eq "--ostrace"} {
1.92 + set s "CREATE TABLE ostrace"
1.93 + append s "(method TEXT, clicks INT, file TEXT, i32 INT, i64 INT);"
1.94 + puts $ostrace_fd $s
1.95 + sqlite3_instvfs configure ostrace ostrace_call
1.96 + sqlite3_instvfs configure ostrace ostrace_call
1.97 + }
1.98 + set argv [lreplace $argv $i $i]
1.99 + }
1.100 + if {[lindex $argv $i] eq "--binarylog"} {
1.101 + set tester_do_binarylog 1
1.102 + set argv [lreplace $argv $i $i]
1.103 + }
1.104 +}
1.105 +
1.106 +#
1.107 +# Check the command-line arguments to set the maximum number of
1.108 +# errors tolerated before halting.
1.109 +#
1.110 +if {![info exists maxErr]} {
1.111 + set maxErr 1000
1.112 +}
1.113 +for {set i 0} {$i<[llength $argv]} {incr i} {
1.114 + if {[regexp {^--maxerror=(\d+)$} [lindex $argv $i] all maxErr]} {
1.115 + set argv [lreplace $argv $i $i]
1.116 + }
1.117 +}
1.118 +#puts "Max error = $maxErr"
1.119 +
1.120 +
1.121 +# Use the pager codec if it is available
1.122 +#
1.123 +if {[sqlite3 -has-codec] && [info command sqlite_orig]==""} {
1.124 + rename sqlite3 sqlite_orig
1.125 + proc sqlite3 {args} {
1.126 + if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} {
1.127 + lappend args -key {xyzzy}
1.128 + }
1.129 + uplevel 1 sqlite_orig $args
1.130 + }
1.131 +}
1.132 +
1.133 +
1.134 +# Create a test database
1.135 +#
1.136 +if {![info exists nTest]} {
1.137 + sqlite3_shutdown
1.138 + install_malloc_faultsim 1
1.139 + sqlite3_initialize
1.140 + if {[info exists tester_do_binarylog]} {
1.141 + sqlite3_instvfs binarylog -default binarylog ostrace.bin
1.142 + sqlite3_instvfs marker binarylog "$argv0 $argv"
1.143 + }
1.144 +}
1.145 +catch {db close}
1.146 +file delete -force test.db
1.147 +file delete -force test.db-journal
1.148 +sqlite3 db ./test.db
1.149 +set ::DB [sqlite3_connection_pointer db]
1.150 +if {[info exists ::SETUP_SQL]} {
1.151 + db eval $::SETUP_SQL
1.152 +}
1.153 +
1.154 +# Abort early if this script has been run before.
1.155 +#
1.156 +if {[info exists nTest]} return
1.157 +
1.158 +# Symbian OS globals
1.159 +set case_failure 0
1.160 +set nCases 0
1.161 +set nFailedCases 0
1.162 +
1.163 +# Set the test counters to zero
1.164 +#
1.165 +set nErr 0
1.166 +set nTest 0
1.167 +set skip_test 0
1.168 +set failList {}
1.169 +set omitList {}
1.170 +if {![info exists speedTest]} {
1.171 + set speedTest 0
1.172 +}
1.173 +
1.174 +# Record the fact that a sequence of tests were omitted.
1.175 +#
1.176 +proc omit_test {name reason} {
1.177 + global omitList
1.178 + lappend omitList [list $name $reason]
1.179 +}
1.180 +
1.181 +# Symbian OS: Added procedures to output test result in TEF format
1.182 +puts "<pre>"
1.183 +
1.184 +# Symbian OS: global procedure to handle test errors counter
1.185 +proc do_fail {name} {
1.186 + global case_failure nErr failList
1.187 + set case_failure 1
1.188 + incr nErr
1.189 + lappend ::failList $name
1.190 +}
1.191 +
1.192 +# Symbian OS: global procedure to output START_TESTCASE in TEF format
1.193 +proc start_case {name} {
1.194 + global case_failure nCases
1.195 + set case_failure 0
1.196 + incr nCases
1.197 + puts "<font color=00AF00> START_TESTCASE $name <\/font>"
1.198 +}
1.199 +
1.200 +# Symbian OS: global procedure to output END_TESTCASE in TEF format
1.201 +proc end_case {name} {
1.202 + global case_failure nFailedCases
1.203 + if {$case_failure} {
1.204 + incr nFailedCases
1.205 + puts "<font color=FF0000> END_TESTCASE $name ***TestCaseResult = FAIL <\/font>"
1.206 + } else {
1.207 + puts "<font color=00AF00> END_TESTCASE $name ***TestCaseResult = PASS <\/font>"
1.208 + }
1.209 +}
1.210 +
1.211 +# Symbian OS: global procedure to output test summary in TEF format
1.212 +proc tef_summary {} {
1.213 + global nCases nFailedCases
1.214 + set nPass [expr "$nCases - $nFailedCases"]
1.215 + puts "<font color=00AFFF>TEST STEP SUMMARY:<\/font>"
1.216 + puts "<font color=00AF00>PASS = $nCases<\/font>"
1.217 + puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"
1.218 + puts "<font color=00AFFF>TEST CASE SUMMARY:<\/font>"
1.219 + puts "<font color=00AF00>PASS = $nCases<\/font>"
1.220 + puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"
1.221 + puts "<\/pre>"
1.222 + flush stdout
1.223 +}
1.224 +
1.225 +# Invoke the do_test procedure to run a single test
1.226 +#
1.227 +proc do_test {name cmd expected} {
1.228 + global argv nErr nTest skip_test maxErr
1.229 + sqlite3_memdebug_settitle $name
1.230 + if {[info exists ::tester_do_binarylog]} {
1.231 + sqlite3_instvfs marker binarylog "Start of $name"
1.232 + }
1.233 + if {$skip_test} {
1.234 + set skip_test 0
1.235 + return
1.236 + }
1.237 + if {[llength $argv]==0} {
1.238 + set go 1
1.239 + } else {
1.240 + set go 0
1.241 + foreach pattern $argv {
1.242 + if {[string match $pattern $name]} {
1.243 + set go 1
1.244 + break
1.245 + }
1.246 + }
1.247 + }
1.248 + if {!$go} return
1.249 + incr nTest
1.250 + puts -nonewline $name...
1.251 + flush stdout
1.252 + if {[catch {uplevel #0 "$cmd;\n"} result]} {
1.253 + puts "\nError: $result"
1.254 + # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)
1.255 + do_fail $name
1.256 + print_text $name "FAILED"
1.257 + if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing}
1.258 + } elseif {[string compare $result $expected]} {
1.259 + puts "\nExpected: \[$expected\]\n Got: \[$result\]"
1.260 + # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)
1.261 + do_fail $name
1.262 + print_text $name "FAILED"
1.263 + if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing}
1.264 + } else {
1.265 + puts " Ok"
1.266 + print_text $name "OK"
1.267 + }
1.268 + flush stdout
1.269 + if {[info exists ::tester_do_binarylog]} {
1.270 + sqlite3_instvfs marker binarylog "End of $name"
1.271 + }
1.272 +}
1.273 +
1.274 +# Run an SQL script.
1.275 +# Return the number of microseconds per statement.
1.276 +#
1.277 +proc speed_trial {name numstmt units sql} {
1.278 + puts -nonewline [format {%-21.21s } $name...]
1.279 + flush stdout
1.280 + set speed [time {sqlite3_exec_nr db $sql}]
1.281 + set tm [lindex $speed 0]
1.282 + if {$tm == 0} {
1.283 + set rate [format %20s "many"]
1.284 + } else {
1.285 + set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
1.286 + }
1.287 + set u2 $units/s
1.288 + puts [format {%12d uS %s %s} $tm $rate $u2]
1.289 + global total_time
1.290 + set total_time [expr {$total_time+$tm}]
1.291 +}
1.292 +proc speed_trial_tcl {name numstmt units script} {
1.293 + puts -nonewline [format {%-21.21s } $name...]
1.294 + flush stdout
1.295 + set speed [time {eval $script}]
1.296 + set tm [lindex $speed 0]
1.297 + if {$tm == 0} {
1.298 + set rate [format %20s "many"]
1.299 + } else {
1.300 + set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
1.301 + }
1.302 + set u2 $units/s
1.303 + puts [format {%12d uS %s %s} $tm $rate $u2]
1.304 + global total_time
1.305 + set total_time [expr {$total_time+$tm}]
1.306 +}
1.307 +proc speed_trial_init {name} {
1.308 + global total_time
1.309 + set total_time 0
1.310 +}
1.311 +proc speed_trial_summary {name} {
1.312 + global total_time
1.313 + puts [format {%-21.21s %12d uS TOTAL} $name $total_time]
1.314 +}
1.315 +
1.316 +# Run this routine last
1.317 +#
1.318 +proc finish_test {} {
1.319 + finalize_testing
1.320 +}
1.321 +proc finalize_testing {} {
1.322 + global nTest nErr sqlite_open_file_count omitList
1.323 +
1.324 + catch {db close}
1.325 + catch {db2 close}
1.326 + catch {db3 close}
1.327 +
1.328 + vfs_unlink_test
1.329 + sqlite3 db {}
1.330 + # sqlite3_clear_tsd_memdebug
1.331 + db close
1.332 + sqlite3_reset_auto_extension
1.333 +
1.334 + set heaplimit [sqlite3_soft_heap_limit]
1.335 + if {$heaplimit!=$::soft_limit} {
1.336 + puts "soft-heap-limit changed by this script\
1.337 + from $::soft_limit to $heaplimit"
1.338 + } elseif {$heaplimit!="" && $heaplimit>0} {
1.339 + puts "soft-heap-limit set to $heaplimit"
1.340 + }
1.341 +
1.342 + sqlite3_soft_heap_limit 0
1.343 + incr nTest
1.344 + puts "$nErr errors out of $nTest tests"
1.345 + if {$nErr>0} {
1.346 + puts "Failures on these tests: $::failList"
1.347 + }
1.348 +
1.349 + if {[llength $omitList]>0} {
1.350 + puts "Omitted test cases:"
1.351 + set prec {}
1.352 + foreach {rec} [lsort $omitList] {
1.353 + if {$rec==$prec} continue
1.354 + set prec $rec
1.355 + puts [format { %-12s %s} [lindex $rec 0] [lindex $rec 1]]
1.356 + }
1.357 + }
1.358 +
1.359 + if {$nErr>0 && ![working_64bit_int]} {
1.360 + puts "******************************************************************"
1.361 + puts "N.B.: The version of TCL that you used to build this test harness"
1.362 + puts "is defective in that it does not support 64-bit integers. Some or"
1.363 + puts "all of the test failures above might be a result from this defect"
1.364 + puts "in your TCL build."
1.365 + puts "******************************************************************"
1.366 + }
1.367 + if {[info exists ::tester_do_binarylog]} {
1.368 + sqlite3_instvfs destroy binarylog
1.369 + }
1.370 +
1.371 + if {$sqlite_open_file_count} {
1.372 + puts "$sqlite_open_file_count files were left open"
1.373 + incr nErr
1.374 + }
1.375 +
1.376 + if {[info exists ::tester_do_ostrace]} {
1.377 + puts "Writing ostrace.sql..."
1.378 + set fd $::ostrace_fd
1.379 +
1.380 + puts -nonewline $fd "CREATE TABLE ossummary"
1.381 + puts $fd "(method TEXT, clicks INTEGER, count INTEGER);"
1.382 + foreach row [sqlite3_instvfs report ostrace] {
1.383 + foreach {method count clicks} $row break
1.384 + puts $fd "INSERT INTO ossummary VALUES('$method', $clicks, $count);"
1.385 + }
1.386 + puts $fd "COMMIT;"
1.387 + close $fd
1.388 + sqlite3_instvfs destroy ostrace
1.389 + }
1.390 +
1.391 + if {[sqlite3_memory_used]>0} {
1.392 + puts "Unfreed memory: [sqlite3_memory_used] bytes"
1.393 + incr nErr
1.394 + ifcapable memdebug||mem5||(mem3&&debug) {
1.395 + puts "Writing unfreed memory log to \"./memleak.txt\""
1.396 + sqlite3_memdebug_dump ./memleak.txt
1.397 + }
1.398 + } else {
1.399 + puts "All memory allocations freed - no leaks"
1.400 + ifcapable memdebug||mem5 {
1.401 + sqlite3_memdebug_dump ./memusage.txt
1.402 + }
1.403 + }
1.404 +
1.405 + show_memstats
1.406 + puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
1.407 + puts "Current memory usage: [sqlite3_memory_highwater] bytes"
1.408 + if {[info commands sqlite3_memdebug_malloc_count] ne ""} {
1.409 + puts "Number of malloc() : [sqlite3_memdebug_malloc_count] calls"
1.410 + }
1.411 +
1.412 + if {[info exists ::tester_do_malloctrace]} {
1.413 + puts "Writing mallocs.sql..."
1.414 + memdebug_log_sql
1.415 + sqlite3_memdebug_log stop
1.416 + sqlite3_memdebug_log clear
1.417 +
1.418 + if {[sqlite3_memory_used]>0} {
1.419 + puts "Writing leaks.sql..."
1.420 + sqlite3_memdebug_log sync
1.421 + memdebug_log_sql leaks.sql
1.422 + }
1.423 + }
1.424 +
1.425 + foreach f [glob -nocomplain test.db-*-journal] {
1.426 + file delete -force $f
1.427 + }
1.428 +
1.429 + foreach f [glob -nocomplain test.db-mj*] {
1.430 + file delete -force $f
1.431 + }
1.432 +
1.433 +#Symbian OS - delete_test_files() is called to cleanup after the tests execution
1.434 + delete_test_files
1.435 +
1.436 +# Symbian OS: output TEF format summary
1.437 + tef_summary
1.438 +
1.439 + exit [expr {$nErr>0}]
1.440 +}
1.441 +
1.442 +# Display memory statistics for analysis and debugging purposes.
1.443 +#
1.444 +proc show_memstats {} {
1.445 + set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]
1.446 + set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]
1.447 + set val [format {now %10d max %10d max-size %10d} \
1.448 + [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1.449 + puts "Memory used: $val"
1.450 + set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]
1.451 + set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]
1.452 + set val [format {now %10d max %10d max-size %10d} \
1.453 + [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1.454 + puts "Page-cache used: $val"
1.455 + set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]
1.456 + set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]]
1.457 + puts "Page-cache overflow: $val"
1.458 + set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]
1.459 + set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]]
1.460 + puts "Scratch memory used: $val"
1.461 + set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]
1.462 + set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]
1.463 + set val [format {now %10d max %10d max-size %10d} \
1.464 + [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1.465 + puts "Scratch overflow: $val"
1.466 + ifcapable yytrackmaxstackdepth {
1.467 + set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]
1.468 + set val [format { max %10d} [lindex $x 2]]
1.469 + puts "Parser stack depth: $val"
1.470 + }
1.471 +}
1.472 +
1.473 +# A procedure to execute SQL
1.474 +#
1.475 +proc execsql {sql {db db}} {
1.476 + # puts "SQL = $sql"
1.477 + uplevel [list $db eval $sql]
1.478 +}
1.479 +
1.480 +# Execute SQL and catch exceptions.
1.481 +#
1.482 +proc catchsql {sql {db db}} {
1.483 + # puts "SQL = $sql"
1.484 + set r [catch {$db eval $sql} msg]
1.485 + lappend r $msg
1.486 + return $r
1.487 +}
1.488 +
1.489 +# Do an VDBE code dump on the SQL given
1.490 +#
1.491 +proc explain {sql {db db}} {
1.492 + puts ""
1.493 + puts "addr opcode p1 p2 p3 p4 p5 #"
1.494 + puts "---- ------------ ------ ------ ------ --------------- -- -"
1.495 + $db eval "explain $sql" {} {
1.496 + puts [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \
1.497 + $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
1.498 + ]
1.499 + }
1.500 +}
1.501 +
1.502 +# Show the VDBE program for an SQL statement but omit the Trace
1.503 +# opcode at the beginning. This procedure can be used to prove
1.504 +# that different SQL statements generate exactly the same VDBE code.
1.505 +#
1.506 +proc explain_no_trace {sql} {
1.507 + set tr [db eval "EXPLAIN $sql"]
1.508 + return [lrange $tr 7 end]
1.509 +}
1.510 +
1.511 +# Another procedure to execute SQL. This one includes the field
1.512 +# names in the returned list.
1.513 +#
1.514 +proc execsql2 {sql} {
1.515 + set result {}
1.516 + db eval $sql data {
1.517 + foreach f $data(*) {
1.518 + lappend result $f $data($f)
1.519 + }
1.520 + }
1.521 + return $result
1.522 +}
1.523 +
1.524 +# Use the non-callback API to execute multiple SQL statements
1.525 +#
1.526 +proc stepsql {dbptr sql} {
1.527 + set sql [string trim $sql]
1.528 + set r 0
1.529 + while {[string length $sql]>0} {
1.530 + if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {
1.531 + return [list 1 $vm]
1.532 + }
1.533 + set sql [string trim $sqltail]
1.534 +# while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
1.535 +# foreach v $VAL {lappend r $v}
1.536 +# }
1.537 + while {[sqlite3_step $vm]=="SQLITE_ROW"} {
1.538 + for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {
1.539 + lappend r [sqlite3_column_text $vm $i]
1.540 + }
1.541 + }
1.542 + if {[catch {sqlite3_finalize $vm} errmsg]} {
1.543 + return [list 1 $errmsg]
1.544 + }
1.545 + }
1.546 + return $r
1.547 +}
1.548 +
1.549 +# Delete a file or directory
1.550 +#
1.551 +proc forcedelete {filename} {
1.552 + if {[catch {file delete -force $filename}]} {
1.553 + exec rm -rf $filename
1.554 + }
1.555 +}
1.556 +
1.557 +# Do an integrity check of the entire database
1.558 +#
1.559 +proc integrity_check {name} {
1.560 + ifcapable integrityck {
1.561 + do_test $name {
1.562 + execsql {PRAGMA integrity_check}
1.563 + } {ok}
1.564 + }
1.565 +}
1.566 +
1.567 +proc fix_ifcapable_expr {expr} {
1.568 + set ret ""
1.569 + set state 0
1.570 + for {set i 0} {$i < [string length $expr]} {incr i} {
1.571 + set char [string range $expr $i $i]
1.572 + set newstate [expr {[string is alnum $char] || $char eq "_"}]
1.573 + if {$newstate && !$state} {
1.574 + append ret {$::sqlite_options(}
1.575 + }
1.576 + if {!$newstate && $state} {
1.577 + append ret )
1.578 + }
1.579 + append ret $char
1.580 + set state $newstate
1.581 + }
1.582 + if {$state} {append ret )}
1.583 + return $ret
1.584 +}
1.585 +
1.586 +# Evaluate a boolean expression of capabilities. If true, execute the
1.587 +# code. Omit the code if false.
1.588 +#
1.589 +proc ifcapable {expr code {else ""} {elsecode ""}} {
1.590 + #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
1.591 + set e2 [fix_ifcapable_expr $expr]
1.592 + if ($e2) {
1.593 + set c [catch {uplevel 1 $code} r]
1.594 + } else {
1.595 + set c [catch {uplevel 1 $elsecode} r]
1.596 + }
1.597 + return -code $c $r
1.598 +}
1.599 +
1.600 +# This proc execs a seperate process that crashes midway through executing
1.601 +# the SQL script $sql on database test.db.
1.602 +#
1.603 +# The crash occurs during a sync() of file $crashfile. When the crash
1.604 +# occurs a random subset of all unsynced writes made by the process are
1.605 +# written into the files on disk. Argument $crashdelay indicates the
1.606 +# number of file syncs to wait before crashing.
1.607 +#
1.608 +# The return value is a list of two elements. The first element is a
1.609 +# boolean, indicating whether or not the process actually crashed or
1.610 +# reported some other error. The second element in the returned list is the
1.611 +# error message. This is "child process exited abnormally" if the crash
1.612 +# occured.
1.613 +#
1.614 +# crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
1.615 +#
1.616 +proc crashsql {args} {
1.617 + if {$::tcl_platform(platform)!="unix"} {
1.618 + error "crashsql should only be used on unix"
1.619 + }
1.620 +
1.621 + set blocksize ""
1.622 + set crashdelay 1
1.623 + set prngseed 0
1.624 + set tclbody {}
1.625 + set crashfile ""
1.626 + set dc ""
1.627 + set sql [lindex $args end]
1.628 +
1.629 + for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {
1.630 + set z [lindex $args $ii]
1.631 + set n [string length $z]
1.632 + set z2 [lindex $args [expr $ii+1]]
1.633 +
1.634 + if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \
1.635 + elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \
1.636 + elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \
1.637 + elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \
1.638 + elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \
1.639 + elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \
1.640 + else { error "Unrecognized option: $z" }
1.641 + }
1.642 +
1.643 + if {$crashfile eq ""} {
1.644 + error "Compulsory option -file missing"
1.645 + }
1.646 +
1.647 + set cfile [file join [pwd] $crashfile]
1.648 +
1.649 + set f [open crash.tcl w]
1.650 + puts $f "sqlite3_crash_enable 1"
1.651 + puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
1.652 + puts $f "set sqlite_pending_byte $::sqlite_pending_byte"
1.653 + puts $f "sqlite3 db test.db -vfs crash"
1.654 +
1.655 + # This block sets the cache size of the main database to 10
1.656 + # pages. This is done in case the build is configured to omit
1.657 + # "PRAGMA cache_size".
1.658 + puts $f {db eval {SELECT * FROM sqlite_master;}}
1.659 + puts $f {set bt [btree_from_db db]}
1.660 + puts $f {btree_set_cache_size $bt 10}
1.661 + if {$prngseed} {
1.662 + set seed [expr {$prngseed%10007+1}]
1.663 + # puts seed=$seed
1.664 + puts $f "db eval {SELECT randomblob($seed)}"
1.665 + }
1.666 +
1.667 + if {[string length $tclbody]>0} {
1.668 + puts $f $tclbody
1.669 + }
1.670 + if {[string length $sql]>0} {
1.671 + puts $f "db eval {"
1.672 + puts $f "$sql"
1.673 + puts $f "}"
1.674 + }
1.675 + close $f
1.676 +
1.677 + set r [catch {
1.678 + exec [info nameofexec] crash.tcl >@stdout
1.679 + } msg]
1.680 + lappend r $msg
1.681 +}
1.682 +
1.683 +# Usage: do_ioerr_test <test number> <options...>
1.684 +#
1.685 +# This proc is used to implement test cases that check that IO errors
1.686 +# are correctly handled. The first argument, <test number>, is an integer
1.687 +# used to name the tests executed by this proc. Options are as follows:
1.688 +#
1.689 +# -tclprep TCL script to run to prepare test.
1.690 +# -sqlprep SQL script to run to prepare test.
1.691 +# -tclbody TCL script to run with IO error simulation.
1.692 +# -sqlbody TCL script to run with IO error simulation.
1.693 +# -exclude List of 'N' values not to test.
1.694 +# -erc Use extended result codes
1.695 +# -persist Make simulated I/O errors persistent
1.696 +# -start Value of 'N' to begin with (default 1)
1.697 +#
1.698 +# -cksum Boolean. If true, test that the database does
1.699 +# not change during the execution of the test case.
1.700 +#
1.701 +proc do_ioerr_test {testname args} {
1.702 +
1.703 + set ::ioerropts(-start) 1
1.704 + set ::ioerropts(-cksum) 0
1.705 + set ::ioerropts(-erc) 0
1.706 + set ::ioerropts(-count) 100000000
1.707 + set ::ioerropts(-persist) 1
1.708 + set ::ioerropts(-ckrefcount) 0
1.709 + set ::ioerropts(-restoreprng) 1
1.710 + array set ::ioerropts $args
1.711 +
1.712 + # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
1.713 + # a couple of obscure IO errors that do not return them.
1.714 + set ::ioerropts(-erc) 0
1.715 +
1.716 + set ::go 1
1.717 + #reset_prng_state
1.718 + save_prng_state
1.719 + for {set n $::ioerropts(-start)} {$::go && $n<200} {incr n} {
1.720 + set ::TN $n
1.721 + incr ::ioerropts(-count) -1
1.722 + if {$::ioerropts(-count)<0} break
1.723 +
1.724 + # Skip this IO error if it was specified with the "-exclude" option.
1.725 + if {[info exists ::ioerropts(-exclude)]} {
1.726 + if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
1.727 + }
1.728 + if {$::ioerropts(-restoreprng)} {
1.729 + restore_prng_state
1.730 + }
1.731 +
1.732 + # Delete the files test.db and test2.db, then execute the TCL and
1.733 + # SQL (in that order) to prepare for the test case.
1.734 + do_test $testname.$n.1 {
1.735 + set ::sqlite_io_error_pending 0
1.736 + catch {db close}
1.737 + catch {file delete -force test.db}
1.738 + catch {file delete -force test.db-journal}
1.739 + catch {file delete -force test2.db}
1.740 + catch {file delete -force test2.db-journal}
1.741 + set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
1.742 + sqlite3_extended_result_codes $::DB $::ioerropts(-erc)
1.743 + if {[info exists ::ioerropts(-tclprep)]} {
1.744 + eval $::ioerropts(-tclprep)
1.745 + }
1.746 + if {[info exists ::ioerropts(-sqlprep)]} {
1.747 + execsql $::ioerropts(-sqlprep)
1.748 + }
1.749 + expr 0
1.750 + } {0}
1.751 +
1.752 + # Read the 'checksum' of the database.
1.753 + if {$::ioerropts(-cksum)} {
1.754 + set checksum [cksum]
1.755 + }
1.756 +
1.757 + # Set the Nth IO error to fail.
1.758 + do_test $testname.$n.2 [subst {
1.759 + set ::sqlite_io_error_persist $::ioerropts(-persist)
1.760 + set ::sqlite_io_error_pending $n
1.761 + }] $n
1.762 +
1.763 + # Create a single TCL script from the TCL and SQL specified
1.764 + # as the body of the test.
1.765 + set ::ioerrorbody {}
1.766 + if {[info exists ::ioerropts(-tclbody)]} {
1.767 + append ::ioerrorbody "$::ioerropts(-tclbody)\n"
1.768 + }
1.769 + if {[info exists ::ioerropts(-sqlbody)]} {
1.770 + append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
1.771 + }
1.772 +
1.773 + # Execute the TCL Script created in the above block. If
1.774 + # there are at least N IO operations performed by SQLite as
1.775 + # a result of the script, the Nth will fail.
1.776 + do_test $testname.$n.3 {
1.777 + set ::sqlite_io_error_hit 0
1.778 + set ::sqlite_io_error_hardhit 0
1.779 + set r [catch $::ioerrorbody msg]
1.780 + set ::errseen $r
1.781 + set rc [sqlite3_errcode $::DB]
1.782 + if {$::ioerropts(-erc)} {
1.783 + # If we are in extended result code mode, make sure all of the
1.784 + # IOERRs we get back really do have their extended code values.
1.785 + # If an extended result code is returned, the sqlite3_errcode
1.786 + # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn
1.787 + # where nnnn is a number
1.788 + if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {
1.789 + return $rc
1.790 + }
1.791 + } else {
1.792 + # If we are not in extended result code mode, make sure no
1.793 + # extended error codes are returned.
1.794 + if {[regexp {\+\d} $rc]} {
1.795 + return $rc
1.796 + }
1.797 + }
1.798 + # The test repeats as long as $::go is non-zero. $::go starts out
1.799 + # as 1. When a test runs to completion without hitting an I/O
1.800 + # error, that means there is no point in continuing with this test
1.801 + # case so set $::go to zero.
1.802 + #
1.803 + if {$::sqlite_io_error_pending>0} {
1.804 + set ::go 0
1.805 + set q 0
1.806 + set ::sqlite_io_error_pending 0
1.807 + } else {
1.808 + set q 1
1.809 + }
1.810 +
1.811 + set s [expr $::sqlite_io_error_hit==0]
1.812 + if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
1.813 + set r 1
1.814 + }
1.815 + set ::sqlite_io_error_hit 0
1.816 +
1.817 + # One of two things must have happened. either
1.818 + # 1. We never hit the IO error and the SQL returned OK
1.819 + # 2. An IO error was hit and the SQL failed
1.820 + #
1.821 + expr { ($s && !$r && !$q) || (!$s && $r && $q) }
1.822 + } {1}
1.823 +
1.824 + set ::sqlite_io_error_hit 0
1.825 + set ::sqlite_io_error_pending 0
1.826 +
1.827 + # Check that no page references were leaked. There should be
1.828 + # a single reference if there is still an active transaction,
1.829 + # or zero otherwise.
1.830 + #
1.831 + # UPDATE: If the IO error occurs after a 'BEGIN' but before any
1.832 + # locks are established on database files (i.e. if the error
1.833 + # occurs while attempting to detect a hot-journal file), then
1.834 + # there may 0 page references and an active transaction according
1.835 + # to [sqlite3_get_autocommit].
1.836 + #
1.837 + if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
1.838 + do_test $testname.$n.4 {
1.839 + set bt [btree_from_db db]
1.840 + db_enter db
1.841 + array set stats [btree_pager_stats $bt]
1.842 + db_leave db
1.843 + set nRef $stats(ref)
1.844 + expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}
1.845 + } {1}
1.846 + }
1.847 +
1.848 + # If there is an open database handle and no open transaction,
1.849 + # and the pager is not running in exclusive-locking mode,
1.850 + # check that the pager is in "unlocked" state. Theoretically,
1.851 + # if a call to xUnlock() failed due to an IO error the underlying
1.852 + # file may still be locked.
1.853 + #
1.854 + ifcapable pragma {
1.855 + if { [info commands db] ne ""
1.856 + && $::ioerropts(-ckrefcount)
1.857 + && [db one {pragma locking_mode}] eq "normal"
1.858 + && [sqlite3_get_autocommit db]
1.859 + } {
1.860 + do_test $testname.$n.5 {
1.861 + set bt [btree_from_db db]
1.862 + db_enter db
1.863 + array set stats [btree_pager_stats $bt]
1.864 + db_leave db
1.865 + set stats(state)
1.866 + } 0
1.867 + }
1.868 + }
1.869 +
1.870 + # If an IO error occured, then the checksum of the database should
1.871 + # be the same as before the script that caused the IO error was run.
1.872 + #
1.873 + if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
1.874 + do_test $testname.$n.6 {
1.875 + catch {db close}
1.876 + catch {db2 close}
1.877 + set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
1.878 + cksum
1.879 + } $checksum
1.880 + }
1.881 +
1.882 + set ::sqlite_io_error_hardhit 0
1.883 + set ::sqlite_io_error_pending 0
1.884 + if {[info exists ::ioerropts(-cleanup)]} {
1.885 + catch $::ioerropts(-cleanup)
1.886 + }
1.887 + }
1.888 + set ::sqlite_io_error_pending 0
1.889 + set ::sqlite_io_error_persist 0
1.890 + unset ::ioerropts
1.891 +}
1.892 +
1.893 +# Return a checksum based on the contents of the main database associated
1.894 +# with connection $db
1.895 +#
1.896 +proc cksum {{db db}} {
1.897 + set txt [$db eval {
1.898 + SELECT name, type, sql FROM sqlite_master order by name
1.899 + }]\n
1.900 + foreach tbl [$db eval {
1.901 + SELECT name FROM sqlite_master WHERE type='table' order by name
1.902 + }] {
1.903 + append txt [$db eval "SELECT * FROM $tbl"]\n
1.904 + }
1.905 + foreach prag {default_synchronous default_cache_size} {
1.906 + append txt $prag-[$db eval "PRAGMA $prag"]\n
1.907 + }
1.908 + set cksum [string length $txt]-[md5 $txt]
1.909 + # puts $cksum-[file size test.db]
1.910 + return $cksum
1.911 +}
1.912 +
1.913 +# Generate a checksum based on the contents of the main and temp tables
1.914 +# database $db. If the checksum of two databases is the same, and the
1.915 +# integrity-check passes for both, the two databases are identical.
1.916 +#
1.917 +proc allcksum {{db db}} {
1.918 + set ret [list]
1.919 + ifcapable tempdb {
1.920 + set sql {
1.921 + SELECT name FROM sqlite_master WHERE type = 'table' UNION
1.922 + SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION
1.923 + SELECT 'sqlite_master' UNION
1.924 + SELECT 'sqlite_temp_master' ORDER BY 1
1.925 + }
1.926 + } else {
1.927 + set sql {
1.928 + SELECT name FROM sqlite_master WHERE type = 'table' UNION
1.929 + SELECT 'sqlite_master' ORDER BY 1
1.930 + }
1.931 + }
1.932 + set tbllist [$db eval $sql]
1.933 + set txt {}
1.934 + foreach tbl $tbllist {
1.935 + append txt [$db eval "SELECT * FROM $tbl"]
1.936 + }
1.937 + foreach prag {default_cache_size} {
1.938 + append txt $prag-[$db eval "PRAGMA $prag"]\n
1.939 + }
1.940 + # puts txt=$txt
1.941 + return [md5 $txt]
1.942 +}
1.943 +
1.944 +proc memdebug_log_sql {{filename mallocs.sql}} {
1.945 +
1.946 + set data [sqlite3_memdebug_log dump]
1.947 + set nFrame [expr [llength [lindex $data 0]]-2]
1.948 + if {$nFrame < 0} { return "" }
1.949 +
1.950 + set database temp
1.951 +
1.952 + set tbl "CREATE TABLE ${database}.malloc(nCall, nByte"
1.953 + for {set ii 1} {$ii <= $nFrame} {incr ii} {
1.954 + append tbl ", f${ii}"
1.955 + }
1.956 + append tbl ");\n"
1.957 +
1.958 + set sql ""
1.959 + foreach e $data {
1.960 + append sql "INSERT INTO ${database}.malloc VALUES([join $e ,]);\n"
1.961 + foreach f [lrange $e 2 end] {
1.962 + set frames($f) 1
1.963 + }
1.964 + }
1.965 +
1.966 + set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
1.967 + set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
1.968 +
1.969 + foreach f [array names frames] {
1.970 + set addr [format %x $f]
1.971 + set cmd "addr2line -e [info nameofexec] $addr"
1.972 + set line [eval exec $cmd]
1.973 + append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
1.974 +
1.975 + set file [lindex [split $line :] 0]
1.976 + set files($file) 1
1.977 + }
1.978 +
1.979 + foreach f [array names files] {
1.980 + set contents ""
1.981 + catch {
1.982 + set fd [open $f]
1.983 + set contents [read $fd]
1.984 + close $fd
1.985 + }
1.986 + set contents [string map {' ''} $contents]
1.987 + append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
1.988 + }
1.989 +
1.990 + set fd [open $filename w]
1.991 + puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
1.992 + close $fd
1.993 +}
1.994 +
1.995 +# Copy file $from into $to. This is used because some versions of
1.996 +# TCL for windows (notably the 8.4.1 binary package shipped with the
1.997 +# current mingw release) have a broken "file copy" command.
1.998 +#
1.999 +proc copy_file {from to} {
1.1000 + if {$::tcl_platform(platform)=="unix"} {
1.1001 + file copy -force $from $to
1.1002 + } else {
1.1003 + set f [open $from]
1.1004 + fconfigure $f -translation binary
1.1005 + set t [open $to w]
1.1006 + fconfigure $t -translation binary
1.1007 + puts -nonewline $t [read $f [file size $from]]
1.1008 + close $t
1.1009 + close $f
1.1010 + }
1.1011 +}
1.1012 +
1.1013 +# If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
1.1014 +# to non-zero, then set the global variable $AUTOVACUUM to 1.
1.1015 +set AUTOVACUUM $sqlite_options(default_autovacuum)