sl@0: # 2007 May 05
sl@0: #
sl@0: # The author disclaims copyright to this source code.  In place of
sl@0: # a legal notice, here is a blessing:
sl@0: #
sl@0: #    May you do good and not evil.
sl@0: #    May you find forgiveness for yourself and forgive others.
sl@0: #    May you share freely, never taking more than you give.
sl@0: #
sl@0: #***********************************************************************
sl@0: #
sl@0: # This file contains common code used by many different malloc tests
sl@0: # within the test suite.
sl@0: #
sl@0: # $Id: malloc_common.tcl,v 1.22 2008/09/23 16:41:30 danielk1977 Exp $
sl@0: 
sl@0: # If we did not compile with malloc testing enabled, then do nothing.
sl@0: #
sl@0: ifcapable builtin_test {
sl@0:   set MEMDEBUG 1
sl@0: } else {
sl@0:   set MEMDEBUG 0
sl@0:   return 0
sl@0: }
sl@0: 
sl@0: # Usage: do_malloc_test <test number> <options...>
sl@0: #
sl@0: # The first argument, <test number>, is an integer used to name the
sl@0: # tests executed by this proc. Options are as follows:
sl@0: #
sl@0: #     -tclprep          TCL script to run to prepare test.
sl@0: #     -sqlprep          SQL script to run to prepare test.
sl@0: #     -tclbody          TCL script to run with malloc failure simulation.
sl@0: #     -sqlbody          TCL script to run with malloc failure simulation.
sl@0: #     -cleanup          TCL script to run after the test.
sl@0: #
sl@0: # This command runs a series of tests to verify SQLite's ability
sl@0: # to handle an out-of-memory condition gracefully. It is assumed
sl@0: # that if this condition occurs a malloc() call will return a
sl@0: # NULL pointer. Linux, for example, doesn't do that by default. See
sl@0: # the "BUGS" section of malloc(3).
sl@0: #
sl@0: # Each iteration of a loop, the TCL commands in any argument passed
sl@0: # to the -tclbody switch, followed by the SQL commands in any argument
sl@0: # passed to the -sqlbody switch are executed. Each iteration the
sl@0: # Nth call to sqliteMalloc() is made to fail, where N is increased
sl@0: # each time the loop runs starting from 1. When all commands execute
sl@0: # successfully, the loop ends.
sl@0: #
sl@0: proc do_malloc_test {tn args} {
sl@0:   array unset ::mallocopts 
sl@0:   array set ::mallocopts $args
sl@0: 
sl@0:   if {[string is integer $tn]} {
sl@0:     set tn malloc-$tn
sl@0:   }
sl@0:   if {[info exists ::mallocopts(-start)]} {
sl@0:     set start $::mallocopts(-start)
sl@0:   } else {
sl@0:     set start 0
sl@0:   }
sl@0:   if {[info exists ::mallocopts(-end)]} {
sl@0:     set end $::mallocopts(-end)
sl@0:   } else {
sl@0:     set end 50000
sl@0:   }
sl@0:   save_prng_state
sl@0: 
sl@0:   foreach ::iRepeat {0 10000000} {
sl@0:     set ::go 1
sl@0:     for {set ::n $start} {$::go && $::n <= $end} {incr ::n} {
sl@0: 
sl@0:       # If $::iRepeat is 0, then the malloc() failure is transient - it
sl@0:       # fails and then subsequent calls succeed. If $::iRepeat is 1, 
sl@0:       # then the failure is persistent - once malloc() fails it keeps
sl@0:       # failing.
sl@0:       #
sl@0:       set zRepeat "transient"
sl@0:       if {$::iRepeat} {set zRepeat "persistent"}
sl@0:       restore_prng_state
sl@0:       foreach file [glob -nocomplain test.db-mj*] {file delete -force $file}
sl@0: 
sl@0:       do_test ${tn}.${zRepeat}.${::n} {
sl@0:   
sl@0:         # Remove all traces of database files test.db and test2.db 
sl@0:         # from the file-system. Then open (empty database) "test.db" 
sl@0:         # with the handle [db].
sl@0:         # 
sl@0:         catch {db close} 
sl@0:         catch {file delete -force test.db}
sl@0:         catch {file delete -force test.db-journal}
sl@0:         catch {file delete -force test2.db}
sl@0:         catch {file delete -force test2.db-journal}
sl@0:         if {[info exists ::mallocopts(-testdb)]} {
sl@0:           file copy $::mallocopts(-testdb) test.db
sl@0:         }
sl@0:         catch { sqlite3 db test.db }
sl@0:         if {[info commands db] ne ""} {
sl@0:           sqlite3_extended_result_codes db 1
sl@0:         }
sl@0:         sqlite3_db_config_lookaside db 0 0 0
sl@0:   
sl@0:         # Execute any -tclprep and -sqlprep scripts.
sl@0:         #
sl@0:         if {[info exists ::mallocopts(-tclprep)]} {
sl@0:           eval $::mallocopts(-tclprep)
sl@0:         }
sl@0:         if {[info exists ::mallocopts(-sqlprep)]} {
sl@0:           execsql $::mallocopts(-sqlprep)
sl@0:         }
sl@0:   
sl@0:         # Now set the ${::n}th malloc() to fail and execute the -tclbody 
sl@0:         # and -sqlbody scripts.
sl@0:         #
sl@0:         sqlite3_memdebug_fail $::n -repeat $::iRepeat
sl@0:         set ::mallocbody {}
sl@0:         if {[info exists ::mallocopts(-tclbody)]} {
sl@0:           append ::mallocbody "$::mallocopts(-tclbody)\n"
sl@0:         }
sl@0:         if {[info exists ::mallocopts(-sqlbody)]} {
sl@0:           append ::mallocbody "db eval {$::mallocopts(-sqlbody)}"
sl@0:         }
sl@0: 
sl@0:         # The following block sets local variables as follows:
sl@0:         #
sl@0:         #     isFail  - True if an error (any error) was reported by sqlite.
sl@0:         #     nFail   - The total number of simulated malloc() failures.
sl@0:         #     nBenign - The number of benign simulated malloc() failures.
sl@0:         #
sl@0:         set isFail [catch $::mallocbody msg]
sl@0:         set nFail [sqlite3_memdebug_fail -1 -benigncnt nBenign]
sl@0:         # puts -nonewline " (isFail=$isFail nFail=$nFail nBenign=$nBenign) "
sl@0: 
sl@0:         # If one or more mallocs failed, run this loop body again.
sl@0:         #
sl@0:         set go [expr {$nFail>0}]
sl@0: 
sl@0:         if {($nFail-$nBenign)==0} {
sl@0:           if {$isFail} {
sl@0:             set v2 $msg
sl@0:           } else {
sl@0:             set isFail 1
sl@0:             set v2 1
sl@0:           }
sl@0:         } elseif {!$isFail} {
sl@0:           set v2 $msg
sl@0:         } elseif {
sl@0:           [info command db]=="" || 
sl@0:           [db errorcode]==7 ||
sl@0:           $msg=="out of memory"
sl@0:         } {
sl@0:           set v2 1
sl@0:         } else {
sl@0:           set v2 $msg
sl@0:           puts [db errorcode]
sl@0:         }
sl@0:         lappend isFail $v2
sl@0:       } {1 1}
sl@0:   
sl@0:       if {[info exists ::mallocopts(-cleanup)]} {
sl@0:         catch [list uplevel #0 $::mallocopts(-cleanup)] msg
sl@0:       }
sl@0:     }
sl@0:   }
sl@0:   unset ::mallocopts
sl@0:   sqlite3_memdebug_fail -1
sl@0: }