3 # The author disclaims copyright to this source code. In place of
4 # a legal notice, here is a blessing:
6 # May you do good and not evil.
7 # May you find forgiveness for yourself and forgive others.
8 # May you share freely, never taking more than you give.
10 #***********************************************************************
11 # This file implements some common TCL routines used for regression
12 # testing the SQLite library
14 # $Id: tester.tcl,v 1.49 2005/05/26 15:20:53 danielk1977 Exp $
16 # Make sure tclsqlite3 was compiled correctly. Abort now with an
17 # error message if not.
19 if {[sqlite3
-tcl-uses
-utf
]} {
20 if {"\u1234"=="u1234"} {
21 puts stderr
"***** BUILD PROBLEM *****"
22 puts stderr
"$argv0 was linked against an older version"
23 puts stderr
"of TCL that does not support Unicode, but uses a header"
24 puts stderr
"file (\"tcl.h\") from a new TCL version that does support"
25 puts stderr
"Unicode. This combination causes internal errors."
26 puts stderr
"Recompile using a TCL library and header file that match"
27 puts stderr
"and try again.\n**************************"
31 if {"\u1234"!="u1234"} {
32 puts stderr
"***** BUILD PROBLEM *****"
33 puts stderr
"$argv0 was linked against an newer version"
34 puts stderr
"of TCL that supports Unicode, but uses a header file"
35 puts stderr
"(\"tcl.h\") from a old TCL version that does not support"
36 puts stderr
"Unicode. This combination causes internal errors."
37 puts stderr
"Recompile using a TCL library and header file that match"
38 puts stderr
"and try again.\n**************************"
45 # Use the pager codec if it is available
47 if {[sqlite3
-has-codec
] && [info command sqlite_orig
]==""} {
48 rename sqlite3 sqlite_orig
50 if {[llength $args]==2 && [string index
[lindex $args 0] 0]!="-"} {
51 lappend args
-key {xyzzy
}
53 uplevel 1 sqlite_orig
$args
58 # Create a test database
61 file delete
-force test.db
62 file delete
-force test.db-journal
63 set ::DB [sqlite3 db .
/test.db
]
64 if {[info exists
::SETUP_SQL]} {
68 # Abort early if this script has been run before.
70 if {[info exists nTest
]} return
72 # Set the test counters to zero
81 # Invoke the do_test procedure to run a single test
83 proc do_test
{name cmd expected
} {
84 global argv nErr nTest skip_test maxErr
89 if {[llength $argv]==0} {
93 foreach pattern
$argv {
94 if {[string match
$pattern $name]} {
102 puts -nonewline $name...
104 if {[catch {uplevel #0 "$cmd;\n"} result]} {
105 puts "\nError: $result"
107 lappend ::failList $name
108 if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing
}
109 } elseif
{[string compare
$result $expected]} {
110 puts "\nExpected: \[$expected\]\n Got: \[$result\]"
112 lappend ::failList $name
113 if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing
}
119 # The procedure uses the special "sqlite_malloc_stat" command
120 # (which is only available if SQLite is compiled with -DSQLITE_DEBUG=1)
121 # to see how many malloc()s have not been free()ed. The number
122 # of surplus malloc()s is stored in the global variable $::Leak.
123 # If the value in $::Leak grows, it may mean there is a memory leak
126 proc memleak_check
{} {
127 if {[info command sqlite_malloc_stat
]!=""} {
128 set r
[sqlite_malloc_stat
]
129 set ::Leak [expr {[lindex $r 0]-[lindex $r 1]}]
133 # Run this routine last
135 proc finish_test
{} {
138 proc finalize_testing
{} {
139 global nTest nErr nProb sqlite_open_file_count
140 if {$nErr==0} memleak_check
142 puts "$nErr errors out of $nTest tests"
143 puts "Failures on these tests: $::failList"
145 puts "$nProb probabilistic tests also failed, but this does"
146 puts "not necessarily indicate a malfunction."
149 if {$sqlite_open_file_count} {
150 puts "$sqlite_open_file_count files were left open"
154 exit [expr {$nErr>0}]
157 # A procedure to execute SQL
159 proc execsql
{sql
{db db
}} {
161 return [$db eval $sql]
164 # Execute SQL and catch exceptions.
166 proc catchsql
{sql
{db db
}} {
168 set r
[catch {$db eval $sql} msg
]
173 # Do an VDBE code dump on the SQL given
175 proc explain
{sql
{db db
}} {
177 puts "addr opcode p1 p2 p3 "
178 puts "---- ------------ ------ ------ ---------------"
179 $db eval "explain $sql" {} {
180 puts [format {%-4d %-12.12s
%-6d %-6d %s
} $addr $opcode $p1 $p2 $p3]
184 # Another procedure to execute SQL. This one includes the field
185 # names in the returned list.
187 proc execsql2
{sql
} {
191 lappend result
$f $data($f)
197 # Use the non-callback API to execute multiple SQL statements
199 proc stepsql
{dbptr sql
} {
200 set sql
[string trim
$sql]
202 while {[string length
$sql]>0} {
203 if {[catch {sqlite3_prepare
$dbptr $sql -1 sqltail
} vm
]} {
206 set sql
[string trim
$sqltail]
207 # while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
208 # foreach v $VAL {lappend r $v}
210 while {[sqlite3_step
$vm]=="SQLITE_ROW"} {
211 for {set i
0} {$i<[sqlite3_data_count
$vm]} {incr i
} {
212 lappend r
[sqlite3_column_text
$vm $i]
215 if {[catch {sqlite3_finalize
$vm} errmsg
]} {
216 return [list 1 $errmsg]
222 # Delete a file or directory
224 proc forcedelete
{filename} {
225 if {[catch {file delete
-force $filename}]} {
226 exec rm
-rf $filename
230 # Do an integrity check of the entire database
232 proc integrity_check
{name
} {
233 ifcapable integrityck
{
235 execsql
{PRAGMA integrity_check
}
240 # Evaluate a boolean expression of capabilities. If true, execute the
241 # code. Omit the code if false.
243 proc ifcapable
{expr code
{else ""} {elsecode
""}} {
244 regsub -all {[a-z_0-9
]+} $expr {$::sqlite_options(&)} e2
246 set c
[catch {uplevel 1 $code} r
]
248 set c
[catch {uplevel 1 $elsecode} r
]
253 # This proc execs a seperate process that crashes midway through executing
254 # the SQL script $sql on database test.db.
256 # The crash occurs during a sync() of file $crashfile. When the crash
257 # occurs a random subset of all unsynced writes made by the process are
258 # written into the files on disk. Argument $crashdelay indicates the
259 # number of file syncs to wait before crashing.
261 # The return value is a list of two elements. The first element is a
262 # boolean, indicating whether or not the process actually crashed or
263 # reported some other error. The second element in the returned list is the
264 # error message. This is "child process exited abnormally" if the crash
267 proc crashsql
{crashdelay crashfile sql
} {
268 if {$::tcl_platform(platform
)!="unix"} {
269 error "crashsql should only be used on unix"
271 set cfile
[file join [pwd] $crashfile]
273 set f
[open crash.tcl w
]
274 puts $f "sqlite3_crashparams $crashdelay $cfile"
275 puts $f "sqlite3 db test.db"
276 puts $f "db eval {pragma cache_size = 10}"
283 exec [file join . crashtest
] crash.tcl
>@stdout
288 # Usage: do_ioerr_test <test number> <options...>
290 # This proc is used to implement test cases that check that IO errors
291 # are correctly handled. The first argument, <test number>, is an integer
292 # used to name the tests executed by this proc. Options are as follows:
294 # -tclprep TCL script to run to prepare test.
295 # -sqlprep SQL script to run to prepare test.
296 # -tclbody TCL script to run with IO error simulation.
297 # -sqlbody TCL script to run with IO error simulation.
298 # -exclude List of 'N' values not to test.
299 # -start Value of 'N' to begin with (default 1)
301 # -cksum Boolean. If true, test that the database does
302 # not change during the execution of the test case.
304 proc do_ioerr_test
{testname args
} {
306 set ::ioerropts(-start) 1
307 set ::ioerropts(-cksum) 0
309 array set ::ioerropts $args
312 for {set n
$::ioerropts(-start)} {$::go} {incr n
} {
314 # Skip this IO error if it was specified with the "-exclude" option.
315 if {[info exists
::ioerropts(-exclude)]} {
316 if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
319 # Delete the files test.db and test2.db, then execute the TCL and
320 # SQL (in that order) to prepare for the test case.
321 do_test
$testname.
$n.1 {
322 set ::sqlite_io_error_pending 0
324 catch {file delete
-force test.db
}
325 catch {file delete
-force test.db-journal
}
326 catch {file delete
-force test2.db
}
327 catch {file delete
-force test2.db-journal
}
328 set ::DB [sqlite3 db test.db
]
329 if {[info exists
::ioerropts(-tclprep)]} {
330 eval $::ioerropts(-tclprep)
332 if {[info exists
::ioerropts(-sqlprep)]} {
333 execsql
$::ioerropts(-sqlprep)
338 # Read the 'checksum' of the database.
339 if {$::ioerropts(-cksum)} {
343 # Set the Nth IO error to fail.
344 do_test
$testname.
$n.2 [subst {
345 set ::sqlite_io_error_pending $n
348 # Create a single TCL script from the TCL and SQL specified
349 # as the body of the test.
351 if {[info exists
::ioerropts(-tclbody)]} {
352 append ::ioerrorbody "$::ioerropts(-tclbody)\n"
354 if {[info exists
::ioerropts(-sqlbody)]} {
355 append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
358 # Execute the TCL Script created in the above block. If
359 # there are at least N IO operations performed by SQLite as
360 # a result of the script, the Nth will fail.
361 do_test
$testname.
$n.3 {
362 set r
[catch $::ioerrorbody msg
]
363 set ::go [expr {$::sqlite_io_error_pending<=0}]
364 set s
[expr $::sqlite_io_error_pending>0]
365 # puts "$::sqlite_io_error_pending $r $msg"
366 expr { ($s && !$r) ||
(!$s && $r) }
367 # expr {$::sqlite_io_error_pending>0 || $r!=0}
370 # If an IO error occured, then the checksum of the database should
371 # be the same as before the script that caused the IO error was run.
372 if {$::go && $::ioerropts(-cksum)} {
373 do_test
$testname.
$n.4 {
375 set ::DB [sqlite3 db test.db
]
380 if {[info exists
::ioerropts(-cleanup)]} {
381 catch $::ioerropts(-cleanup)
384 set ::sqlite_io_error_pending 0
388 # Return a checksum based on the contents of database 'db'.
390 proc cksum
{{db db
}} {
392 SELECT name
, type
, sql FROM sqlite_master order by name
394 foreach tbl
[$db eval {
395 SELECT name FROM sqlite_master WHERE type
='table' order by name
397 append txt
[$db eval "SELECT * FROM $tbl"]\n
399 foreach prag
{default_synchronous default_cache_size
} {
400 append txt
$prag-[$db eval "PRAGMA $prag"]\n
402 set cksum
[string length
$txt]-[md5
$txt]
403 # puts $cksum-[file size test.db]
407 # Copy file $from into $to. This is used because some versions of
408 # TCL for windows (notably the 8.4.1 binary package shipped with the
409 # current mingw release) have a broken "file copy" command.
411 proc copy_file
{from to
} {
412 if {$::tcl_platform(platform
)=="unix"} {
413 file copy
-force $from $to
416 fconfigure $f -translation binary
418 fconfigure $t -translation binary
419 puts -nonewline $t [read $f [file size
$from]]
425 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
426 # to non-zero, then set the global variable $AUTOVACUUM to 1.
427 set AUTOVACUUM
$sqlite_options(default_autovacuum
)