| 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 # What for user input before continuing. This gives an opportunity | |
| 18 # to connect profiling tools to the process. | |
| 19 # | |
| 20 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 21 if {[regexp {^-+pause$} [lindex $argv $i] all value]} { | |
| 22 puts -nonewline "Press RETURN to begin..." | |
| 23 flush stdout | |
| 24 gets stdin | |
| 25 set argv [lreplace $argv $i $i] | |
| 26 } | |
| 27 } | |
| 28 | |
| 29 set tcl_precision 15 | |
| 30 sqlite3_test_control_pending_byte 0x0010000 | |
| 31 | |
| 32 # | |
| 33 # Check the command-line arguments for a default soft-heap-limit. | |
| 34 # Store this default value in the global variable ::soft_limit and | |
| 35 # update the soft-heap-limit each time this script is run. In that | |
| 36 # way if an individual test file changes the soft-heap-limit, it | |
| 37 # will be reset at the start of the next test file. | |
| 38 # | |
| 39 if {![info exists soft_limit]} { | |
| 40 set soft_limit 0 | |
| 41 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 42 if {[regexp {^--soft-heap-limit=(.+)$} [lindex $argv $i] all value]} { | |
| 43 if {$value!="off"} { | |
| 44 set soft_limit $value | |
| 45 } | |
| 46 set argv [lreplace $argv $i $i] | |
| 47 } | |
| 48 } | |
| 49 } | |
| 50 sqlite3_soft_heap_limit $soft_limit | |
| 51 | |
| 52 # | |
| 53 # Check the command-line arguments to set the memory debugger | |
| 54 # backtrace depth. | |
| 55 # | |
| 56 # See the sqlite3_memdebug_backtrace() function in mem2.c or | |
| 57 # test_malloc.c for additional information. | |
| 58 # | |
| 59 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 60 if {[lindex $argv $i] eq "--malloctrace"} { | |
| 61 set argv [lreplace $argv $i $i] | |
| 62 sqlite3_memdebug_backtrace 10 | |
| 63 sqlite3_memdebug_log start | |
| 64 set tester_do_malloctrace 1 | |
| 65 } | |
| 66 } | |
| 67 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 68 if {[regexp {^--backtrace=(\d+)$} [lindex $argv $i] all value]} { | |
| 69 sqlite3_memdebug_backtrace $value | |
| 70 set argv [lreplace $argv $i $i] | |
| 71 } | |
| 72 } | |
| 73 | |
| 74 | |
| 75 proc ostrace_call {zCall nClick zFile i32 i64} { | |
| 76 set s "INSERT INTO ostrace VALUES('$zCall', $nClick, '$zFile', $i32, $i64);" | |
| 77 puts $::ostrace_fd $s | |
| 78 } | |
| 79 | |
| 80 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 81 if {[lindex $argv $i] eq "--ossummary" || [lindex $argv $i] eq "--ostrace"} { | |
| 82 sqlite3_instvfs create -default ostrace | |
| 83 set tester_do_ostrace 1 | |
| 84 set ostrace_fd [open ostrace.sql w] | |
| 85 puts $ostrace_fd "BEGIN;" | |
| 86 if {[lindex $argv $i] eq "--ostrace"} { | |
| 87 set s "CREATE TABLE ostrace" | |
| 88 append s "(method TEXT, clicks INT, file TEXT, i32 INT, i64 INT);" | |
| 89 puts $ostrace_fd $s | |
| 90 sqlite3_instvfs configure ostrace ostrace_call | |
| 91 sqlite3_instvfs configure ostrace ostrace_call | |
| 92 } | |
| 93 set argv [lreplace $argv $i $i] | |
| 94 } | |
| 95 if {[lindex $argv $i] eq "--binarylog"} { | |
| 96 set tester_do_binarylog 1 | |
| 97 set argv [lreplace $argv $i $i] | |
| 98 } | |
| 99 } | |
| 100 | |
| 101 # | |
| 102 # Check the command-line arguments to set the maximum number of | |
| 103 # errors tolerated before halting. | |
| 104 # | |
| 105 if {![info exists maxErr]} { | |
| 106 set maxErr 1000 | |
| 107 } | |
| 108 for {set i 0} {$i<[llength $argv]} {incr i} { | |
| 109 if {[regexp {^--maxerror=(\d+)$} [lindex $argv $i] all maxErr]} { | |
| 110 set argv [lreplace $argv $i $i] | |
| 111 } | |
| 112 } | |
| 113 #puts "Max error = $maxErr" | |
| 114 | |
| 115 | |
| 116 # Use the pager codec if it is available | |
| 117 # | |
| 118 if {[sqlite3 -has-codec] && [info command sqlite_orig]==""} { | |
| 119 rename sqlite3 sqlite_orig | |
| 120 proc sqlite3 {args} { | |
| 121 if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} { | |
| 122 lappend args -key {xyzzy} | |
| 123 } | |
| 124 uplevel 1 sqlite_orig $args | |
| 125 } | |
| 126 } | |
| 127 | |
| 128 | |
| 129 # Create a test database | |
| 130 # | |
| 131 if {![info exists nTest]} { | |
| 132 sqlite3_shutdown | |
| 133 install_malloc_faultsim 1 | |
| 134 sqlite3_initialize | |
| 135 autoinstall_test_functions | |
| 136 if {[info exists tester_do_binarylog]} { | |
| 137 sqlite3_instvfs binarylog -default binarylog ostrace.bin | |
| 138 sqlite3_instvfs marker binarylog "$argv0 $argv" | |
| 139 } | |
| 140 } | |
| 141 | |
| 142 proc reset_db {} { | |
| 143 catch {db close} | |
| 144 file delete -force test.db | |
| 145 file delete -force test.db-journal | |
| 146 sqlite3 db ./test.db | |
| 147 set ::DB [sqlite3_connection_pointer db] | |
| 148 if {[info exists ::SETUP_SQL]} { | |
| 149 db eval $::SETUP_SQL | |
| 150 } | |
| 151 } | |
| 152 reset_db | |
| 153 | |
| 154 # Abort early if this script has been run before. | |
| 155 # | |
| 156 if {[info exists nTest]} return | |
| 157 | |
| 158 # Set the test counters to zero | |
| 159 # | |
| 160 set nErr 0 | |
| 161 set nTest 0 | |
| 162 set skip_test 0 | |
| 163 set failList {} | |
| 164 set omitList {} | |
| 165 if {![info exists speedTest]} { | |
| 166 set speedTest 0 | |
| 167 } | |
| 168 | |
| 169 # Record the fact that a sequence of tests were omitted. | |
| 170 # | |
| 171 proc omit_test {name reason} { | |
| 172 global omitList | |
| 173 lappend omitList [list $name $reason] | |
| 174 } | |
| 175 | |
| 176 # Invoke the do_test procedure to run a single test | |
| 177 # | |
| 178 proc do_test {name cmd expected} { | |
| 179 global argv nErr nTest skip_test maxErr | |
| 180 sqlite3_memdebug_settitle $name | |
| 181 if {[info exists ::tester_do_binarylog]} { | |
| 182 sqlite3_instvfs marker binarylog "Start of $name" | |
| 183 } | |
| 184 if {$skip_test} { | |
| 185 set skip_test 0 | |
| 186 return | |
| 187 } | |
| 188 if {[llength $argv]==0} { | |
| 189 set go 1 | |
| 190 } else { | |
| 191 set go 0 | |
| 192 foreach pattern $argv { | |
| 193 if {[string match $pattern $name]} { | |
| 194 set go 1 | |
| 195 break | |
| 196 } | |
| 197 } | |
| 198 } | |
| 199 if {!$go} return | |
| 200 incr nTest | |
| 201 puts -nonewline $name... | |
| 202 flush stdout | |
| 203 if {[catch {uplevel #0 "$cmd;\n"} result]} { | |
| 204 puts "\nError: $result" | |
| 205 incr nErr | |
| 206 lappend ::failList $name | |
| 207 if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing} | |
| 208 } elseif {[string compare $result $expected]} { | |
| 209 puts "\nExpected: \[$expected\]\n Got: \[$result\]" | |
| 210 incr nErr | |
| 211 lappend ::failList $name | |
| 212 if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing} | |
| 213 } else { | |
| 214 puts " Ok" | |
| 215 } | |
| 216 flush stdout | |
| 217 if {[info exists ::tester_do_binarylog]} { | |
| 218 sqlite3_instvfs marker binarylog "End of $name" | |
| 219 } | |
| 220 } | |
| 221 | |
| 222 # Run an SQL script. | |
| 223 # Return the number of microseconds per statement. | |
| 224 # | |
| 225 proc speed_trial {name numstmt units sql} { | |
| 226 puts -nonewline [format {%-21.21s } $name...] | |
| 227 flush stdout | |
| 228 set speed [time {sqlite3_exec_nr db $sql}] | |
| 229 set tm [lindex $speed 0] | |
| 230 if {$tm == 0} { | |
| 231 set rate [format %20s "many"] | |
| 232 } else { | |
| 233 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] | |
| 234 } | |
| 235 set u2 $units/s | |
| 236 puts [format {%12d uS %s %s} $tm $rate $u2] | |
| 237 global total_time | |
| 238 set total_time [expr {$total_time+$tm}] | |
| 239 } | |
| 240 proc speed_trial_tcl {name numstmt units script} { | |
| 241 puts -nonewline [format {%-21.21s } $name...] | |
| 242 flush stdout | |
| 243 set speed [time {eval $script}] | |
| 244 set tm [lindex $speed 0] | |
| 245 if {$tm == 0} { | |
| 246 set rate [format %20s "many"] | |
| 247 } else { | |
| 248 set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]] | |
| 249 } | |
| 250 set u2 $units/s | |
| 251 puts [format {%12d uS %s %s} $tm $rate $u2] | |
| 252 global total_time | |
| 253 set total_time [expr {$total_time+$tm}] | |
| 254 } | |
| 255 proc speed_trial_init {name} { | |
| 256 global total_time | |
| 257 set total_time 0 | |
| 258 } | |
| 259 proc speed_trial_summary {name} { | |
| 260 global total_time | |
| 261 puts [format {%-21.21s %12d uS TOTAL} $name $total_time] | |
| 262 } | |
| 263 | |
| 264 # Run this routine last | |
| 265 # | |
| 266 proc finish_test {} { | |
| 267 finalize_testing | |
| 268 } | |
| 269 proc finalize_testing {} { | |
| 270 global nTest nErr sqlite_open_file_count omitList | |
| 271 | |
| 272 catch {db close} | |
| 273 catch {db2 close} | |
| 274 catch {db3 close} | |
| 275 | |
| 276 vfs_unlink_test | |
| 277 sqlite3 db {} | |
| 278 # sqlite3_clear_tsd_memdebug | |
| 279 db close | |
| 280 sqlite3_reset_auto_extension | |
| 281 set heaplimit [sqlite3_soft_heap_limit] | |
| 282 if {$heaplimit!=$::soft_limit} { | |
| 283 puts "soft-heap-limit changed by this script\ | |
| 284 from $::soft_limit to $heaplimit" | |
| 285 } elseif {$heaplimit!="" && $heaplimit>0} { | |
| 286 puts "soft-heap-limit set to $heaplimit" | |
| 287 } | |
| 288 sqlite3_soft_heap_limit 0 | |
| 289 incr nTest | |
| 290 puts "$nErr errors out of $nTest tests" | |
| 291 if {$nErr>0} { | |
| 292 puts "Failures on these tests: $::failList" | |
| 293 } | |
| 294 run_thread_tests 1 | |
| 295 if {[llength $omitList]>0} { | |
| 296 puts "Omitted test cases:" | |
| 297 set prec {} | |
| 298 foreach {rec} [lsort $omitList] { | |
| 299 if {$rec==$prec} continue | |
| 300 set prec $rec | |
| 301 puts [format { %-12s %s} [lindex $rec 0] [lindex $rec 1]] | |
| 302 } | |
| 303 } | |
| 304 if {$nErr>0 && ![working_64bit_int]} { | |
| 305 puts "******************************************************************" | |
| 306 puts "N.B.: The version of TCL that you used to build this test harness" | |
| 307 puts "is defective in that it does not support 64-bit integers. Some or" | |
| 308 puts "all of the test failures above might be a result from this defect" | |
| 309 puts "in your TCL build." | |
| 310 puts "******************************************************************" | |
| 311 } | |
| 312 if {[info exists ::tester_do_binarylog]} { | |
| 313 sqlite3_instvfs destroy binarylog | |
| 314 } | |
| 315 if {$sqlite_open_file_count} { | |
| 316 puts "$sqlite_open_file_count files were left open" | |
| 317 incr nErr | |
| 318 } | |
| 319 if {[info exists ::tester_do_ostrace]} { | |
| 320 puts "Writing ostrace.sql..." | |
| 321 set fd $::ostrace_fd | |
| 322 | |
| 323 puts -nonewline $fd "CREATE TABLE ossummary" | |
| 324 puts $fd "(method TEXT, clicks INTEGER, count INTEGER);" | |
| 325 foreach row [sqlite3_instvfs report ostrace] { | |
| 326 foreach {method count clicks} $row break | |
| 327 puts $fd "INSERT INTO ossummary VALUES('$method', $clicks, $count);" | |
| 328 } | |
| 329 puts $fd "COMMIT;" | |
| 330 close $fd | |
| 331 sqlite3_instvfs destroy ostrace | |
| 332 } | |
| 333 if {[sqlite3_memory_used]>0} { | |
| 334 puts "Unfreed memory: [sqlite3_memory_used] bytes" | |
| 335 incr nErr | |
| 336 ifcapable memdebug||mem5||(mem3&&debug) { | |
| 337 puts "Writing unfreed memory log to \"./memleak.txt\"" | |
| 338 sqlite3_memdebug_dump ./memleak.txt | |
| 339 } | |
| 340 } else { | |
| 341 puts "All memory allocations freed - no leaks" | |
| 342 ifcapable memdebug||mem5 { | |
| 343 sqlite3_memdebug_dump ./memusage.txt | |
| 344 } | |
| 345 } | |
| 346 show_memstats | |
| 347 puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes" | |
| 348 puts "Current memory usage: [sqlite3_memory_highwater] bytes" | |
| 349 if {[info commands sqlite3_memdebug_malloc_count] ne ""} { | |
| 350 puts "Number of malloc() : [sqlite3_memdebug_malloc_count] calls" | |
| 351 } | |
| 352 if {[info exists ::tester_do_malloctrace]} { | |
| 353 puts "Writing mallocs.sql..." | |
| 354 memdebug_log_sql | |
| 355 sqlite3_memdebug_log stop | |
| 356 sqlite3_memdebug_log clear | |
| 357 | |
| 358 if {[sqlite3_memory_used]>0} { | |
| 359 puts "Writing leaks.sql..." | |
| 360 sqlite3_memdebug_log sync | |
| 361 memdebug_log_sql leaks.sql | |
| 362 } | |
| 363 } | |
| 364 foreach f [glob -nocomplain test.db-*-journal] { | |
| 365 file delete -force $f | |
| 366 } | |
| 367 foreach f [glob -nocomplain test.db-mj*] { | |
| 368 file delete -force $f | |
| 369 } | |
| 370 exit [expr {$nErr>0}] | |
| 371 } | |
| 372 | |
| 373 # Display memory statistics for analysis and debugging purposes. | |
| 374 # | |
| 375 proc show_memstats {} { | |
| 376 set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0] | |
| 377 set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0] | |
| 378 set val [format {now %10d max %10d max-size %10d} \ | |
| 379 [lindex $x 1] [lindex $x 2] [lindex $y 2]] | |
| 380 puts "Memory used: $val" | |
| 381 set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0] | |
| 382 set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0] | |
| 383 set val [format {now %10d max %10d max-size %10d} \ | |
| 384 [lindex $x 1] [lindex $x 2] [lindex $y 2]] | |
| 385 puts "Page-cache used: $val" | |
| 386 set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0] | |
| 387 set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] | |
| 388 puts "Page-cache overflow: $val" | |
| 389 set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0] | |
| 390 set val [format {now %10d max %10d} [lindex $x 1] [lindex $x 2]] | |
| 391 puts "Scratch memory used: $val" | |
| 392 set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0] | |
| 393 set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0] | |
| 394 set val [format {now %10d max %10d max-size %10d} \ | |
| 395 [lindex $x 1] [lindex $x 2] [lindex $y 2]] | |
| 396 puts "Scratch overflow: $val" | |
| 397 ifcapable yytrackmaxstackdepth { | |
| 398 set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0] | |
| 399 set val [format { max %10d} [lindex $x 2]] | |
| 400 puts "Parser stack depth: $val" | |
| 401 } | |
| 402 } | |
| 403 | |
| 404 # A procedure to execute SQL | |
| 405 # | |
| 406 proc execsql {sql {db db}} { | |
| 407 # puts "SQL = $sql" | |
| 408 uplevel [list $db eval $sql] | |
| 409 } | |
| 410 | |
| 411 # Execute SQL and catch exceptions. | |
| 412 # | |
| 413 proc catchsql {sql {db db}} { | |
| 414 # puts "SQL = $sql" | |
| 415 set r [catch {$db eval $sql} msg] | |
| 416 lappend r $msg | |
| 417 return $r | |
| 418 } | |
| 419 | |
| 420 # Do an VDBE code dump on the SQL given | |
| 421 # | |
| 422 proc explain {sql {db db}} { | |
| 423 puts "" | |
| 424 puts "addr opcode p1 p2 p3 p4 p5 #" | |
| 425 puts "---- ------------ ------ ------ ------ --------------- -- -" | |
| 426 $db eval "explain $sql" {} { | |
| 427 puts [format {%-4d %-12.12s %-6d %-6d %-6d % -17s %s %s} \ | |
| 428 $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment | |
| 429 ] | |
| 430 } | |
| 431 } | |
| 432 | |
| 433 # Show the VDBE program for an SQL statement but omit the Trace | |
| 434 # opcode at the beginning. This procedure can be used to prove | |
| 435 # that different SQL statements generate exactly the same VDBE code. | |
| 436 # | |
| 437 proc explain_no_trace {sql} { | |
| 438 set tr [db eval "EXPLAIN $sql"] | |
| 439 return [lrange $tr 7 end] | |
| 440 } | |
| 441 | |
| 442 # Another procedure to execute SQL. This one includes the field | |
| 443 # names in the returned list. | |
| 444 # | |
| 445 proc execsql2 {sql} { | |
| 446 set result {} | |
| 447 db eval $sql data { | |
| 448 foreach f $data(*) { | |
| 449 lappend result $f $data($f) | |
| 450 } | |
| 451 } | |
| 452 return $result | |
| 453 } | |
| 454 | |
| 455 # Use the non-callback API to execute multiple SQL statements | |
| 456 # | |
| 457 proc stepsql {dbptr sql} { | |
| 458 set sql [string trim $sql] | |
| 459 set r 0 | |
| 460 while {[string length $sql]>0} { | |
| 461 if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} { | |
| 462 return [list 1 $vm] | |
| 463 } | |
| 464 set sql [string trim $sqltail] | |
| 465 # while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} { | |
| 466 # foreach v $VAL {lappend r $v} | |
| 467 # } | |
| 468 while {[sqlite3_step $vm]=="SQLITE_ROW"} { | |
| 469 for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} { | |
| 470 lappend r [sqlite3_column_text $vm $i] | |
| 471 } | |
| 472 } | |
| 473 if {[catch {sqlite3_finalize $vm} errmsg]} { | |
| 474 return [list 1 $errmsg] | |
| 475 } | |
| 476 } | |
| 477 return $r | |
| 478 } | |
| 479 | |
| 480 # Delete a file or directory | |
| 481 # | |
| 482 proc forcedelete {filename} { | |
| 483 if {[catch {file delete -force $filename}]} { | |
| 484 exec rm -rf $filename | |
| 485 } | |
| 486 } | |
| 487 | |
| 488 # Do an integrity check of the entire database | |
| 489 # | |
| 490 proc integrity_check {name {db db}} { | |
| 491 ifcapable integrityck { | |
| 492 do_test $name [list execsql {PRAGMA integrity_check} $db] {ok} | |
| 493 } | |
| 494 } | |
| 495 | |
| 496 proc fix_ifcapable_expr {expr} { | |
| 497 set ret "" | |
| 498 set state 0 | |
| 499 for {set i 0} {$i < [string length $expr]} {incr i} { | |
| 500 set char [string range $expr $i $i] | |
| 501 set newstate [expr {[string is alnum $char] || $char eq "_"}] | |
| 502 if {$newstate && !$state} { | |
| 503 append ret {$::sqlite_options(} | |
| 504 } | |
| 505 if {!$newstate && $state} { | |
| 506 append ret ) | |
| 507 } | |
| 508 append ret $char | |
| 509 set state $newstate | |
| 510 } | |
| 511 if {$state} {append ret )} | |
| 512 return $ret | |
| 513 } | |
| 514 | |
| 515 # Evaluate a boolean expression of capabilities. If true, execute the | |
| 516 # code. Omit the code if false. | |
| 517 # | |
| 518 proc ifcapable {expr code {else ""} {elsecode ""}} { | |
| 519 #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2 | |
| 520 set e2 [fix_ifcapable_expr $expr] | |
| 521 if ($e2) { | |
| 522 set c [catch {uplevel 1 $code} r] | |
| 523 } else { | |
| 524 set c [catch {uplevel 1 $elsecode} r] | |
| 525 } | |
| 526 return -code $c $r | |
| 527 } | |
| 528 | |
| 529 # This proc execs a seperate process that crashes midway through executing | |
| 530 # the SQL script $sql on database test.db. | |
| 531 # | |
| 532 # The crash occurs during a sync() of file $crashfile. When the crash | |
| 533 # occurs a random subset of all unsynced writes made by the process are | |
| 534 # written into the files on disk. Argument $crashdelay indicates the | |
| 535 # number of file syncs to wait before crashing. | |
| 536 # | |
| 537 # The return value is a list of two elements. The first element is a | |
| 538 # boolean, indicating whether or not the process actually crashed or | |
| 539 # reported some other error. The second element in the returned list is the | |
| 540 # error message. This is "child process exited abnormally" if the crash | |
| 541 # occured. | |
| 542 # | |
| 543 # crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql | |
| 544 # | |
| 545 proc crashsql {args} { | |
| 546 if {$::tcl_platform(platform)!="unix"} { | |
| 547 error "crashsql should only be used on unix" | |
| 548 } | |
| 549 | |
| 550 set blocksize "" | |
| 551 set crashdelay 1 | |
| 552 set prngseed 0 | |
| 553 set tclbody {} | |
| 554 set crashfile "" | |
| 555 set dc "" | |
| 556 set sql [lindex $args end] | |
| 557 | |
| 558 for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} { | |
| 559 set z [lindex $args $ii] | |
| 560 set n [string length $z] | |
| 561 set z2 [lindex $args [expr $ii+1]] | |
| 562 | |
| 563 if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \ | |
| 564 elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \ | |
| 565 elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \ | |
| 566 elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \ | |
| 567 elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \ | |
| 568 elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" }
\ | |
| 569 else { error "Unrecognized option: $z" } | |
| 570 } | |
| 571 | |
| 572 if {$crashfile eq ""} { | |
| 573 error "Compulsory option -file missing" | |
| 574 } | |
| 575 | |
| 576 set cfile [file join [pwd] $crashfile] | |
| 577 | |
| 578 set f [open crash.tcl w] | |
| 579 puts $f "sqlite3_crash_enable 1" | |
| 580 puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile" | |
| 581 puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" | |
| 582 puts $f "sqlite3 db test.db -vfs crash" | |
| 583 | |
| 584 # This block sets the cache size of the main database to 10 | |
| 585 # pages. This is done in case the build is configured to omit | |
| 586 # "PRAGMA cache_size". | |
| 587 puts $f {db eval {SELECT * FROM sqlite_master;}} | |
| 588 puts $f {set bt [btree_from_db db]} | |
| 589 puts $f {btree_set_cache_size $bt 10} | |
| 590 if {$prngseed} { | |
| 591 set seed [expr {$prngseed%10007+1}] | |
| 592 # puts seed=$seed | |
| 593 puts $f "db eval {SELECT randomblob($seed)}" | |
| 594 } | |
| 595 | |
| 596 if {[string length $tclbody]>0} { | |
| 597 puts $f $tclbody | |
| 598 } | |
| 599 if {[string length $sql]>0} { | |
| 600 puts $f "db eval {" | |
| 601 puts $f "$sql" | |
| 602 puts $f "}" | |
| 603 } | |
| 604 close $f | |
| 605 | |
| 606 set r [catch { | |
| 607 exec [info nameofexec] crash.tcl >@stdout | |
| 608 } msg] | |
| 609 lappend r $msg | |
| 610 } | |
| 611 | |
| 612 # Usage: do_ioerr_test <test number> <options...> | |
| 613 # | |
| 614 # This proc is used to implement test cases that check that IO errors | |
| 615 # are correctly handled. The first argument, <test number>, is an integer | |
| 616 # used to name the tests executed by this proc. Options are as follows: | |
| 617 # | |
| 618 # -tclprep TCL script to run to prepare test. | |
| 619 # -sqlprep SQL script to run to prepare test. | |
| 620 # -tclbody TCL script to run with IO error simulation. | |
| 621 # -sqlbody TCL script to run with IO error simulation. | |
| 622 # -exclude List of 'N' values not to test. | |
| 623 # -erc Use extended result codes | |
| 624 # -persist Make simulated I/O errors persistent | |
| 625 # -start Value of 'N' to begin with (default 1) | |
| 626 # | |
| 627 # -cksum Boolean. If true, test that the database does | |
| 628 # not change during the execution of the test case. | |
| 629 # | |
| 630 proc do_ioerr_test {testname args} { | |
| 631 | |
| 632 set ::ioerropts(-start) 1 | |
| 633 set ::ioerropts(-cksum) 0 | |
| 634 set ::ioerropts(-erc) 0 | |
| 635 set ::ioerropts(-count) 100000000 | |
| 636 set ::ioerropts(-persist) 1 | |
| 637 set ::ioerropts(-ckrefcount) 0 | |
| 638 set ::ioerropts(-restoreprng) 1 | |
| 639 array set ::ioerropts $args | |
| 640 | |
| 641 # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are | |
| 642 # a couple of obscure IO errors that do not return them. | |
| 643 set ::ioerropts(-erc) 0 | |
| 644 | |
| 645 set ::go 1 | |
| 646 #reset_prng_state | |
| 647 save_prng_state | |
| 648 for {set n $::ioerropts(-start)} {$::go} {incr n} { | |
| 649 set ::TN $n | |
| 650 incr ::ioerropts(-count) -1 | |
| 651 if {$::ioerropts(-count)<0} break | |
| 652 | |
| 653 # Skip this IO error if it was specified with the "-exclude" option. | |
| 654 if {[info exists ::ioerropts(-exclude)]} { | |
| 655 if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue | |
| 656 } | |
| 657 if {$::ioerropts(-restoreprng)} { | |
| 658 restore_prng_state | |
| 659 } | |
| 660 | |
| 661 # Delete the files test.db and test2.db, then execute the TCL and | |
| 662 # SQL (in that order) to prepare for the test case. | |
| 663 do_test $testname.$n.1 { | |
| 664 set ::sqlite_io_error_pending 0 | |
| 665 catch {db close} | |
| 666 catch {db2 close} | |
| 667 catch {file delete -force test.db} | |
| 668 catch {file delete -force test.db-journal} | |
| 669 catch {file delete -force test2.db} | |
| 670 catch {file delete -force test2.db-journal} | |
| 671 set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] | |
| 672 sqlite3_extended_result_codes $::DB $::ioerropts(-erc) | |
| 673 if {[info exists ::ioerropts(-tclprep)]} { | |
| 674 eval $::ioerropts(-tclprep) | |
| 675 } | |
| 676 if {[info exists ::ioerropts(-sqlprep)]} { | |
| 677 execsql $::ioerropts(-sqlprep) | |
| 678 } | |
| 679 expr 0 | |
| 680 } {0} | |
| 681 | |
| 682 # Read the 'checksum' of the database. | |
| 683 if {$::ioerropts(-cksum)} { | |
| 684 set checksum [cksum] | |
| 685 } | |
| 686 | |
| 687 # Set the Nth IO error to fail. | |
| 688 do_test $testname.$n.2 [subst { | |
| 689 set ::sqlite_io_error_persist $::ioerropts(-persist) | |
| 690 set ::sqlite_io_error_pending $n | |
| 691 }] $n | |
| 692 | |
| 693 # Create a single TCL script from the TCL and SQL specified | |
| 694 # as the body of the test. | |
| 695 set ::ioerrorbody {} | |
| 696 if {[info exists ::ioerropts(-tclbody)]} { | |
| 697 append ::ioerrorbody "$::ioerropts(-tclbody)\n" | |
| 698 } | |
| 699 if {[info exists ::ioerropts(-sqlbody)]} { | |
| 700 append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}" | |
| 701 } | |
| 702 | |
| 703 # Execute the TCL Script created in the above block. If | |
| 704 # there are at least N IO operations performed by SQLite as | |
| 705 # a result of the script, the Nth will fail. | |
| 706 do_test $testname.$n.3 { | |
| 707 set ::sqlite_io_error_hit 0 | |
| 708 set ::sqlite_io_error_hardhit 0 | |
| 709 set r [catch $::ioerrorbody msg] | |
| 710 set ::errseen $r | |
| 711 set rc [sqlite3_errcode $::DB] | |
| 712 if {$::ioerropts(-erc)} { | |
| 713 # If we are in extended result code mode, make sure all of the | |
| 714 # IOERRs we get back really do have their extended code values. | |
| 715 # If an extended result code is returned, the sqlite3_errcode | |
| 716 # TCLcommand will return a string of the form: SQLITE_IOERR+nnnn | |
| 717 # where nnnn is a number | |
| 718 if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} { | |
| 719 return $rc | |
| 720 } | |
| 721 } else { | |
| 722 # If we are not in extended result code mode, make sure no | |
| 723 # extended error codes are returned. | |
| 724 if {[regexp {\+\d} $rc]} { | |
| 725 return $rc | |
| 726 } | |
| 727 } | |
| 728 # The test repeats as long as $::go is non-zero. $::go starts out | |
| 729 # as 1. When a test runs to completion without hitting an I/O | |
| 730 # error, that means there is no point in continuing with this test | |
| 731 # case so set $::go to zero. | |
| 732 # | |
| 733 if {$::sqlite_io_error_pending>0} { | |
| 734 set ::go 0 | |
| 735 set q 0 | |
| 736 set ::sqlite_io_error_pending 0 | |
| 737 } else { | |
| 738 set q 1 | |
| 739 } | |
| 740 | |
| 741 set s [expr $::sqlite_io_error_hit==0] | |
| 742 if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} { | |
| 743 set r 1 | |
| 744 } | |
| 745 set ::sqlite_io_error_hit 0 | |
| 746 | |
| 747 # One of two things must have happened. either | |
| 748 # 1. We never hit the IO error and the SQL returned OK | |
| 749 # 2. An IO error was hit and the SQL failed | |
| 750 # | |
| 751 expr { ($s && !$r && !$q) || (!$s && $r && $q) } | |
| 752 } {1} | |
| 753 | |
| 754 set ::sqlite_io_error_hit 0 | |
| 755 set ::sqlite_io_error_pending 0 | |
| 756 | |
| 757 # Check that no page references were leaked. There should be | |
| 758 # a single reference if there is still an active transaction, | |
| 759 # or zero otherwise. | |
| 760 # | |
| 761 # UPDATE: If the IO error occurs after a 'BEGIN' but before any | |
| 762 # locks are established on database files (i.e. if the error | |
| 763 # occurs while attempting to detect a hot-journal file), then | |
| 764 # there may 0 page references and an active transaction according | |
| 765 # to [sqlite3_get_autocommit]. | |
| 766 # | |
| 767 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} { | |
| 768 do_test $testname.$n.4 { | |
| 769 set bt [btree_from_db db] | |
| 770 db_enter db | |
| 771 array set stats [btree_pager_stats $bt] | |
| 772 db_leave db | |
| 773 set nRef $stats(ref) | |
| 774 expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)} | |
| 775 } {1} | |
| 776 } | |
| 777 | |
| 778 # If there is an open database handle and no open transaction, | |
| 779 # and the pager is not running in exclusive-locking mode, | |
| 780 # check that the pager is in "unlocked" state. Theoretically, | |
| 781 # if a call to xUnlock() failed due to an IO error the underlying | |
| 782 # file may still be locked. | |
| 783 # | |
| 784 ifcapable pragma { | |
| 785 if { [info commands db] ne "" | |
| 786 && $::ioerropts(-ckrefcount) | |
| 787 && [db one {pragma locking_mode}] eq "normal" | |
| 788 && [sqlite3_get_autocommit db] | |
| 789 } { | |
| 790 do_test $testname.$n.5 { | |
| 791 set bt [btree_from_db db] | |
| 792 db_enter db | |
| 793 array set stats [btree_pager_stats $bt] | |
| 794 db_leave db | |
| 795 set stats(state) | |
| 796 } 0 | |
| 797 } | |
| 798 } | |
| 799 | |
| 800 # If an IO error occured, then the checksum of the database should | |
| 801 # be the same as before the script that caused the IO error was run. | |
| 802 # | |
| 803 if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} { | |
| 804 do_test $testname.$n.6 { | |
| 805 catch {db close} | |
| 806 catch {db2 close} | |
| 807 set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db] | |
| 808 cksum | |
| 809 } $checksum | |
| 810 } | |
| 811 | |
| 812 set ::sqlite_io_error_hardhit 0 | |
| 813 set ::sqlite_io_error_pending 0 | |
| 814 if {[info exists ::ioerropts(-cleanup)]} { | |
| 815 catch $::ioerropts(-cleanup) | |
| 816 } | |
| 817 } | |
| 818 set ::sqlite_io_error_pending 0 | |
| 819 set ::sqlite_io_error_persist 0 | |
| 820 unset ::ioerropts | |
| 821 } | |
| 822 | |
| 823 # Return a checksum based on the contents of the main database associated | |
| 824 # with connection $db | |
| 825 # | |
| 826 proc cksum {{db db}} { | |
| 827 set txt [$db eval { | |
| 828 SELECT name, type, sql FROM sqlite_master order by name | |
| 829 }]\n | |
| 830 foreach tbl [$db eval { | |
| 831 SELECT name FROM sqlite_master WHERE type='table' order by name | |
| 832 }] { | |
| 833 append txt [$db eval "SELECT * FROM $tbl"]\n | |
| 834 } | |
| 835 foreach prag {default_synchronous default_cache_size} { | |
| 836 append txt $prag-[$db eval "PRAGMA $prag"]\n | |
| 837 } | |
| 838 set cksum [string length $txt]-[md5 $txt] | |
| 839 # puts $cksum-[file size test.db] | |
| 840 return $cksum | |
| 841 } | |
| 842 | |
| 843 # Generate a checksum based on the contents of the main and temp tables | |
| 844 # database $db. If the checksum of two databases is the same, and the | |
| 845 # integrity-check passes for both, the two databases are identical. | |
| 846 # | |
| 847 proc allcksum {{db db}} { | |
| 848 set ret [list] | |
| 849 ifcapable tempdb { | |
| 850 set sql { | |
| 851 SELECT name FROM sqlite_master WHERE type = 'table' UNION | |
| 852 SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION | |
| 853 SELECT 'sqlite_master' UNION | |
| 854 SELECT 'sqlite_temp_master' ORDER BY 1 | |
| 855 } | |
| 856 } else { | |
| 857 set sql { | |
| 858 SELECT name FROM sqlite_master WHERE type = 'table' UNION | |
| 859 SELECT 'sqlite_master' ORDER BY 1 | |
| 860 } | |
| 861 } | |
| 862 set tbllist [$db eval $sql] | |
| 863 set txt {} | |
| 864 foreach tbl $tbllist { | |
| 865 append txt [$db eval "SELECT * FROM $tbl"] | |
| 866 } | |
| 867 foreach prag {default_cache_size} { | |
| 868 append txt $prag-[$db eval "PRAGMA $prag"]\n | |
| 869 } | |
| 870 # puts txt=$txt | |
| 871 return [md5 $txt] | |
| 872 } | |
| 873 | |
| 874 # Generate a checksum based on the contents of a single database with | |
| 875 # a database connection. The name of the database is $dbname. | |
| 876 # Examples of $dbname are "temp" or "main". | |
| 877 # | |
| 878 proc dbcksum {db dbname} { | |
| 879 if {$dbname=="temp"} { | |
| 880 set master sqlite_temp_master | |
| 881 } else { | |
| 882 set master $dbname.sqlite_master | |
| 883 } | |
| 884 set alltab [$db eval "SELECT name FROM $master WHERE type='table'"] | |
| 885 set txt [$db eval "SELECT * FROM $master"]\n | |
| 886 foreach tab $alltab { | |
| 887 append txt [$db eval "SELECT * FROM $dbname.$tab"]\n | |
| 888 } | |
| 889 return [md5 $txt] | |
| 890 } | |
| 891 | |
| 892 proc memdebug_log_sql {{filename mallocs.sql}} { | |
| 893 | |
| 894 set data [sqlite3_memdebug_log dump] | |
| 895 set nFrame [expr [llength [lindex $data 0]]-2] | |
| 896 if {$nFrame < 0} { return "" } | |
| 897 | |
| 898 set database temp | |
| 899 | |
| 900 set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);" | |
| 901 | |
| 902 set sql "" | |
| 903 foreach e $data { | |
| 904 set nCall [lindex $e 0] | |
| 905 set nByte [lindex $e 1] | |
| 906 set lStack [lrange $e 2 end] | |
| 907 append sql "INSERT INTO ${database}.malloc VALUES" | |
| 908 append sql "('test', $nCall, $nByte, '$lStack');\n" | |
| 909 foreach f $lStack { | |
| 910 set frames($f) 1 | |
| 911 } | |
| 912 } | |
| 913 | |
| 914 set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n" | |
| 915 set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n" | |
| 916 | |
| 917 foreach f [array names frames] { | |
| 918 set addr [format %x $f] | |
| 919 set cmd "addr2line -e [info nameofexec] $addr" | |
| 920 set line [eval exec $cmd] | |
| 921 append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n" | |
| 922 | |
| 923 set file [lindex [split $line :] 0] | |
| 924 set files($file) 1 | |
| 925 } | |
| 926 | |
| 927 foreach f [array names files] { | |
| 928 set contents "" | |
| 929 catch { | |
| 930 set fd [open $f] | |
| 931 set contents [read $fd] | |
| 932 close $fd | |
| 933 } | |
| 934 set contents [string map {' ''} $contents] | |
| 935 append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n" | |
| 936 } | |
| 937 | |
| 938 set fd [open $filename w] | |
| 939 puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;" | |
| 940 close $fd | |
| 941 } | |
| 942 | |
| 943 # Copy file $from into $to. This is used because some versions of | |
| 944 # TCL for windows (notably the 8.4.1 binary package shipped with the | |
| 945 # current mingw release) have a broken "file copy" command. | |
| 946 # | |
| 947 proc copy_file {from to} { | |
| 948 if {$::tcl_platform(platform)=="unix"} { | |
| 949 file copy -force $from $to | |
| 950 } else { | |
| 951 set f [open $from] | |
| 952 fconfigure $f -translation binary | |
| 953 set t [open $to w] | |
| 954 fconfigure $t -translation binary | |
| 955 puts -nonewline $t [read $f [file size $from]] | |
| 956 close $t | |
| 957 close $f | |
| 958 } | |
| 959 } | |
| 960 | |
| 961 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set | |
| 962 # to non-zero, then set the global variable $AUTOVACUUM to 1. | |
| 963 set AUTOVACUUM $sqlite_options(default_autovacuum) | |
| 964 | |
| 965 source $testdir/thread_common.tcl | |
| OLD | NEW |
|---|
Chromium Code Reviews
Issue 3108030:
Move bundled copy of sqlite one level deeper to better separate it... (Closed)
Base URL: svn://svn.chromium.org/chrome/trunk/src/