Annotation of embedaddon/sqlite3/test/malloc_common.tcl, revision 1.1
1.1 ! misho 1: # 2007 May 05
! 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: #
! 12: # This file contains common code used by many different malloc tests
! 13: # within the test suite.
! 14: #
! 15: # $Id: malloc_common.tcl,v 1.22 2008/09/23 16:41:30 danielk1977 Exp $
! 16:
! 17: # If we did not compile with malloc testing enabled, then do nothing.
! 18: #
! 19: ifcapable builtin_test {
! 20: set MEMDEBUG 1
! 21: } else {
! 22: set MEMDEBUG 0
! 23: return 0
! 24: }
! 25:
! 26: # Transient and persistent OOM errors:
! 27: #
! 28: set FAULTSIM(oom-transient) [list \
! 29: -injectstart {oom_injectstart 0} \
! 30: -injectstop oom_injectstop \
! 31: -injecterrlist {{1 {out of memory}}} \
! 32: ]
! 33: set FAULTSIM(oom-persistent) [list \
! 34: -injectstart {oom_injectstart 1000000} \
! 35: -injectstop oom_injectstop \
! 36: -injecterrlist {{1 {out of memory}}} \
! 37: ]
! 38:
! 39: # Transient and persistent IO errors:
! 40: #
! 41: set FAULTSIM(ioerr-transient) [list \
! 42: -injectstart {ioerr_injectstart 0} \
! 43: -injectstop ioerr_injectstop \
! 44: -injecterrlist {{1 {disk I/O error}}} \
! 45: ]
! 46: set FAULTSIM(ioerr-persistent) [list \
! 47: -injectstart {ioerr_injectstart 1} \
! 48: -injectstop ioerr_injectstop \
! 49: -injecterrlist {{1 {disk I/O error}}} \
! 50: ]
! 51:
! 52: # SQLITE_FULL errors (always persistent):
! 53: #
! 54: set FAULTSIM(full) [list \
! 55: -injectinstall fullerr_injectinstall \
! 56: -injectstart fullerr_injectstart \
! 57: -injectstop fullerr_injectstop \
! 58: -injecterrlist {{1 {database or disk is full}}} \
! 59: -injectuninstall fullerr_injectuninstall \
! 60: ]
! 61:
! 62: # Transient and persistent SHM errors:
! 63: #
! 64: set FAULTSIM(shmerr-transient) [list \
! 65: -injectinstall shmerr_injectinstall \
! 66: -injectstart {shmerr_injectstart 0} \
! 67: -injectstop shmerr_injectstop \
! 68: -injecterrlist {{1 {disk I/O error}}} \
! 69: -injectuninstall shmerr_injectuninstall \
! 70: ]
! 71: set FAULTSIM(shmerr-persistent) [list \
! 72: -injectinstall shmerr_injectinstall \
! 73: -injectstart {shmerr_injectstart 1} \
! 74: -injectstop shmerr_injectstop \
! 75: -injecterrlist {{1 {disk I/O error}}} \
! 76: -injectuninstall shmerr_injectuninstall \
! 77: ]
! 78:
! 79: # Transient and persistent CANTOPEN errors:
! 80: #
! 81: set FAULTSIM(cantopen-transient) [list \
! 82: -injectinstall cantopen_injectinstall \
! 83: -injectstart {cantopen_injectstart 0} \
! 84: -injectstop cantopen_injectstop \
! 85: -injecterrlist {{1 {unable to open database file}}} \
! 86: -injectuninstall cantopen_injectuninstall \
! 87: ]
! 88: set FAULTSIM(cantopen-persistent) [list \
! 89: -injectinstall cantopen_injectinstall \
! 90: -injectstart {cantopen_injectstart 1} \
! 91: -injectstop cantopen_injectstop \
! 92: -injecterrlist {{1 {unable to open database file}}} \
! 93: -injectuninstall cantopen_injectuninstall \
! 94: ]
! 95:
! 96:
! 97:
! 98: #--------------------------------------------------------------------------
! 99: # Usage do_faultsim_test NAME ?OPTIONS...?
! 100: #
! 101: # -faults List of fault types to simulate.
! 102: #
! 103: # -prep Script to execute before -body.
! 104: #
! 105: # -body Script to execute (with fault injection).
! 106: #
! 107: # -test Script to execute after -body.
! 108: #
! 109: # -install Script to execute after faultsim -injectinstall
! 110: #
! 111: # -uninstall Script to execute after faultsim -uninjectinstall
! 112: #
! 113: proc do_faultsim_test {name args} {
! 114: global FAULTSIM
! 115:
! 116: set DEFAULT(-faults) [array names FAULTSIM]
! 117: set DEFAULT(-prep) ""
! 118: set DEFAULT(-body) ""
! 119: set DEFAULT(-test) ""
! 120: set DEFAULT(-install) ""
! 121: set DEFAULT(-uninstall) ""
! 122:
! 123: fix_testname name
! 124:
! 125: array set O [array get DEFAULT]
! 126: array set O $args
! 127: foreach o [array names O] {
! 128: if {[info exists DEFAULT($o)]==0} { error "unknown option: $o" }
! 129: }
! 130:
! 131: set faultlist [list]
! 132: foreach f $O(-faults) {
! 133: set flist [array names FAULTSIM $f]
! 134: if {[llength $flist]==0} { error "unknown fault: $f" }
! 135: set faultlist [concat $faultlist $flist]
! 136: }
! 137:
! 138: set testspec [list -prep $O(-prep) -body $O(-body) \
! 139: -test $O(-test) -install $O(-install) -uninstall $O(-uninstall)
! 140: ]
! 141: foreach f [lsort -unique $faultlist] {
! 142: eval do_one_faultsim_test "$name-$f" $FAULTSIM($f) $testspec
! 143: }
! 144: }
! 145:
! 146:
! 147: #-------------------------------------------------------------------------
! 148: # Procedures to save and restore the current file-system state:
! 149: #
! 150: # faultsim_save
! 151: # faultsim_restore
! 152: # faultsim_save_and_close
! 153: # faultsim_restore_and_reopen
! 154: # faultsim_delete_and_reopen
! 155: #
! 156: proc faultsim_save {args} { uplevel db_save $args }
! 157: proc faultsim_save_and_close {args} { uplevel db_save_and_close $args }
! 158: proc faultsim_restore {args} { uplevel db_restore $args }
! 159: proc faultsim_restore_and_reopen {args} {
! 160: uplevel db_restore_and_reopen $args
! 161: sqlite3_extended_result_codes db 1
! 162: sqlite3_db_config_lookaside db 0 0 0
! 163: }
! 164: proc faultsim_delete_and_reopen {args} {
! 165: uplevel db_delete_and_reopen $args
! 166: sqlite3_extended_result_codes db 1
! 167: sqlite3_db_config_lookaside db 0 0 0
! 168: }
! 169:
! 170: proc faultsim_integrity_check {{db db}} {
! 171: set ic [$db eval { PRAGMA integrity_check }]
! 172: if {$ic != "ok"} { error "Integrity check: $ic" }
! 173: }
! 174:
! 175:
! 176: # The following procs are used as [do_one_faultsim_test] callbacks when
! 177: # injecting OOM faults into test cases.
! 178: #
! 179: proc oom_injectstart {nRepeat iFail} {
! 180: sqlite3_memdebug_fail [expr $iFail-1] -repeat $nRepeat
! 181: }
! 182: proc oom_injectstop {} {
! 183: sqlite3_memdebug_fail -1
! 184: }
! 185:
! 186: # The following procs are used as [do_one_faultsim_test] callbacks when
! 187: # injecting IO error faults into test cases.
! 188: #
! 189: proc ioerr_injectstart {persist iFail} {
! 190: set ::sqlite_io_error_persist $persist
! 191: set ::sqlite_io_error_pending $iFail
! 192: }
! 193: proc ioerr_injectstop {} {
! 194: set sv $::sqlite_io_error_hit
! 195: set ::sqlite_io_error_persist 0
! 196: set ::sqlite_io_error_pending 0
! 197: set ::sqlite_io_error_hardhit 0
! 198: set ::sqlite_io_error_hit 0
! 199: set ::sqlite_io_error_pending 0
! 200: return $sv
! 201: }
! 202:
! 203: # The following procs are used as [do_one_faultsim_test] callbacks when
! 204: # injecting shared-memory related error faults into test cases.
! 205: #
! 206: proc shmerr_injectinstall {} {
! 207: testvfs shmfault -default true
! 208: shmfault filter {xShmOpen xShmMap xShmLock}
! 209: }
! 210: proc shmerr_injectuninstall {} {
! 211: catch {db close}
! 212: catch {db2 close}
! 213: shmfault delete
! 214: }
! 215: proc shmerr_injectstart {persist iFail} {
! 216: shmfault ioerr $iFail $persist
! 217: }
! 218: proc shmerr_injectstop {} {
! 219: shmfault ioerr
! 220: }
! 221:
! 222: # The following procs are used as [do_one_faultsim_test] callbacks when
! 223: # injecting SQLITE_FULL error faults into test cases.
! 224: #
! 225: proc fullerr_injectinstall {} {
! 226: testvfs shmfault -default true
! 227: }
! 228: proc fullerr_injectuninstall {} {
! 229: catch {db close}
! 230: catch {db2 close}
! 231: shmfault delete
! 232: }
! 233: proc fullerr_injectstart {iFail} {
! 234: shmfault full $iFail 1
! 235: }
! 236: proc fullerr_injectstop {} {
! 237: shmfault full
! 238: }
! 239:
! 240: # The following procs are used as [do_one_faultsim_test] callbacks when
! 241: # injecting SQLITE_CANTOPEN error faults into test cases.
! 242: #
! 243: proc cantopen_injectinstall {} {
! 244: testvfs shmfault -default true
! 245: }
! 246: proc cantopen_injectuninstall {} {
! 247: catch {db close}
! 248: catch {db2 close}
! 249: shmfault delete
! 250: }
! 251: proc cantopen_injectstart {persist iFail} {
! 252: shmfault cantopen $iFail $persist
! 253: }
! 254: proc cantopen_injectstop {} {
! 255: shmfault cantopen
! 256: }
! 257:
! 258: # This command is not called directly. It is used by the
! 259: # [faultsim_test_result] command created by [do_faultsim_test] and used
! 260: # by -test scripts.
! 261: #
! 262: proc faultsim_test_result_int {args} {
! 263: upvar testrc testrc testresult testresult testnfail testnfail
! 264: set t [list $testrc $testresult]
! 265: set r $args
! 266: if { ($testnfail==0 && $t != [lindex $r 0]) || [lsearch $r $t]<0 } {
! 267: error "nfail=$testnfail rc=$testrc result=$testresult"
! 268: }
! 269: }
! 270:
! 271: #--------------------------------------------------------------------------
! 272: # Usage do_one_faultsim_test NAME ?OPTIONS...?
! 273: #
! 274: # The first argument, <test number>, is used as a prefix of the test names
! 275: # taken by tests executed by this command. Options are as follows. All
! 276: # options take a single argument.
! 277: #
! 278: # -injectstart Script to enable fault-injection.
! 279: #
! 280: # -injectstop Script to disable fault-injection.
! 281: #
! 282: # -injecterrlist List of generally acceptable test results (i.e. error
! 283: # messages). Example: [list {1 {out of memory}}]
! 284: #
! 285: # -injectinstall
! 286: #
! 287: # -injectuninstall
! 288: #
! 289: # -prep Script to execute before -body.
! 290: #
! 291: # -body Script to execute (with fault injection).
! 292: #
! 293: # -test Script to execute after -body.
! 294: #
! 295: proc do_one_faultsim_test {testname args} {
! 296:
! 297: set DEFAULT(-injectstart) "expr"
! 298: set DEFAULT(-injectstop) "expr 0"
! 299: set DEFAULT(-injecterrlist) [list]
! 300: set DEFAULT(-injectinstall) ""
! 301: set DEFAULT(-injectuninstall) ""
! 302: set DEFAULT(-prep) ""
! 303: set DEFAULT(-body) ""
! 304: set DEFAULT(-test) ""
! 305: set DEFAULT(-install) ""
! 306: set DEFAULT(-uninstall) ""
! 307:
! 308: array set O [array get DEFAULT]
! 309: array set O $args
! 310: foreach o [array names O] {
! 311: if {[info exists DEFAULT($o)]==0} { error "unknown option: $o" }
! 312: }
! 313:
! 314: proc faultsim_test_proc {testrc testresult testnfail} $O(-test)
! 315: proc faultsim_test_result {args} "
! 316: uplevel faultsim_test_result_int \$args [list $O(-injecterrlist)]
! 317: "
! 318:
! 319: eval $O(-injectinstall)
! 320: eval $O(-install)
! 321:
! 322: set stop 0
! 323: for {set iFail 1} {!$stop} {incr iFail} {
! 324:
! 325: # Evaluate the -prep script.
! 326: #
! 327: eval $O(-prep)
! 328:
! 329: # Start the fault-injection. Run the -body script. Stop the fault
! 330: # injection. Local var $nfail is set to the total number of faults
! 331: # injected into the system this trial.
! 332: #
! 333: eval $O(-injectstart) $iFail
! 334: set rc [catch $O(-body) res]
! 335: set nfail [eval $O(-injectstop)]
! 336:
! 337: # Run the -test script. If it throws no error, consider this trial
! 338: # sucessful. If it does throw an error, cause a [do_test] test to
! 339: # fail (and print out the unexpected exception thrown by the -test
! 340: # script at the same time).
! 341: #
! 342: set rc [catch [list faultsim_test_proc $rc $res $nfail] res]
! 343: if {$rc == 0} {set res ok}
! 344: do_test $testname.$iFail [list list $rc $res] {0 ok}
! 345:
! 346: # If no faults where injected this trial, don't bother running
! 347: # any more. This test is finished.
! 348: #
! 349: if {$nfail==0} { set stop 1 }
! 350: }
! 351:
! 352: eval $O(-uninstall)
! 353: eval $O(-injectuninstall)
! 354: }
! 355:
! 356: # Usage: do_malloc_test <test number> <options...>
! 357: #
! 358: # The first argument, <test number>, is an integer used to name the
! 359: # tests executed by this proc. Options are as follows:
! 360: #
! 361: # -tclprep TCL script to run to prepare test.
! 362: # -sqlprep SQL script to run to prepare test.
! 363: # -tclbody TCL script to run with malloc failure simulation.
! 364: # -sqlbody TCL script to run with malloc failure simulation.
! 365: # -cleanup TCL script to run after the test.
! 366: #
! 367: # This command runs a series of tests to verify SQLite's ability
! 368: # to handle an out-of-memory condition gracefully. It is assumed
! 369: # that if this condition occurs a malloc() call will return a
! 370: # NULL pointer. Linux, for example, doesn't do that by default. See
! 371: # the "BUGS" section of malloc(3).
! 372: #
! 373: # Each iteration of a loop, the TCL commands in any argument passed
! 374: # to the -tclbody switch, followed by the SQL commands in any argument
! 375: # passed to the -sqlbody switch are executed. Each iteration the
! 376: # Nth call to sqliteMalloc() is made to fail, where N is increased
! 377: # each time the loop runs starting from 1. When all commands execute
! 378: # successfully, the loop ends.
! 379: #
! 380: proc do_malloc_test {tn args} {
! 381: array unset ::mallocopts
! 382: array set ::mallocopts $args
! 383:
! 384: if {[string is integer $tn]} {
! 385: set tn malloc-$tn
! 386: }
! 387: if {[info exists ::mallocopts(-start)]} {
! 388: set start $::mallocopts(-start)
! 389: } else {
! 390: set start 0
! 391: }
! 392: if {[info exists ::mallocopts(-end)]} {
! 393: set end $::mallocopts(-end)
! 394: } else {
! 395: set end 50000
! 396: }
! 397: save_prng_state
! 398:
! 399: foreach ::iRepeat {0 10000000} {
! 400: set ::go 1
! 401: for {set ::n $start} {$::go && $::n <= $end} {incr ::n} {
! 402:
! 403: # If $::iRepeat is 0, then the malloc() failure is transient - it
! 404: # fails and then subsequent calls succeed. If $::iRepeat is 1,
! 405: # then the failure is persistent - once malloc() fails it keeps
! 406: # failing.
! 407: #
! 408: set zRepeat "transient"
! 409: if {$::iRepeat} {set zRepeat "persistent"}
! 410: restore_prng_state
! 411: foreach file [glob -nocomplain test.db-mj*] {forcedelete $file}
! 412:
! 413: do_test ${tn}.${zRepeat}.${::n} {
! 414:
! 415: # Remove all traces of database files test.db and test2.db
! 416: # from the file-system. Then open (empty database) "test.db"
! 417: # with the handle [db].
! 418: #
! 419: catch {db close}
! 420: catch {db2 close}
! 421: forcedelete test.db
! 422: forcedelete test.db-journal
! 423: forcedelete test.db-wal
! 424: forcedelete test2.db
! 425: forcedelete test2.db-journal
! 426: forcedelete test2.db-wal
! 427: if {[info exists ::mallocopts(-testdb)]} {
! 428: copy_file $::mallocopts(-testdb) test.db
! 429: }
! 430: catch { sqlite3 db test.db }
! 431: if {[info commands db] ne ""} {
! 432: sqlite3_extended_result_codes db 1
! 433: }
! 434: sqlite3_db_config_lookaside db 0 0 0
! 435:
! 436: # Execute any -tclprep and -sqlprep scripts.
! 437: #
! 438: if {[info exists ::mallocopts(-tclprep)]} {
! 439: eval $::mallocopts(-tclprep)
! 440: }
! 441: if {[info exists ::mallocopts(-sqlprep)]} {
! 442: execsql $::mallocopts(-sqlprep)
! 443: }
! 444:
! 445: # Now set the ${::n}th malloc() to fail and execute the -tclbody
! 446: # and -sqlbody scripts.
! 447: #
! 448: sqlite3_memdebug_fail $::n -repeat $::iRepeat
! 449: set ::mallocbody {}
! 450: if {[info exists ::mallocopts(-tclbody)]} {
! 451: append ::mallocbody "$::mallocopts(-tclbody)\n"
! 452: }
! 453: if {[info exists ::mallocopts(-sqlbody)]} {
! 454: append ::mallocbody "db eval {$::mallocopts(-sqlbody)}"
! 455: }
! 456:
! 457: # The following block sets local variables as follows:
! 458: #
! 459: # isFail - True if an error (any error) was reported by sqlite.
! 460: # nFail - The total number of simulated malloc() failures.
! 461: # nBenign - The number of benign simulated malloc() failures.
! 462: #
! 463: set isFail [catch $::mallocbody msg]
! 464: set nFail [sqlite3_memdebug_fail -1 -benigncnt nBenign]
! 465: # puts -nonewline " (isFail=$isFail nFail=$nFail nBenign=$nBenign) "
! 466:
! 467: # If one or more mallocs failed, run this loop body again.
! 468: #
! 469: set go [expr {$nFail>0}]
! 470:
! 471: if {($nFail-$nBenign)==0} {
! 472: if {$isFail} {
! 473: set v2 $msg
! 474: } else {
! 475: set isFail 1
! 476: set v2 1
! 477: }
! 478: } elseif {!$isFail} {
! 479: set v2 $msg
! 480: } elseif {
! 481: [info command db]=="" ||
! 482: [db errorcode]==7 ||
! 483: $msg=="out of memory"
! 484: } {
! 485: set v2 1
! 486: } else {
! 487: set v2 $msg
! 488: puts [db errorcode]
! 489: }
! 490: lappend isFail $v2
! 491: } {1 1}
! 492:
! 493: if {[info exists ::mallocopts(-cleanup)]} {
! 494: catch [list uplevel #0 $::mallocopts(-cleanup)] msg
! 495: }
! 496: }
! 497: }
! 498: unset ::mallocopts
! 499: sqlite3_memdebug_fail -1
! 500: }
! 501:
! 502:
! 503: #-------------------------------------------------------------------------
! 504: # This proc is used to test a single SELECT statement. Parameter $name is
! 505: # passed a name for the test case (i.e. "fts3_malloc-1.4.1") and parameter
! 506: # $sql is passed the text of the SELECT statement. Parameter $result is
! 507: # set to the expected output if the SELECT statement is successfully
! 508: # executed using [db eval].
! 509: #
! 510: # Example:
! 511: #
! 512: # do_select_test testcase-1.1 "SELECT 1+1, 1+2" {1 2}
! 513: #
! 514: # If global variable DO_MALLOC_TEST is set to a non-zero value, or if
! 515: # it is not defined at all, then OOM testing is performed on the SELECT
! 516: # statement. Each OOM test case is said to pass if either (a) executing
! 517: # the SELECT statement succeeds and the results match those specified
! 518: # by parameter $result, or (b) TCL throws an "out of memory" error.
! 519: #
! 520: # If DO_MALLOC_TEST is defined and set to zero, then the SELECT statement
! 521: # is executed just once. In this case the test case passes if the results
! 522: # match the expected results passed via parameter $result.
! 523: #
! 524: proc do_select_test {name sql result} {
! 525: uplevel [list doPassiveTest 0 $name $sql [list 0 [list {*}$result]]]
! 526: }
! 527:
! 528: proc do_restart_select_test {name sql result} {
! 529: uplevel [list doPassiveTest 1 $name $sql [list 0 $result]]
! 530: }
! 531:
! 532: proc do_error_test {name sql error} {
! 533: uplevel [list doPassiveTest 0 $name $sql [list 1 $error]]
! 534: }
! 535:
! 536: proc doPassiveTest {isRestart name sql catchres} {
! 537: if {![info exists ::DO_MALLOC_TEST]} { set ::DO_MALLOC_TEST 1 }
! 538:
! 539: if {[info exists ::testprefix]
! 540: && [string is integer [string range $name 0 0]]
! 541: } {
! 542: set name $::testprefix.$name
! 543: }
! 544:
! 545: switch $::DO_MALLOC_TEST {
! 546: 0 { # No malloc failures.
! 547: do_test $name [list set {} [uplevel [list catchsql $sql]]] $catchres
! 548: return
! 549: }
! 550: 1 { # Simulate transient failures.
! 551: set nRepeat 1
! 552: set zName "transient"
! 553: set nStartLimit 100000
! 554: set nBackup 1
! 555: }
! 556: 2 { # Simulate persistent failures.
! 557: set nRepeat 1
! 558: set zName "persistent"
! 559: set nStartLimit 100000
! 560: set nBackup 1
! 561: }
! 562: 3 { # Simulate transient failures with extra brute force.
! 563: set nRepeat 100000
! 564: set zName "ridiculous"
! 565: set nStartLimit 1
! 566: set nBackup 10
! 567: }
! 568: }
! 569:
! 570: # The set of acceptable results from running [catchsql $sql].
! 571: #
! 572: set answers [list {1 {out of memory}} $catchres]
! 573: set str [join $answers " OR "]
! 574:
! 575: set nFail 1
! 576: for {set iLimit $nStartLimit} {$nFail} {incr iLimit} {
! 577: for {set iFail 1} {$nFail && $iFail<=$iLimit} {incr iFail} {
! 578: for {set iTest 0} {$iTest<$nBackup && ($iFail-$iTest)>0} {incr iTest} {
! 579:
! 580: if {$isRestart} { sqlite3 db test.db }
! 581:
! 582: sqlite3_memdebug_fail [expr $iFail-$iTest] -repeat $nRepeat
! 583: set res [uplevel [list catchsql $sql]]
! 584: if {[lsearch -exact $answers $res]>=0} { set res $str }
! 585: set testname "$name.$zName.$iFail"
! 586: do_test "$name.$zName.$iLimit.$iFail" [list set {} $res] $str
! 587:
! 588: set nFail [sqlite3_memdebug_fail -1 -benigncnt nBenign]
! 589: }
! 590: }
! 591: }
! 592: }
! 593:
! 594:
! 595: #-------------------------------------------------------------------------
! 596: # Test a single write to the database. In this case a "write" is a
! 597: # DELETE, UPDATE or INSERT statement.
! 598: #
! 599: # If OOM testing is performed, there are several acceptable outcomes:
! 600: #
! 601: # 1) The write succeeds. No error is returned.
! 602: #
! 603: # 2) An "out of memory" exception is thrown and:
! 604: #
! 605: # a) The statement has no effect, OR
! 606: # b) The current transaction is rolled back, OR
! 607: # c) The statement succeeds. This can only happen if the connection
! 608: # is in auto-commit mode (after the statement is executed, so this
! 609: # includes COMMIT statements).
! 610: #
! 611: # If the write operation eventually succeeds, zero is returned. If a
! 612: # transaction is rolled back, non-zero is returned.
! 613: #
! 614: # Parameter $name is the name to use for the test case (or test cases).
! 615: # The second parameter, $tbl, should be the name of the database table
! 616: # being modified. Parameter $sql contains the SQL statement to test.
! 617: #
! 618: proc do_write_test {name tbl sql} {
! 619: if {![info exists ::DO_MALLOC_TEST]} { set ::DO_MALLOC_TEST 1 }
! 620:
! 621: # Figure out an statement to get a checksum for table $tbl.
! 622: db eval "SELECT * FROM $tbl" V break
! 623: set cksumsql "SELECT md5sum([join [concat rowid $V(*)] ,]) FROM $tbl"
! 624:
! 625: # Calculate the initial table checksum.
! 626: set cksum1 [db one $cksumsql]
! 627:
! 628: if {$::DO_MALLOC_TEST } {
! 629: set answers [list {1 {out of memory}} {0 {}}]
! 630: if {$::DO_MALLOC_TEST==1} {
! 631: set modes {100000 persistent}
! 632: } else {
! 633: set modes {1 transient}
! 634: }
! 635: } else {
! 636: set answers [list {0 {}}]
! 637: set modes [list 0 nofail]
! 638: }
! 639: set str [join $answers " OR "]
! 640:
! 641: foreach {nRepeat zName} $modes {
! 642: for {set iFail 1} 1 {incr iFail} {
! 643: if {$::DO_MALLOC_TEST} {sqlite3_memdebug_fail $iFail -repeat $nRepeat}
! 644:
! 645: set res [uplevel [list catchsql $sql]]
! 646: set nFail [sqlite3_memdebug_fail -1 -benigncnt nBenign]
! 647: if {$nFail==0} {
! 648: do_test $name.$zName.$iFail [list set {} $res] {0 {}}
! 649: return
! 650: } else {
! 651: if {[lsearch $answers $res]>=0} {
! 652: set res $str
! 653: }
! 654: do_test $name.$zName.$iFail [list set {} $res] $str
! 655: set cksum2 [db one $cksumsql]
! 656: if {$cksum1 != $cksum2} return
! 657: }
! 658: }
! 659: }
! 660: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to malloc_common.tcl CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / sqlite3 / test