Import SQLite 3.8.7.4.

third_party/sqlite/src/test/malloc_common.tcl

 # 2007 May 05
 #
 # The author disclaims copyright to this source code.  In place of
 # a legal notice, here is a blessing:
 #
 #    May you do good and not evil.
 #    May you find forgiveness for yourself and forgive others.
 #    May you share freely, never taking more than you give.
 #
 #***********************************************************************
@@ skipping 75 matching lines @@
   -injectuninstall cantopen_injectuninstall  \
 ]
 set FAULTSIM(cantopen-persistent) [list      \
   -injectinstall   cantopen_injectinstall    \
   -injectstart     {cantopen_injectstart 1}  \
   -injectstop      cantopen_injectstop       \
   -injecterrlist   {{1 {unable to open database file}}}  \
   -injectuninstall cantopen_injectuninstall  \
 ]
 
+set FAULTSIM(interrupt) [list                 \
+  -injectinstall   interrupt_injectinstall    \
+  -injectstart     interrupt_injectstart      \
+  -injectstop      interrupt_injectstop       \
+  -injecterrlist   {{1 interrupted} {1 interrupt}}        \
+  -injectuninstall interrupt_injectuninstall  \
+]
+
 
 
 #--------------------------------------------------------------------------
 # Usage do_faultsim_test NAME ?OPTIONS...? 
 #
 #     -faults           List of fault types to simulate.
 #
 #     -prep             Script to execute before -body.
 #
 #     -body             Script to execute (with fault injection).
 #
 #     -test             Script to execute after -body.
 #
 #     -install          Script to execute after faultsim -injectinstall
 #
 #     -uninstall        Script to execute after faultsim -uninjectinstall
 #
 proc do_faultsim_test {name args} {
   global FAULTSIM
   
-  set DEFAULT(-faults)        [array names FAULTSIM]
+  foreach n [array names FAULTSIM] {
+    if {$n != "interrupt"} {lappend DEFAULT(-faults) $n}
+  }
   set DEFAULT(-prep)          ""
   set DEFAULT(-body)          ""
   set DEFAULT(-test)          ""
   set DEFAULT(-install)       ""
   set DEFAULT(-uninstall)     ""
 
   fix_testname name
 
   array set O [array get DEFAULT]
   array set O $args
@@ skipping 121 matching lines @@
   catch {db2 close}
   shmfault delete
 }
 proc cantopen_injectstart {persist iFail} {
   shmfault cantopen $iFail $persist
 }
 proc cantopen_injectstop {} {
   shmfault cantopen
 }
 
+# The following procs are used as [do_one_faultsim_test] callbacks 
+# when injecting SQLITE_INTERRUPT error faults into test cases.
+#
+proc interrupt_injectinstall {} {
+}
+proc interrupt_injectuninstall {} {
+}
+proc interrupt_injectstart {iFail} {
+  set ::sqlite_interrupt_count $iFail
+}
+proc interrupt_injectstop {} {
+  set res [expr $::sqlite_interrupt_count<=0]
+  set ::sqlite_interrupt_count 0
+  set res
+}
+
 # This command is not called directly. It is used by the 
 # [faultsim_test_result] command created by [do_faultsim_test] and used
 # by -test scripts.
 #
 proc faultsim_test_result_int {args} {
   upvar testrc testrc testresult testresult testnfail testnfail
   set t [list $testrc $testresult]
   set r $args
   if { ($testnfail==0 && $t != [lindex $r 0]) || [lsearch $r $t]<0 } {
-    error "nfail=$testnfail rc=$testrc result=$testresult"
+    error "nfail=$testnfail rc=$testrc result=$testresult list=$r"
   }
 }
 
 #--------------------------------------------------------------------------
 # Usage do_one_faultsim_test NAME ?OPTIONS...? 
 #
 # The first argument, <test number>, is used as a prefix of the test names
 # taken by tests executed by this command. Options are as follows. All
 # options take a single argument.
 #
@@ skipping 98 matching lines @@
 # Nth call to sqliteMalloc() is made to fail, where N is increased
 # each time the loop runs starting from 1. When all commands execute
 # successfully, the loop ends.
 #
 proc do_malloc_test {tn args} {
   array unset ::mallocopts 
   array set ::mallocopts $args
 
   if {[string is integer $tn]} {
     set tn malloc-$tn
+    catch { set tn $::testprefix-$tn }
   }
   if {[info exists ::mallocopts(-start)]} {
     set start $::mallocopts(-start)
   } else {
     set start 0
   }
   if {[info exists ::mallocopts(-end)]} {
     set end $::mallocopts(-end)
   } else {
     set end 50000
   }
   save_prng_state
 
   foreach ::iRepeat {0 10000000} {
     set ::go 1
     for {set ::n $start} {$::go && $::n <= $end} {incr ::n} {
 
       # If $::iRepeat is 0, then the malloc() failure is transient - it
       # fails and then subsequent calls succeed. If $::iRepeat is 1, 
       # then the failure is persistent - once malloc() fails it keeps
       # failing.
       #
       set zRepeat "transient"
       if {$::iRepeat} {set zRepeat "persistent"}
       restore_prng_state
-      foreach file [glob -nocomplain test.db-mj*] {file delete -force $file}
+      foreach file [glob -nocomplain test.db-mj*] {forcedelete $file}
 
       do_test ${tn}.${zRepeat}.${::n} {
   
         # Remove all traces of database files test.db and test2.db 
         # from the file-system. Then open (empty database) "test.db" 
         # with the handle [db].
         # 
         catch {db close} 
         catch {db2 close} 
         forcedelete test.db
         forcedelete test.db-journal
         forcedelete test.db-wal
         forcedelete test2.db
         forcedelete test2.db-journal
         forcedelete test2.db-wal
         if {[info exists ::mallocopts(-testdb)]} {
-          file copy $::mallocopts(-testdb) test.db
+          copy_file $::mallocopts(-testdb) test.db
         }
         catch { sqlite3 db test.db }
         if {[info commands db] ne ""} {
           sqlite3_extended_result_codes db 1
         }
         sqlite3_db_config_lookaside db 0 0 0
   
         # Execute any -tclprep and -sqlprep scripts.
         #
         if {[info exists ::mallocopts(-tclprep)]} {
@@ skipping 212 matching lines @@
         if {[lsearch $answers $res]>=0} {
           set res $str
         }
         do_test $name.$zName.$iFail [list set {} $res] $str
         set cksum2 [db one $cksumsql]
         if {$cksum1 != $cksum2} return
       }
     }
   }
 }