# 2001 September 15 # # 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. # #*********************************************************************** # This file implements some common TCL routines used for regression # testing the SQLite library # # $Id: tester.tcl,v 1.27 2004/02/11 02:18:07 drh Exp $ # Make sure tclsqlite was compiled correctly. Abort now with an # error message if not. # if {[sqlite -tcl-uses-utf]} { if {"\u1234"=="u1234"} { puts stderr "***** BUILD PROBLEM *****" puts stderr "$argv0 was linked against an older version" puts stderr "of TCL that does not support Unicode, but uses a header" puts stderr "file (\"tcl.h\") from a new TCL version that does support" puts stderr "Unicode. This combination causes internal errors." puts stderr "Recompile using a TCL library and header file that match" puts stderr "and try again.\n**************************" exit 1 } } else { if {"\u1234"!="u1234"} { puts stderr "***** BUILD PROBLEM *****" puts stderr "$argv0 was linked against an newer version" puts stderr "of TCL that supports Unicode, but uses a header file" puts stderr "(\"tcl.h\") from a old TCL version that does not support" puts stderr "Unicode. This combination causes internal errors." puts stderr "Recompile using a TCL library and header file that match" puts stderr "and try again.\n**************************" exit 1 } } # Use the pager codec if it is available # if {[sqlite -has-codec] && [info command sqlite_orig]==""} { rename sqlite sqlite_orig proc sqlite {args} { if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} { lappend args -key {xyzzy} } uplevel 1 sqlite_orig $args } } # Create a test database # catch {db close} file delete -force test.db file delete -force test.db-journal sqlite db ./test.db if {[info exists ::SETUP_SQL]} { db eval $::SETUP_SQL } # Abort early if this script has been run before. # if {[info exists nTest]} return # Set the test counters to zero # set nErr 0 set nTest 0 set nProb 0 set skip_test 0 set failList {} # Invoke the do_test procedure to run a single test # proc do_test {name cmd expected} { global argv nErr nTest skip_test if {$skip_test} { set skip_test 0 return } if {[llength $argv]==0} { set go 1 } else { set go 0 foreach pattern $argv { if {[string match $pattern $name]} { set go 1 break } } } if {!$go} return incr nTest puts -nonewline $name... flush stdout if {[catch {uplevel #0 "$cmd;\n"} result]} { puts "\nError: $result" incr nErr lappend ::failList $name if {$nErr>10} {puts "*** Giving up..."; finalize_testing} } elseif {[string compare $result $expected]} { puts "\nExpected: \[$expected\]\n Got: \[$result\]" incr nErr lappend ::failList $name if {$nErr>10} {puts "*** Giving up..."; finalize_testing} } else { puts " Ok" } } # Invoke this procedure on a test that is probabilistic # and might fail sometimes. # proc do_probtest {name cmd expected} { global argv nProb nTest skip_test if {$skip_test} { set skip_test 0 return } if {[llength $argv]==0} { set go 1 } else { set go 0 foreach pattern $argv { if {[string match $pattern $name]} { set go 1 break } } } if {!$go} return incr nTest puts -nonewline $name... flush stdout if {[catch {uplevel #0 "$cmd;\n"} result]} { puts "\nError: $result" incr nErr } elseif {[string compare $result $expected]} { puts "\nExpected: \[$expected\]\n Got: \[$result\]" puts "NOTE: The results of the previous test depend on system load" puts "and processor speed. The test may sometimes fail even if the" puts "library is working correctly." incr nProb } else { puts " Ok" } } # The procedure uses the special "sqlite_malloc_stat" command # (which is only available if SQLite is compiled with -DMEMORY_DEBUG=1) # to see how many malloc()s have not been free()ed. The number # of surplus malloc()s is stored in the global variable $::Leak. # If the value in $::Leak grows, it may mean there is a memory leak # in the library. # proc memleak_check {} { if {[info command sqlite_malloc_stat]!=""} { set r [sqlite_malloc_stat] set ::Leak [expr {[lindex $r 0]-[lindex $r 1]}] } } # Run this routine last # proc finish_test {} { finalize_testing } proc finalize_testing {} { global nTest nErr nProb sqlite_open_file_count if {$nErr==0} memleak_check catch {db close} puts "$nErr errors out of $nTest tests" puts "Failures on these tests: $::failList" if {$nProb>0} { puts "$nProb probabilistic tests also failed, but this does" puts "not necessarily indicate a malfunction." } if {$sqlite_open_file_count} { puts "$sqlite_open_file_count files were left open" incr nErr } exit [expr {$nErr>0}] } # A procedure to execute SQL # proc execsql {sql {db db}} { # puts "SQL = $sql" return [$db eval $sql] } # Execute SQL and catch exceptions. # proc catchsql {sql {db db}} { # puts "SQL = $sql" set r [catch {$db eval $sql} msg] lappend r $msg return $r } # Do an VDBE code dump on the SQL given # proc explain {sql {db db}} { puts "" puts "addr opcode p1 p2 p3 " puts "---- ------------ ------ ------ ---------------" $db eval "explain $sql" {} { puts [format {%-4d %-12.12s %-6d %-6d %s} $addr $opcode $p1 $p2 $p3] } } # Another procedure to execute SQL. This one includes the field # names in the returned list. # proc execsql2 {sql} { set result {} db eval $sql data { foreach f $data(*) { lappend result $f $data($f) } } return $result } # Use the non-callback API to execute multiple SQL statements # proc stepsql {dbptr sql} { set sql [string trim $sql] set r 0 while {[string length $sql]>0} { if {[catch {sqlite_compile $dbptr $sql sqltail} vm]} { return [list 1 $vm] } set sql [string trim $sqltail] while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} { foreach v $VAL {lappend r $v} } if {[catch {sqlite_finalize $vm} errmsg]} { return [list 1 $errmsg] } } return $r } # Delete a file or directory # proc forcedelete {filename} { if {[catch {file delete -force $filename}]} { exec rm -rf $filename } } # Do an integrity check of the entire database # proc integrity_check {name} { do_test $name { execsql {PRAGMA integrity_check} } {ok} }