1*1da57d55SToomas Soome# 27c478bd9Sstevel@tonic-gate# 2001 September 15 37c478bd9Sstevel@tonic-gate# 47c478bd9Sstevel@tonic-gate# The author disclaims copyright to this source code. In place of 57c478bd9Sstevel@tonic-gate# a legal notice, here is a blessing: 67c478bd9Sstevel@tonic-gate# 77c478bd9Sstevel@tonic-gate# May you do good and not evil. 87c478bd9Sstevel@tonic-gate# May you find forgiveness for yourself and forgive others. 97c478bd9Sstevel@tonic-gate# May you share freely, never taking more than you give. 107c478bd9Sstevel@tonic-gate# 117c478bd9Sstevel@tonic-gate#*********************************************************************** 127c478bd9Sstevel@tonic-gate# This file implements some common TCL routines used for regression 137c478bd9Sstevel@tonic-gate# testing the SQLite library 147c478bd9Sstevel@tonic-gate# 157c478bd9Sstevel@tonic-gate# $Id: tester.tcl,v 1.28 2004/02/14 01:39:50 drh Exp $ 167c478bd9Sstevel@tonic-gate 177c478bd9Sstevel@tonic-gate# Make sure tclsqlite was compiled correctly. Abort now with an 187c478bd9Sstevel@tonic-gate# error message if not. 197c478bd9Sstevel@tonic-gate# 207c478bd9Sstevel@tonic-gateif {[sqlite -tcl-uses-utf]} { 217c478bd9Sstevel@tonic-gate if {"\u1234"=="u1234"} { 227c478bd9Sstevel@tonic-gate puts stderr "***** BUILD PROBLEM *****" 237c478bd9Sstevel@tonic-gate puts stderr "$argv0 was linked against an older version" 247c478bd9Sstevel@tonic-gate puts stderr "of TCL that does not support Unicode, but uses a header" 257c478bd9Sstevel@tonic-gate puts stderr "file (\"tcl.h\") from a new TCL version that does support" 267c478bd9Sstevel@tonic-gate puts stderr "Unicode. This combination causes internal errors." 277c478bd9Sstevel@tonic-gate puts stderr "Recompile using a TCL library and header file that match" 287c478bd9Sstevel@tonic-gate puts stderr "and try again.\n**************************" 297c478bd9Sstevel@tonic-gate exit 1 307c478bd9Sstevel@tonic-gate } 317c478bd9Sstevel@tonic-gate} else { 327c478bd9Sstevel@tonic-gate if {"\u1234"!="u1234"} { 337c478bd9Sstevel@tonic-gate puts stderr "***** BUILD PROBLEM *****" 347c478bd9Sstevel@tonic-gate puts stderr "$argv0 was linked against an newer version" 357c478bd9Sstevel@tonic-gate puts stderr "of TCL that supports Unicode, but uses a header file" 367c478bd9Sstevel@tonic-gate puts stderr "(\"tcl.h\") from a old TCL version that does not support" 377c478bd9Sstevel@tonic-gate puts stderr "Unicode. This combination causes internal errors." 387c478bd9Sstevel@tonic-gate puts stderr "Recompile using a TCL library and header file that match" 397c478bd9Sstevel@tonic-gate puts stderr "and try again.\n**************************" 407c478bd9Sstevel@tonic-gate exit 1 417c478bd9Sstevel@tonic-gate } 427c478bd9Sstevel@tonic-gate} 437c478bd9Sstevel@tonic-gate 447c478bd9Sstevel@tonic-gate# Use the pager codec if it is available 457c478bd9Sstevel@tonic-gate# 467c478bd9Sstevel@tonic-gateif {[sqlite -has-codec] && [info command sqlite_orig]==""} { 477c478bd9Sstevel@tonic-gate rename sqlite sqlite_orig 487c478bd9Sstevel@tonic-gate proc sqlite {args} { 497c478bd9Sstevel@tonic-gate if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} { 507c478bd9Sstevel@tonic-gate lappend args -key {xyzzy} 517c478bd9Sstevel@tonic-gate } 527c478bd9Sstevel@tonic-gate uplevel 1 sqlite_orig $args 537c478bd9Sstevel@tonic-gate } 547c478bd9Sstevel@tonic-gate} 557c478bd9Sstevel@tonic-gate 567c478bd9Sstevel@tonic-gate 577c478bd9Sstevel@tonic-gate# Create a test database 587c478bd9Sstevel@tonic-gate# 597c478bd9Sstevel@tonic-gatecatch {db close} 607c478bd9Sstevel@tonic-gatefile delete -force test.db 617c478bd9Sstevel@tonic-gatefile delete -force test.db-journal 627c478bd9Sstevel@tonic-gatesqlite db ./test.db 637c478bd9Sstevel@tonic-gateif {[info exists ::SETUP_SQL]} { 647c478bd9Sstevel@tonic-gate db eval $::SETUP_SQL 657c478bd9Sstevel@tonic-gate} 667c478bd9Sstevel@tonic-gate 677c478bd9Sstevel@tonic-gate# Abort early if this script has been run before. 687c478bd9Sstevel@tonic-gate# 697c478bd9Sstevel@tonic-gateif {[info exists nTest]} return 707c478bd9Sstevel@tonic-gate 717c478bd9Sstevel@tonic-gate# Set the test counters to zero 727c478bd9Sstevel@tonic-gate# 737c478bd9Sstevel@tonic-gateset nErr 0 747c478bd9Sstevel@tonic-gateset nTest 0 757c478bd9Sstevel@tonic-gateset nProb 0 767c478bd9Sstevel@tonic-gateset skip_test 0 777c478bd9Sstevel@tonic-gateset failList {} 787c478bd9Sstevel@tonic-gate 79*1da57d55SToomas Soome# Invoke the do_test procedure to run a single test 807c478bd9Sstevel@tonic-gate# 817c478bd9Sstevel@tonic-gateproc do_test {name cmd expected} { 827c478bd9Sstevel@tonic-gate global argv nErr nTest skip_test 837c478bd9Sstevel@tonic-gate if {$skip_test} { 847c478bd9Sstevel@tonic-gate set skip_test 0 857c478bd9Sstevel@tonic-gate return 867c478bd9Sstevel@tonic-gate } 87*1da57d55SToomas Soome if {[llength $argv]==0} { 887c478bd9Sstevel@tonic-gate set go 1 897c478bd9Sstevel@tonic-gate } else { 907c478bd9Sstevel@tonic-gate set go 0 917c478bd9Sstevel@tonic-gate foreach pattern $argv { 927c478bd9Sstevel@tonic-gate if {[string match $pattern $name]} { 937c478bd9Sstevel@tonic-gate set go 1 947c478bd9Sstevel@tonic-gate break 957c478bd9Sstevel@tonic-gate } 967c478bd9Sstevel@tonic-gate } 977c478bd9Sstevel@tonic-gate } 987c478bd9Sstevel@tonic-gate if {!$go} return 997c478bd9Sstevel@tonic-gate incr nTest 1007c478bd9Sstevel@tonic-gate puts -nonewline $name... 1017c478bd9Sstevel@tonic-gate flush stdout 1027c478bd9Sstevel@tonic-gate if {[catch {uplevel #0 "$cmd;\n"} result]} { 1037c478bd9Sstevel@tonic-gate puts "\nError: $result" 1047c478bd9Sstevel@tonic-gate incr nErr 1057c478bd9Sstevel@tonic-gate lappend ::failList $name 1067c478bd9Sstevel@tonic-gate if {$nErr>100} {puts "*** Giving up..."; finalize_testing} 1077c478bd9Sstevel@tonic-gate } elseif {[string compare $result $expected]} { 1087c478bd9Sstevel@tonic-gate puts "\nExpected: \[$expected\]\n Got: \[$result\]" 1097c478bd9Sstevel@tonic-gate incr nErr 1107c478bd9Sstevel@tonic-gate lappend ::failList $name 1117c478bd9Sstevel@tonic-gate if {$nErr>100} {puts "*** Giving up..."; finalize_testing} 1127c478bd9Sstevel@tonic-gate } else { 1137c478bd9Sstevel@tonic-gate puts " Ok" 1147c478bd9Sstevel@tonic-gate } 1157c478bd9Sstevel@tonic-gate} 1167c478bd9Sstevel@tonic-gate 1177c478bd9Sstevel@tonic-gate# Invoke this procedure on a test that is probabilistic 1187c478bd9Sstevel@tonic-gate# and might fail sometimes. 1197c478bd9Sstevel@tonic-gate# 1207c478bd9Sstevel@tonic-gateproc do_probtest {name cmd expected} { 1217c478bd9Sstevel@tonic-gate global argv nProb nTest skip_test 1227c478bd9Sstevel@tonic-gate if {$skip_test} { 1237c478bd9Sstevel@tonic-gate set skip_test 0 1247c478bd9Sstevel@tonic-gate return 1257c478bd9Sstevel@tonic-gate } 126*1da57d55SToomas Soome if {[llength $argv]==0} { 1277c478bd9Sstevel@tonic-gate set go 1 1287c478bd9Sstevel@tonic-gate } else { 1297c478bd9Sstevel@tonic-gate set go 0 1307c478bd9Sstevel@tonic-gate foreach pattern $argv { 1317c478bd9Sstevel@tonic-gate if {[string match $pattern $name]} { 1327c478bd9Sstevel@tonic-gate set go 1 1337c478bd9Sstevel@tonic-gate break 1347c478bd9Sstevel@tonic-gate } 1357c478bd9Sstevel@tonic-gate } 1367c478bd9Sstevel@tonic-gate } 1377c478bd9Sstevel@tonic-gate if {!$go} return 1387c478bd9Sstevel@tonic-gate incr nTest 1397c478bd9Sstevel@tonic-gate puts -nonewline $name... 1407c478bd9Sstevel@tonic-gate flush stdout 1417c478bd9Sstevel@tonic-gate if {[catch {uplevel #0 "$cmd;\n"} result]} { 1427c478bd9Sstevel@tonic-gate puts "\nError: $result" 1437c478bd9Sstevel@tonic-gate incr nErr 1447c478bd9Sstevel@tonic-gate } elseif {[string compare $result $expected]} { 1457c478bd9Sstevel@tonic-gate puts "\nExpected: \[$expected\]\n Got: \[$result\]" 1467c478bd9Sstevel@tonic-gate puts "NOTE: The results of the previous test depend on system load" 1477c478bd9Sstevel@tonic-gate puts "and processor speed. The test may sometimes fail even if the" 1487c478bd9Sstevel@tonic-gate puts "library is working correctly." 149*1da57d55SToomas Soome incr nProb 1507c478bd9Sstevel@tonic-gate } else { 1517c478bd9Sstevel@tonic-gate puts " Ok" 1527c478bd9Sstevel@tonic-gate } 1537c478bd9Sstevel@tonic-gate} 1547c478bd9Sstevel@tonic-gate 1557c478bd9Sstevel@tonic-gate# The procedure uses the special "sqlite_malloc_stat" command 1567c478bd9Sstevel@tonic-gate# (which is only available if SQLite is compiled with -DMEMORY_DEBUG=1) 1577c478bd9Sstevel@tonic-gate# to see how many malloc()s have not been free()ed. The number 1587c478bd9Sstevel@tonic-gate# of surplus malloc()s is stored in the global variable $::Leak. 1597c478bd9Sstevel@tonic-gate# If the value in $::Leak grows, it may mean there is a memory leak 1607c478bd9Sstevel@tonic-gate# in the library. 1617c478bd9Sstevel@tonic-gate# 1627c478bd9Sstevel@tonic-gateproc memleak_check {} { 1637c478bd9Sstevel@tonic-gate if {[info command sqlite_malloc_stat]!=""} { 1647c478bd9Sstevel@tonic-gate set r [sqlite_malloc_stat] 1657c478bd9Sstevel@tonic-gate set ::Leak [expr {[lindex $r 0]-[lindex $r 1]}] 1667c478bd9Sstevel@tonic-gate } 1677c478bd9Sstevel@tonic-gate} 1687c478bd9Sstevel@tonic-gate 1697c478bd9Sstevel@tonic-gate# Run this routine last 1707c478bd9Sstevel@tonic-gate# 1717c478bd9Sstevel@tonic-gateproc finish_test {} { 1727c478bd9Sstevel@tonic-gate finalize_testing 1737c478bd9Sstevel@tonic-gate} 1747c478bd9Sstevel@tonic-gateproc finalize_testing {} { 1757c478bd9Sstevel@tonic-gate global nTest nErr nProb sqlite_open_file_count 1767c478bd9Sstevel@tonic-gate if {$nErr==0} memleak_check 1777c478bd9Sstevel@tonic-gate catch {db close} 1787c478bd9Sstevel@tonic-gate puts "$nErr errors out of $nTest tests" 1797c478bd9Sstevel@tonic-gate puts "Failures on these tests: $::failList" 1807c478bd9Sstevel@tonic-gate if {$nProb>0} { 1817c478bd9Sstevel@tonic-gate puts "$nProb probabilistic tests also failed, but this does" 1827c478bd9Sstevel@tonic-gate puts "not necessarily indicate a malfunction." 1837c478bd9Sstevel@tonic-gate } 1847c478bd9Sstevel@tonic-gate if {$sqlite_open_file_count} { 1857c478bd9Sstevel@tonic-gate puts "$sqlite_open_file_count files were left open" 1867c478bd9Sstevel@tonic-gate incr nErr 1877c478bd9Sstevel@tonic-gate } 1887c478bd9Sstevel@tonic-gate exit [expr {$nErr>0}] 1897c478bd9Sstevel@tonic-gate} 1907c478bd9Sstevel@tonic-gate 1917c478bd9Sstevel@tonic-gate# A procedure to execute SQL 1927c478bd9Sstevel@tonic-gate# 1937c478bd9Sstevel@tonic-gateproc execsql {sql {db db}} { 1947c478bd9Sstevel@tonic-gate # puts "SQL = $sql" 1957c478bd9Sstevel@tonic-gate return [$db eval $sql] 1967c478bd9Sstevel@tonic-gate} 1977c478bd9Sstevel@tonic-gate 1987c478bd9Sstevel@tonic-gate# Execute SQL and catch exceptions. 1997c478bd9Sstevel@tonic-gate# 2007c478bd9Sstevel@tonic-gateproc catchsql {sql {db db}} { 2017c478bd9Sstevel@tonic-gate # puts "SQL = $sql" 2027c478bd9Sstevel@tonic-gate set r [catch {$db eval $sql} msg] 2037c478bd9Sstevel@tonic-gate lappend r $msg 2047c478bd9Sstevel@tonic-gate return $r 2057c478bd9Sstevel@tonic-gate} 2067c478bd9Sstevel@tonic-gate 2077c478bd9Sstevel@tonic-gate# Do an VDBE code dump on the SQL given 2087c478bd9Sstevel@tonic-gate# 2097c478bd9Sstevel@tonic-gateproc explain {sql {db db}} { 2107c478bd9Sstevel@tonic-gate puts "" 2117c478bd9Sstevel@tonic-gate puts "addr opcode p1 p2 p3 " 2127c478bd9Sstevel@tonic-gate puts "---- ------------ ------ ------ ---------------" 2137c478bd9Sstevel@tonic-gate $db eval "explain $sql" {} { 2147c478bd9Sstevel@tonic-gate puts [format {%-4d %-12.12s %-6d %-6d %s} $addr $opcode $p1 $p2 $p3] 2157c478bd9Sstevel@tonic-gate } 2167c478bd9Sstevel@tonic-gate} 2177c478bd9Sstevel@tonic-gate 2187c478bd9Sstevel@tonic-gate# Another procedure to execute SQL. This one includes the field 2197c478bd9Sstevel@tonic-gate# names in the returned list. 2207c478bd9Sstevel@tonic-gate# 2217c478bd9Sstevel@tonic-gateproc execsql2 {sql} { 2227c478bd9Sstevel@tonic-gate set result {} 2237c478bd9Sstevel@tonic-gate db eval $sql data { 2247c478bd9Sstevel@tonic-gate foreach f $data(*) { 2257c478bd9Sstevel@tonic-gate lappend result $f $data($f) 2267c478bd9Sstevel@tonic-gate } 2277c478bd9Sstevel@tonic-gate } 2287c478bd9Sstevel@tonic-gate return $result 2297c478bd9Sstevel@tonic-gate} 2307c478bd9Sstevel@tonic-gate 2317c478bd9Sstevel@tonic-gate# Use the non-callback API to execute multiple SQL statements 2327c478bd9Sstevel@tonic-gate# 2337c478bd9Sstevel@tonic-gateproc stepsql {dbptr sql} { 2347c478bd9Sstevel@tonic-gate set sql [string trim $sql] 2357c478bd9Sstevel@tonic-gate set r 0 2367c478bd9Sstevel@tonic-gate while {[string length $sql]>0} { 2377c478bd9Sstevel@tonic-gate if {[catch {sqlite_compile $dbptr $sql sqltail} vm]} { 2387c478bd9Sstevel@tonic-gate return [list 1 $vm] 2397c478bd9Sstevel@tonic-gate } 2407c478bd9Sstevel@tonic-gate set sql [string trim $sqltail] 2417c478bd9Sstevel@tonic-gate while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} { 2427c478bd9Sstevel@tonic-gate foreach v $VAL {lappend r $v} 2437c478bd9Sstevel@tonic-gate } 2447c478bd9Sstevel@tonic-gate if {[catch {sqlite_finalize $vm} errmsg]} { 2457c478bd9Sstevel@tonic-gate return [list 1 $errmsg] 2467c478bd9Sstevel@tonic-gate } 2477c478bd9Sstevel@tonic-gate } 2487c478bd9Sstevel@tonic-gate return $r 2497c478bd9Sstevel@tonic-gate} 2507c478bd9Sstevel@tonic-gate 2517c478bd9Sstevel@tonic-gate# Delete a file or directory 2527c478bd9Sstevel@tonic-gate# 2537c478bd9Sstevel@tonic-gateproc forcedelete {filename} { 2547c478bd9Sstevel@tonic-gate if {[catch {file delete -force $filename}]} { 2557c478bd9Sstevel@tonic-gate exec rm -rf $filename 2567c478bd9Sstevel@tonic-gate } 2577c478bd9Sstevel@tonic-gate} 2587c478bd9Sstevel@tonic-gate 2597c478bd9Sstevel@tonic-gate# Do an integrity check of the entire database 2607c478bd9Sstevel@tonic-gate# 2617c478bd9Sstevel@tonic-gateproc integrity_check {name} { 2627c478bd9Sstevel@tonic-gate do_test $name { 2637c478bd9Sstevel@tonic-gate execsql {PRAGMA integrity_check} 2647c478bd9Sstevel@tonic-gate } {ok} 2657c478bd9Sstevel@tonic-gate} 266