test/malloc_common.tcl

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