xref: /illumos-gate/usr/src/lib/libsqlite/test/tester.tcl (revision 1da57d551424de5a9d469760be7c4b4d4f10a755)
1#
2# 2001 September 15
3#
4# The author disclaims copyright to this source code.  In place of
5# a legal notice, here is a blessing:
6#
7#    May you do good and not evil.
8#    May you find forgiveness for yourself and forgive others.
9#    May you share freely, never taking more than you give.
10#
11#***********************************************************************
12# This file implements some common TCL routines used for regression
13# testing the SQLite library
14#
15# $Id: tester.tcl,v 1.28 2004/02/14 01:39:50 drh Exp $
16
17# Make sure tclsqlite was compiled correctly.  Abort now with an
18# error message if not.
19#
20if {[sqlite -tcl-uses-utf]} {
21  if {"\u1234"=="u1234"} {
22    puts stderr "***** BUILD PROBLEM *****"
23    puts stderr "$argv0 was linked against an older version"
24    puts stderr "of TCL that does not support Unicode, but uses a header"
25    puts stderr "file (\"tcl.h\") from a new TCL version that does support"
26    puts stderr "Unicode.  This combination causes internal errors."
27    puts stderr "Recompile using a TCL library and header file that match"
28    puts stderr "and try again.\n**************************"
29    exit 1
30  }
31} else {
32  if {"\u1234"!="u1234"} {
33    puts stderr "***** BUILD PROBLEM *****"
34    puts stderr "$argv0 was linked against an newer version"
35    puts stderr "of TCL that supports Unicode, but uses a header file"
36    puts stderr "(\"tcl.h\") from a old TCL version that does not support"
37    puts stderr "Unicode.  This combination causes internal errors."
38    puts stderr "Recompile using a TCL library and header file that match"
39    puts stderr "and try again.\n**************************"
40    exit 1
41  }
42}
43
44# Use the pager codec if it is available
45#
46if {[sqlite -has-codec] && [info command sqlite_orig]==""} {
47  rename sqlite sqlite_orig
48  proc sqlite {args} {
49    if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} {
50      lappend args -key {xyzzy}
51    }
52    uplevel 1 sqlite_orig $args
53  }
54}
55
56
57# Create a test database
58#
59catch {db close}
60file delete -force test.db
61file delete -force test.db-journal
62sqlite db ./test.db
63if {[info exists ::SETUP_SQL]} {
64  db eval $::SETUP_SQL
65}
66
67# Abort early if this script has been run before.
68#
69if {[info exists nTest]} return
70
71# Set the test counters to zero
72#
73set nErr 0
74set nTest 0
75set nProb 0
76set skip_test 0
77set failList {}
78
79# Invoke the do_test procedure to run a single test
80#
81proc do_test {name cmd expected} {
82  global argv nErr nTest skip_test
83  if {$skip_test} {
84    set skip_test 0
85    return
86  }
87  if {[llength $argv]==0} {
88    set go 1
89  } else {
90    set go 0
91    foreach pattern $argv {
92      if {[string match $pattern $name]} {
93        set go 1
94        break
95      }
96    }
97  }
98  if {!$go} return
99  incr nTest
100  puts -nonewline $name...
101  flush stdout
102  if {[catch {uplevel #0 "$cmd;\n"} result]} {
103    puts "\nError: $result"
104    incr nErr
105    lappend ::failList $name
106    if {$nErr>100} {puts "*** Giving up..."; finalize_testing}
107  } elseif {[string compare $result $expected]} {
108    puts "\nExpected: \[$expected\]\n     Got: \[$result\]"
109    incr nErr
110    lappend ::failList $name
111    if {$nErr>100} {puts "*** Giving up..."; finalize_testing}
112  } else {
113    puts " Ok"
114  }
115}
116
117# Invoke this procedure on a test that is probabilistic
118# and might fail sometimes.
119#
120proc do_probtest {name cmd expected} {
121  global argv nProb nTest skip_test
122  if {$skip_test} {
123    set skip_test 0
124    return
125  }
126  if {[llength $argv]==0} {
127    set go 1
128  } else {
129    set go 0
130    foreach pattern $argv {
131      if {[string match $pattern $name]} {
132        set go 1
133        break
134      }
135    }
136  }
137  if {!$go} return
138  incr nTest
139  puts -nonewline $name...
140  flush stdout
141  if {[catch {uplevel #0 "$cmd;\n"} result]} {
142    puts "\nError: $result"
143    incr nErr
144  } elseif {[string compare $result $expected]} {
145    puts "\nExpected: \[$expected\]\n     Got: \[$result\]"
146    puts "NOTE: The results of the previous test depend on system load"
147    puts "and processor speed.  The test may sometimes fail even if the"
148    puts "library is working correctly."
149    incr nProb
150  } else {
151    puts " Ok"
152  }
153}
154
155# The procedure uses the special "sqlite_malloc_stat" command
156# (which is only available if SQLite is compiled with -DMEMORY_DEBUG=1)
157# to see how many malloc()s have not been free()ed.  The number
158# of surplus malloc()s is stored in the global variable $::Leak.
159# If the value in $::Leak grows, it may mean there is a memory leak
160# in the library.
161#
162proc memleak_check {} {
163  if {[info command sqlite_malloc_stat]!=""} {
164    set r [sqlite_malloc_stat]
165    set ::Leak [expr {[lindex $r 0]-[lindex $r 1]}]
166  }
167}
168
169# Run this routine last
170#
171proc finish_test {} {
172  finalize_testing
173}
174proc finalize_testing {} {
175  global nTest nErr nProb sqlite_open_file_count
176  if {$nErr==0} memleak_check
177  catch {db close}
178  puts "$nErr errors out of $nTest tests"
179  puts "Failures on these tests: $::failList"
180  if {$nProb>0} {
181    puts "$nProb probabilistic tests also failed, but this does"
182    puts "not necessarily indicate a malfunction."
183  }
184  if {$sqlite_open_file_count} {
185    puts "$sqlite_open_file_count files were left open"
186    incr nErr
187  }
188  exit [expr {$nErr>0}]
189}
190
191# A procedure to execute SQL
192#
193proc execsql {sql {db db}} {
194  # puts "SQL = $sql"
195  return [$db eval $sql]
196}
197
198# Execute SQL and catch exceptions.
199#
200proc catchsql {sql {db db}} {
201  # puts "SQL = $sql"
202  set r [catch {$db eval $sql} msg]
203  lappend r $msg
204  return $r
205}
206
207# Do an VDBE code dump on the SQL given
208#
209proc explain {sql {db db}} {
210  puts ""
211  puts "addr  opcode        p1       p2     p3             "
212  puts "----  ------------  ------  ------  ---------------"
213  $db eval "explain $sql" {} {
214    puts [format {%-4d  %-12.12s  %-6d  %-6d  %s} $addr $opcode $p1 $p2 $p3]
215  }
216}
217
218# Another procedure to execute SQL.  This one includes the field
219# names in the returned list.
220#
221proc execsql2 {sql} {
222  set result {}
223  db eval $sql data {
224    foreach f $data(*) {
225      lappend result $f $data($f)
226    }
227  }
228  return $result
229}
230
231# Use the non-callback API to execute multiple SQL statements
232#
233proc stepsql {dbptr sql} {
234  set sql [string trim $sql]
235  set r 0
236  while {[string length $sql]>0} {
237    if {[catch {sqlite_compile $dbptr $sql sqltail} vm]} {
238      return [list 1 $vm]
239    }
240    set sql [string trim $sqltail]
241    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
242      foreach v $VAL {lappend r $v}
243    }
244    if {[catch {sqlite_finalize $vm} errmsg]} {
245      return [list 1 $errmsg]
246    }
247  }
248  return $r
249}
250
251# Delete a file or directory
252#
253proc forcedelete {filename} {
254  if {[catch {file delete -force $filename}]} {
255    exec rm -rf $filename
256  }
257}
258
259# Do an integrity check of the entire database
260#
261proc integrity_check {name} {
262  do_test $name {
263    execsql {PRAGMA integrity_check}
264  } {ok}
265}
266