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