xref: /sqlite-3.40.0/test/malloc_common.tcl (revision 5665b3ea) 
1
2# Usage: do_malloc_test <test number> <options...>
3#
4# The first argument, <test number>, is an integer used to name the
5# tests executed by this proc. Options are as follows:
6#
7#     -tclprep          TCL script to run to prepare test.
8#     -sqlprep          SQL script to run to prepare test.
9#     -tclbody          TCL script to run with malloc failure simulation.
10#     -sqlbody          TCL script to run with malloc failure simulation.
11#     -cleanup          TCL script to run after the test.
12#
13# This command runs a series of tests to verify SQLite's ability
14# to handle an out-of-memory condition gracefully. It is assumed
15# that if this condition occurs a malloc() call will return a
16# NULL pointer. Linux, for example, doesn't do that by default. See
17# the "BUGS" section of malloc(3).
18#
19# Each iteration of a loop, the TCL commands in any argument passed
20# to the -tclbody switch, followed by the SQL commands in any argument
21# passed to the -sqlbody switch are executed. Each iteration the
22# Nth call to sqliteMalloc() is made to fail, where N is increased
23# each time the loop runs starting from 1. When all commands execute
24# successfully, the loop ends.
25#
26proc do_malloc_test {tn args} {
27  array unset ::mallocopts
28  array set ::mallocopts $args
29
30  if {[string is integer $tn]} {
31    set tn malloc-$tn
32  }
33
34  set ::go 1
35  for {set ::n 1} {$::go && $::n < 50000} {incr ::n} {
36    do_test $tn.$::n {
37
38      # Remove all traces of database files test.db and test2.db from the files
39      # system. Then open (empty database) "test.db" with the handle [db].
40      #
41      sqlite_malloc_fail 0
42      catch {db close}
43      catch {file delete -force test.db}
44      catch {file delete -force test.db-journal}
45      catch {file delete -force test2.db}
46      catch {file delete -force test2.db-journal}
47      catch {sqlite3 db test.db}
48      set ::DB [sqlite3_connection_pointer db]
49
50      # Execute any -tclprep and -sqlprep scripts.
51      #
52      if {[info exists ::mallocopts(-tclprep)]} {
53        eval $::mallocopts(-tclprep)
54      }
55      if {[info exists ::mallocopts(-sqlprep)]} {
56        execsql $::mallocopts(-sqlprep)
57      }
58
59      # Now set the ${::n}th malloc() to fail and execute the -tclbody and
60      # -sqlbody scripts.
61      #
62      sqlite_malloc_fail $::n
63      set ::mallocbody {}
64      if {[info exists ::mallocopts(-tclbody)]} {
65        append ::mallocbody "$::mallocopts(-tclbody)\n"
66      }
67      if {[info exists ::mallocopts(-sqlbody)]} {
68        append ::mallocbody "db eval {$::mallocopts(-sqlbody)}"
69      }
70      set v [catch $::mallocbody msg]
71
72      # If the test fails (if $v!=0) and the database connection actually
73      # exists, make sure the failure code is SQLITE_NOMEM.
74      if {$v && [info command db]=="db" && [info exists ::mallocopts(-sqlbody)]
75              && [db errorcode]!=7} {
76        set v 999
77      }
78
79      set leftover [lindex [sqlite_malloc_stat] 2]
80      if {$leftover>0} {
81        if {$leftover>1} {puts "\nLeftover: $leftover\nReturn=$v  Message=$msg"}
82        set ::go 0
83        if {$v} {
84          puts "\nError message returned: $msg"
85        } else {
86          set v {1 1}
87        }
88      } else {
89        set v2 [expr {$msg=="" || $msg=="out of memory"}]
90        if {!$v2} {puts "\nError message returned: $msg"}
91        lappend v $v2
92      }
93    } {1 1}
94
95    if {[info exists ::mallocopts(-cleanup)]} {
96      catch [list uplevel #0 $::mallocopts(-cleanup)] msg
97    }
98  }
99  unset ::mallocopts
100}
101
102