SQLite

#--------------------------------------------------------------------------


# These procs are used to build up a "program" in global variable
# ::run_test_script. At the end of this file, the proc [run_test] is used
# to execute the program (and all test cases contained therein).
#
set ::run_test_sql_id 0
set ::run_test_script [list]
proc TEST {id t} {lappend ::run_test_script -test [list $id $t]}
proc PREP {p} {lappend ::run_test_script -prep [string trim $p]}
proc DEBUG {s} {lappend ::run_test_script -debug $s}

# SQL --
#
#     SQL ?-norollback? <sql-text>
#
# Add an 'SQL' primitive to the program (see notes above). If the -norollback
# switch is present, then the statement is not allowed to automatically roll
# back any active transaction if malloc() fails. It must rollback the statement
# transaction only.
#
proc SQL  {a1 {a2 ""}} {
  # An SQL primitive parameter is a list of three elements, an id, a boolean
  # value indicating if the statement may cause transaction rollback when
  # malloc() fails, and the sql statement itself.
  set id [incr ::run_test_sql_id]
  if {$a2 == ""} {
    lappend ::run_test_script -sql [list $id true [string trim $a1]]
  } else {
    lappend ::run_test_script -sql [list $id false [string trim $a2]]
  }
}

# TEST_AUTOCOMMIT --
# 
#     A shorthand test to see if a transaction is active or not. The first
#     argument - $id - is the integer number of the test case. The second

    }
  } {abc abc abc_i abc abc_t abc abc_v abc_v 1 2 3}
}

set sql {
  BEGIN;DELETE FROM abc;
}
for {set i 1} {$i < 100} {incr i} {
  set a $i
  set b "String value $i"
  set c [string repeat X $i]
  append sql "INSERT INTO abc VALUES ($a, '$b', '$c');"
}
append sql {COMMIT;}
PREP $sql

proc run_test {arglist iRepeat {pcstart 0} {iFailStart 1}} {
  if {[llength $arglist] %2} {
    error "Uneven number of arguments to TEST"
  }

  for {set i 0} {$i < $pcstart} {incr i} {
    set k2 [lindex $arglist [expr {2 * $i}]]
    set v2 [lindex $arglist [expr {2 * $i + 1}]]
    set ac [sqlite3_get_autocommit $::DB]        ;# Auto-Commit
    switch -- $k2 {
      -sql  {db eval [lindex $v2 2]}
      -prep {db eval $v2}
      -debug {eval $v2}
    }
    set nac [sqlite3_get_autocommit $::DB]       ;# New Auto-Commit 
    if {$ac && !$nac} {set begin_pc $i}
  }

  db rollback_hook [list incr ::rollback_hook_count]

  set iFail $iFailStart
  set pc $pcstart
  while {$pc*2 < [llength $arglist]} {
    # Fetch the current instruction type and payload.
    set k [lindex $arglist [expr {2 * $pc}]]
    set v [lindex $arglist [expr {2 * $pc + 1}]]

    # Id of this iteration:

    set iterid "pc=$pc.iFail=$iFail$k"


    switch -- $k {

      -test { 
        foreach {id script} $v {}
        set testid "malloc3-(test $id).$iterid"
        eval $script
        incr pc
      }

      -sql {
        set ::rollback_hook_count 0

        set id [lindex $v 0]
        set testid "malloc3-(integrity $id).$iterid"

        set ac [sqlite3_get_autocommit $::DB]        ;# Auto-Commit
        sqlite3_memdebug_fail $iFail -repeat 0
        set rc [catch {db eval [lindex $v 2]} msg]   ;# True error occurs
        set nac [sqlite3_get_autocommit $::DB]       ;# New Auto-Commit 

        if {$rc != 0 && $nac && !$ac} {
          # Before [db eval] the auto-commit flag was clear. Now it
          # is set. Since an error occured we assume this was not a
          # commit - therefore a rollback occured. Check that the
          # rollback-hook was invoked.
          do_test malloc3-rollback_hook_count.$iterid {
            set ::rollback_hook_count
          } {1}
        }

        set nFail [sqlite3_memdebug_fail -1 -benigncnt nBenign]
        if {$rc == 0} {
            # Successful execution of sql. The number of failed malloc()
            # calls should be equal to the number of benign failures.
            # Otherwise a malloc() failed and the error was not reported.
            # 
            set expr {$nFail!=$nBenign}
            if {[expr $expr]} {
              error "Unreported malloc() failure, test \"$testid\", $expr"
            }

            if {$ac && !$nac} {
              # Before the [db eval] the auto-commit flag was set, now it
              # is clear. We can deduce that a "BEGIN" statement has just
              # been successfully executed.
              set begin_pc $pc
            } 

            incr pc
            set iFail 1
            integrity_check $testid
        } elseif {[regexp {.*out of memory} $msg] || [db errorcode] == 3082} {
            # Out of memory error, as expected.
            #
            integrity_check $testid
            incr iFail
            if {$nac && !$ac} {

              if {![lindex $v 1] && [db errorcode] != 3082} {
                # error "Statement \"[lindex $v 2]\" caused a rollback"
              }

              for {set i $begin_pc} {$i < $pc} {incr i} {
                set k2 [lindex $arglist [expr {2 * $i}]]
                set v2 [lindex $arglist [expr {2 * $i + 1}]]
                set catchupsql ""
                switch -- $k2 {
                  -sql  {set catchupsql [lindex $v2 2]}
                  -prep {set catchupsql $v2}
                }
                db eval $catchupsql
              }
            }
        } else {
            error $msg
        }

        # back up to the previous "-test" block.
        while {[lindex $arglist [expr {2 * ($pc - 1)}]] == "-test"} {
          incr pc -1
        }
      }

      -prep {
        db eval $v
        incr pc
      }

      -debug {
        eval $v
        incr pc
      }

      default { error "Unknown switch: $k" }
    }
  }
}

# Turn off the Tcl interface's prepared statement caching facility. Then
# run the tests with "persistent" malloc failures.
sqlite3_extended_result_codes db 1
db cache size 0
run_test $::run_test_script 1

# Close and reopen the db.
db close