From 569c6676a6ddb0ff73821d7693b5e18ddef809b9 Mon Sep 17 00:00:00 2001 From: Hans-Christoph Steiner Date: Thu, 16 Oct 2014 22:51:35 -0400 Subject: Imported Upstream version 3.2.0 --- test/tester.tcl | 304 ++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 262 insertions(+), 42 deletions(-) (limited to 'test/tester.tcl') diff --git a/test/tester.tcl b/test/tester.tcl index 761a36e..3bf92f2 100644 --- a/test/tester.tcl +++ b/test/tester.tcl @@ -14,7 +14,7 @@ # $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $ #------------------------------------------------------------------------- -# The commands provided by the code in this file to help with creating +# The commands provided by the code in this file to help with creating # test cases are as follows: # # Commands to manipulate the db and the file-system at a high level: @@ -42,6 +42,7 @@ # # Commands to execute/explain SQL statements: # +# memdbsql SQL # stepsql DB SQL # execsql2 SQL # explain_no_trace SQL @@ -58,6 +59,7 @@ # do_test TESTNAME SCRIPT EXPECTED # do_execsql_test TESTNAME SQL EXPECTED # do_catchsql_test TESTNAME SQL EXPECTED +# do_timed_execsql_test TESTNAME SQL EXPECTED # # Commands providing a lower level interface to the global test counters: # @@ -80,7 +82,7 @@ # presql # -# Set the precision of FP arithmatic used by the interpreter. And +# Set the precision of FP arithmatic used by the interpreter. And # configure SQLite to take database file locks on the page that begins # 64KB into the database file instead of the one 1GB in. This means # the code that handles that special case can be tested without creating @@ -90,7 +92,7 @@ set tcl_precision 15 sqlite3_test_control_pending_byte 0x0010000 -# If the pager codec is available, create a wrapper for the [sqlite3] +# If the pager codec is available, create a wrapper for the [sqlite3] # command that appends "-key {xyzzy}" to the command line. i.e. this: # # sqlite3 db test.db @@ -122,7 +124,7 @@ if {[info command sqlite_orig]==""} { } set res } else { - # This command is not opening a new database connection. Pass the + # This command is not opening a new database connection. Pass the # arguments through to the C implementation as the are. # uplevel 1 sqlite_orig $args @@ -291,6 +293,66 @@ proc do_delete_file {force args} { } } +if {$::tcl_platform(platform) eq "windows"} { + proc do_remove_win32_dir {args} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + foreach dirName $args { + # On windows, sometimes even a [remove_win32_dir] can fail just after + # a directory is emptied. The cause is usually "tag-alongs" - programs + # like anti-virus software, automatic backup tools and various explorer + # extensions that keep a file open a little longer than we expect, + # causing the delete to fail. + # + # The solution is to wait a short amount of time before retrying the + # removal. + # + if {$nRetry > 0} { + for {set i 0} {$i < $nRetry} {incr i} { + set rc [catch { + remove_win32_dir $dirName + } msg] + if {$rc == 0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + remove_win32_dir $dirName + } + } + } + + proc do_delete_win32_file {args} { + set nRetry [getFileRetries] ;# Maximum number of retries. + set nDelay [getFileRetryDelay] ;# Delay in ms before retrying. + + foreach fileName $args { + # On windows, sometimes even a [delete_win32_file] can fail just after + # a file is closed. The cause is usually "tag-alongs" - programs like + # anti-virus software, automatic backup tools and various explorer + # extensions that keep a file open a little longer than we expect, + # causing the delete to fail. + # + # The solution is to wait a short amount of time before retrying the + # delete. + # + if {$nRetry > 0} { + for {set i 0} {$i < $nRetry} {incr i} { + set rc [catch { + delete_win32_file $fileName + } msg] + if {$rc == 0} break + if {$nDelay > 0} { after $nDelay } + } + if {$rc} { error $msg } + } else { + delete_win32_file $fileName + } + } + } +} + proc execpresql {handle args} { trace remove execution $handle enter [list execpresql $handle] if {[info exists ::G(perm:presql)]} { @@ -312,8 +374,8 @@ proc do_not_use_codec {} { # if {[info exists cmdlinearg]==0} { - # Parse any options specified in the $argv array. This script accepts the - # following options: + # Parse any options specified in the $argv array. This script accepts the + # following options: # # --pause # --soft-heap-limit=NN @@ -342,7 +404,7 @@ if {[info exists cmdlinearg]==0} { foreach a $argv { switch -regexp -- $a { {^-+pause$} { - # Wait for user input before continuing. This is to give the user an + # Wait for user input before continuing. This is to give the user an # opportunity to connect profiling tools to the process. puts -nonewline "Press RETURN to begin..." flush stdout @@ -405,8 +467,8 @@ if {[info exists cmdlinearg]==0} { # Install the malloc layer used to inject OOM errors. And the 'automatic' # extensions. This only needs to be done once for the process. # - sqlite3_shutdown - install_malloc_faultsim 1 + sqlite3_shutdown + install_malloc_faultsim 1 sqlite3_initialize autoinstall_test_functions @@ -516,7 +578,7 @@ proc incr_ntest {} { } -# Invoke the do_test procedure to run a single test +# Invoke the do_test procedure to run a single test # proc do_test {name cmd expected} { global argv cmdlinearg @@ -525,7 +587,7 @@ proc do_test {name cmd expected} { sqlite3_memdebug_settitle $name -# if {[llength $argv]==0} { +# if {[llength $argv]==0} { # set go 1 # } else { # set go 0 @@ -551,12 +613,38 @@ proc do_test {name cmd expected} { fail_test $name } else { if {[regexp {^~?/.*/$} $expected]} { + # "expected" is of the form "/PATTERN/" then the result if correct if + # regular expression PATTERN matches the result. "~/PATTERN/" means + # the regular expression must not match. if {[string index $expected 0]=="~"} { - set re [string map {# {[-0-9.]+}} [string range $expected 2 end-1]] - set ok [expr {![regexp $re $result]}] + set re [string range $expected 2 end-1] + if {[string index $re 0]=="*"} { + # If the regular expression begins with * then treat it as a glob instead + set ok [string match $re $result] + } else { + set re [string map {# {[-0-9.]+}} $re] + set ok [regexp $re $result] + } + set ok [expr {!$ok}] } else { - set re [string map {# {[-0-9.]+}} [string range $expected 1 end-1]] - set ok [regexp $re $result] + set re [string range $expected 1 end-1] + if {[string index $re 0]=="*"} { + # If the regular expression begins with * then treat it as a glob instead + set ok [string match $re $result] + } else { + set re [string map {# {[-0-9.]+}} $re] + set ok [regexp $re $result] + } + } + } elseif {[regexp {^~?\*.*\*$} $expected]} { + # "expected" is of the form "*GLOB*" then the result if correct if + # glob pattern GLOB matches the result. "~/GLOB/" means + # the glob must not match. + if {[string index $expected 0]=="~"} { + set e [string range $expected 1 end] + set ok [expr {![string match $e $result]}] + } else { + set ok [string match $expected $result] } } else { set ok [expr {[string compare $result $expected]==0}] @@ -615,13 +703,13 @@ proc do_realnum_test {name cmd expected} { proc fix_testname {varname} { upvar $varname testname - if {[info exists ::testprefix] + if {[info exists ::testprefix] && [string is digit [string range $testname 0 0]] } { set testname "${::testprefix}-$testname" } } - + proc do_execsql_test {testname sql {result {}}} { fix_testname testname uplevel do_test [list $testname] [list "execsql {$sql}"] [list [list {*}$result]] @@ -630,6 +718,11 @@ proc do_catchsql_test {testname sql result} { fix_testname testname uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result] } +proc do_timed_execsql_test {testname sql {result {}}} { + fix_testname testname + uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\ + [list [list {*}$result]] +} proc do_eqp_test {name sql res} { uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res] } @@ -707,7 +800,7 @@ proc delete_all_data {} { } } -# Run an SQL script. +# Run an SQL script. # Return the number of microseconds per statement. # proc speed_trial {name numstmt units sql} { @@ -770,6 +863,7 @@ proc speed_trial_summary {name} { # proc finish_test {} { catch {db close} + catch {db1 close} catch {db2 close} catch {db3 close} if {0==[info exists ::SLAVE]} { finalize_testing } @@ -793,9 +887,28 @@ proc finalize_testing {} { set nTest [incr_ntest] set nErr [set_test_counter errors] - puts "$nErr errors out of $nTest tests" - if {$nErr>0} { - puts "Failures on these tests: [set_test_counter fail_list]" + set nKnown 0 + if {[file readable known-problems.txt]} { + set fd [open known-problems.txt] + set content [read $fd] + close $fd + foreach x $content {set known_error($x) 1} + foreach x [set_test_counter fail_list] { + if {[info exists known_error($x)]} {incr nKnown} + } + } + if {$nKnown>0} { + puts "[expr {$nErr-$nKnown}] new errors and $nKnown known errors\ + out of $nTest tests" + } else { + puts "$nErr errors out of $nTest tests" + } + if {$nErr>$nKnown} { + puts -nonewline "Failures on these tests:" + foreach x [set_test_counter fail_list] { + if {![info exists known_error($x)]} {puts -nonewline " $x"} + } + puts "" } foreach warning [set_test_counter warn_list] { puts "Warning: $warning" @@ -907,6 +1020,14 @@ proc execsql {sql {db db}} { # puts "SQL = $sql" uplevel [list $db eval $sql] } +proc execsql_timed {sql {db db}} { + set tm [time { + set x [uplevel [list $db eval $sql]] + } 1] + set tm [lindex $tm 0] + puts -nonewline " ([expr {$tm*0.001}]ms) " + set x +} # Execute SQL and catch exceptions. # @@ -930,6 +1051,87 @@ proc explain {sql {db db}} { } } +proc explain_i {sql {db db}} { + puts "" + puts "addr opcode p1 p2 p3 p4 p5 #" + puts "---- ------------ ------ ------ ------ ---------------- -- -" + + + # Set up colors for the different opcodes. Scheme is as follows: + # + # Red: Opcodes that write to a b-tree. + # Blue: Opcodes that reposition or seek a cursor. + # Green: The ResultRow opcode. + # + if { [catch {fconfigure stdout -mode}]==0 } { + set R "\033\[31;1m" ;# Red fg + set G "\033\[32;1m" ;# Green fg + set B "\033\[34;1m" ;# Red fg + set D "\033\[39;0m" ;# Default fg + } else { + set R "" + set G "" + set B "" + set D "" + } + foreach opcode { + Seek SeekGe SeekGt SeekLe SeekLt NotFound Last Rewind + NoConflict Next Prev VNext VPrev VFilter + } { + set color($opcode) $B + } + foreach opcode {ResultRow} { + set color($opcode) $G + } + foreach opcode {IdxInsert Insert Delete IdxDelete} { + set color($opcode) $R + } + + set bSeenGoto 0 + $db eval "explain $sql" {} { + set x($addr) 0 + set op($addr) $opcode + + if {$opcode == "Goto" && ($bSeenGoto==0 || ($p2 > $addr+10))} { + set linebreak($p2) 1 + set bSeenGoto 1 + } + + if {$opcode=="Next" || $opcode=="Prev" + || $opcode=="VNext" || $opcode=="VPrev" + } { + for {set i $p2} {$i<$addr} {incr i} { + incr x($i) 2 + } + } + + if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} { + for {set i [expr $p2+1]} {$i<$addr} {incr i} { + incr x($i) 2 + } + } + + if {$opcode == "Halt" && $comment == "End of coroutine"} { + set linebreak([expr $addr+1]) 1 + } + } + + $db eval "explain $sql" {} { + if {[info exists linebreak($addr)]} { + puts "" + } + set I [string repeat " " $x($addr)] + + set col "" + catch { set col $color($opcode) } + + puts [format {%-4d %s%s%-12.12s%s %-6d %-6d %-6d % -17s %s %s} \ + $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment + ] + } + puts "---- ------------ ------ ------ ------ ---------------- -- -" +} + # Show the VDBE program for an SQL statement but omit the Trace # opcode at the beginning. This procedure can be used to prove # that different SQL statements generate exactly the same VDBE code. @@ -952,6 +1154,15 @@ proc execsql2 {sql} { return $result } +# Use a temporary in-memory database to execute SQL statements +# +proc memdbsql {sql} { + sqlite3 memdb :memory: + set result [memdb eval $sql] + memdb close + return $result +} + # Use the non-callback API to execute multiple SQL statements # proc stepsql {dbptr sql} { @@ -1062,17 +1273,19 @@ proc crashsql {args} { set blocksize "" set crashdelay 1 set prngseed 0 + set opendb { sqlite3 db test.db -vfs crash } set tclbody {} set crashfile "" set dc "" set sql [lindex $args end] - + for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} { set z [lindex $args $ii] set n [string length $z] set z2 [lindex $args [expr $ii+1]] if {$n>1 && [string first $z -delay]==0} {set crashdelay $z2} \ + elseif {$n>1 && [string first $z -opendb]==0} {set opendb $z2} \ elseif {$n>1 && [string first $z -seed]==0} {set prngseed $z2} \ elseif {$n>1 && [string first $z -file]==0} {set crashfile $z2} \ elseif {$n>1 && [string first $z -tclbody]==0} {set tclbody $z2} \ @@ -1085,7 +1298,7 @@ proc crashsql {args} { error "Compulsory option -file missing" } - # $crashfile gets compared to the native filename in + # $crashfile gets compared to the native filename in # cfSync(), which can be different then what TCL uses by # default, so here we force it to the "nativename" format. set cfile [string map {\\ \\\\} [file nativename [file join [get_pwd] $crashfile]]] @@ -1094,7 +1307,7 @@ proc crashsql {args} { puts $f "sqlite3_crash_enable 1" puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile" puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte" - puts $f "sqlite3 db test.db -vfs crash" + puts $f $opendb # This block sets the cache size of the main database to 10 # pages. This is done in case the build is configured to omit @@ -1102,6 +1315,7 @@ proc crashsql {args} { puts $f {db eval {SELECT * FROM sqlite_master;}} puts $f {set bt [btree_from_db db]} puts $f {btree_set_cache_size $bt 10} + if {$prngseed} { set seed [expr {$prngseed%10007+1}] # puts seed=$seed @@ -1120,7 +1334,7 @@ proc crashsql {args} { set r [catch { exec [info nameofexec] crash.tcl >@stdout } msg] - + # Windows/ActiveState TCL returns a slightly different # error message. We map that to the expected message # so that we don't have to change all of the test @@ -1130,7 +1344,7 @@ proc crashsql {args} { set msg "child process exited abnormally" } } - + lappend r $msg } @@ -1156,7 +1370,7 @@ proc run_ioerr_prep {} { # Usage: do_ioerr_test # # This proc is used to implement test cases that check that IO errors -# are correctly handled. The first argument, , is an integer +# are correctly handled. The first argument, , is an integer # used to name the tests executed by this proc. Options are as follows: # # -tclprep TCL script to run to prepare test. @@ -1185,7 +1399,7 @@ proc do_ioerr_test {testname args} { # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are # a couple of obscure IO errors that do not return them. set ::ioerropts(-erc) 0 - + # Create a single TCL script from the TCL and SQL specified # as the body of the test. set ::ioerrorbody {} @@ -1209,7 +1423,7 @@ proc do_ioerr_test {testname args} { set ::TN $n incr ::ioerropts(-count) -1 if {$::ioerropts(-count)<0} break - + # Skip this IO error if it was specified with the "-exclude" option. if {[info exists ::ioerropts(-exclude)]} { if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue @@ -1218,7 +1432,7 @@ proc do_ioerr_test {testname args} { restore_prng_state } - # Delete the files test.db and test2.db, then execute the TCL and + # Delete the files test.db and test2.db, then execute the TCL and # SQL (in that order) to prepare for the test case. do_test $testname.$n.1 { run_ioerr_prep @@ -1236,7 +1450,7 @@ proc do_ioerr_test {testname args} { }] $n # Execute the TCL script created for the body of this test. If - # at least N IO operations performed by SQLite as a result of + # at least N IO operations performed by SQLite as a result of # the script, the Nth will fail. do_test $testname.$n.3 { set ::sqlite_io_error_hit 0 @@ -1290,12 +1504,12 @@ proc do_ioerr_test {testname args} { set ::sqlite_io_error_hit 0 set ::sqlite_io_error_pending 0 - # Check that no page references were leaked. There should be - # a single reference if there is still an active transaction, + # Check that no page references were leaked. There should be + # a single reference if there is still an active transaction, # or zero otherwise. # # UPDATE: If the IO error occurs after a 'BEGIN' but before any - # locks are established on database files (i.e. if the error + # locks are established on database files (i.e. if the error # occurs while attempting to detect a hot-journal file), then # there may 0 page references and an active transaction according # to [sqlite3_get_autocommit]. @@ -1311,7 +1525,7 @@ proc do_ioerr_test {testname args} { } {1} } - # If there is an open database handle and no open transaction, + # If there is an open database handle and no open transaction, # and the pager is not running in exclusive-locking mode, # check that the pager is in "unlocked" state. Theoretically, # if a call to xUnlock() failed due to an IO error the underlying @@ -1415,7 +1629,7 @@ proc allcksum {{db db}} { } # Generate a checksum based on the contents of a single database with -# a database connection. The name of the database is $dbname. +# a database connection. The name of the database is $dbname. # Examples of $dbname are "temp" or "main". # proc dbcksum {db dbname} { @@ -1509,8 +1723,8 @@ proc drop_all_tables {{db db}} { #------------------------------------------------------------------------- # If a test script is executed with global variable $::G(perm:name) set to -# "wal", then the tests are run in WAL mode. Otherwise, they should be run -# in rollback mode. The following Tcl procs are used to make this less +# "wal", then the tests are run in WAL mode. Otherwise, they should be run +# in rollback mode. The following Tcl procs are used to make this less # intrusive: # # wal_set_journal_mode ?DB? @@ -1525,9 +1739,9 @@ proc drop_all_tables {{db db}} { # Otherwise (if not running a WAL permutation) this is a no-op. # # wal_is_wal_mode -# +# # Returns true if this test should be run in WAL mode. False otherwise. -# +# proc wal_is_wal_mode {} { expr {[permutation] eq "wal"} } @@ -1628,10 +1842,10 @@ proc slave_test_file {zFile} { } set ::sqlite_open_file_count 0 - # Test that the global "shared-cache" setting was not altered by + # Test that the global "shared-cache" setting was not altered by # the test script. # - ifcapable shared_cache { + ifcapable shared_cache { set res [expr {[sqlite3_enable_shared_cache] == $scs}] do_test ${tail}-sharedcachesetting [list set {} $res] 1 } @@ -1697,5 +1911,11 @@ set AUTOVACUUM $sqlite_options(default_autovacuum) # Make sure the FTS enhanced query syntax is disabled. set sqlite_fts3_enable_parentheses 0 +# During testing, assume that all database files are well-formed. The +# few test cases that deliberately corrupt database files should rescind +# this setting by invoking "database_can_be_corrupt" +# +database_never_corrupt + source $testdir/thread_common.tcl source $testdir/malloc_common.tcl -- cgit v1.2.3