# Copyright (c) 1999, 2000 D. Richard Hipp # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Author contact information: # drh@hwaci.com # http://www.hwaci.com/drh/ # #*********************************************************************** # This file implements some common TCL routines used for regression # testing the SQLite library # # $Id: tester.tcl,v 1.13 2001/04/04 11:48:58 drh Exp $ # Create a test database # if {![info exists dbprefix]} { if {[info exists env(SQLITE_PREFIX)]} { set dbprefix $env(SQLITE_PREFIX): } else { set dbprefix "gdbm:" } } switch $dbprefix { gdbm: { foreach f [glob -nocomplain testdb/*] { catch {file delete -force $f} } if {[catch {file delete -force testdb}]} { exec rm -rf testdb } file mkdir testdb } memory: { # do nothing } } sqlite db ${dbprefix}testdb # 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 # 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 $::dbprefix$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\]" incr nErr } 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 $::dbprefix$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" } } # Skip a test based on the dbprefix # proc skipif {args} { foreach a $args { if {$::dbprefix==$a} { set ::skip_test 1 return } } } # Run the next test only if the dbprefix is among the listed arguments # proc testif {args} { foreach a $args { if {$::dbprefix==$a} { set ::skip_test 0 return } } set ::skip_test 1 } # The procedure uses the special "--malloc-stats--" macro of SQLite # (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 {} { set r [execsql {--malloc-stats--}] if {$r==""} return set ::Leak [expr {[lindex $r 0]-[lindex $r 1]}] # puts "*** $::Leak mallocs have not been freed ***" } # Run this routine last # proc finish_test {} { global nTest nErr nProb memleak_check catch {db close} puts "$nErr errors out of $nTest tests" if {$nProb>0} { puts "$nProb probabilistic tests also failed, but this does" puts "not necessarily indicate a malfunction." } exit [expr {$nErr>0}] } # A procedure to execute SQL # proc execsql {sql {db db}} { # puts "SQL = $sql" return [$db eval $sql] } # 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 } # Delete a file or directory # proc forcedelete {filename} { if {[catch {file delete -force $filename}]} { exec rm -rf $filename } }