diff options
Diffstat (limited to 'test/tester.tcl')
| -rw-r--r-- | test/tester.tcl | 86 |
1 files changed, 73 insertions, 13 deletions
diff --git a/test/tester.tcl b/test/tester.tcl index 3c34b45..07eebcb 100644 --- a/test/tester.tcl +++ b/test/tester.tcl @@ -19,6 +19,7 @@ # # Commands to manipulate the db and the file-system at a high level: # +# get_pwd # copy_file FROM TO # delete_file FILENAME # drop_all_tables ?DB? @@ -57,7 +58,7 @@ # Commands providing a lower level interface to the global test counters: # # set_test_counter COUNTER ?VALUE? -# omit_test TESTNAME REASON +# omit_test TESTNAME REASON ?APPEND? # fail_test TESTNAME # incr_ntest # @@ -148,6 +149,24 @@ proc getFileRetryDelay {} { return $::G(file-retry-delay) } +# Return the string representing the name of the current directory. On +# Windows, the result is "normalized" to whatever our parent command shell +# is using to prevent case-mismatch issues. +# +proc get_pwd {} { + if {$::tcl_platform(platform) eq "windows"} { + # + # NOTE: Cannot use [file normalize] here because it would alter the + # case of the result to what Tcl considers canonical, which would + # defeat the purpose of this procedure. + # + return [string map [list \\ /] \ + [string trim [exec -- $::env(ComSpec) /c echo %CD%]]] + } else { + return [pwd] + } +} + # Copy file $from into $to. This is used because some versions of # TCL for windows (notably the 8.4.1 binary package shipped with the # current mingw release) have a broken "file copy" command. @@ -274,6 +293,7 @@ if {[info exists cmdlinearg]==0} { # --file-retries=N # --file-retry-delay=N # --start=[$permutation:]$testfile + # --match=$pattern # set cmdlinearg(soft-heap-limit) 0 set cmdlinearg(maxerror) 1000 @@ -283,7 +303,8 @@ if {[info exists cmdlinearg]==0} { set cmdlinearg(soak) 0 set cmdlinearg(file-retries) 0 set cmdlinearg(file-retry-delay) 0 - set cmdlinearg(start) "" + set cmdlinearg(start) "" + set cmdlinearg(match) "" set leftover [list] foreach a $argv { @@ -336,6 +357,12 @@ if {[info exists cmdlinearg]==0} { } if {$::G(start:file) == ""} {unset ::G(start:file)} } + {^-+match=.+$} { + foreach {dummy cmdlinearg(match)} [split $a =] break + + set ::G(match) $cmdlinearg(match) + if {$::G(match) == ""} {unset ::G(match)} + } default { lappend leftover $a } @@ -414,9 +441,11 @@ if {0==[info exists ::SLAVE]} { # Record the fact that a sequence of tests were omitted. # -proc omit_test {name reason} { +proc omit_test {name reason {append 1}} { set omitList [set_test_counter omit_list] - lappend omitList [list $name $reason] + if {$append} { + lappend omitList [list $name $reason] + } set_test_counter omit_list $omitList } @@ -445,7 +474,6 @@ proc incr_ntest {} { # Invoke the do_test procedure to run a single test # proc do_test {name cmd expected} { - global argv cmdlinearg fix_testname name @@ -471,18 +499,47 @@ proc do_test {name cmd expected} { incr_ntest puts -nonewline $name... flush stdout - if {[catch {uplevel #0 "$cmd;\n"} result]} { - puts "\nError: $result" - fail_test $name - } elseif {[string compare $result $expected]} { - puts "\nExpected: \[$expected\]\n Got: \[$result\]" - fail_test $name + + if {![info exists ::G(match)] || [string match $::G(match) $name]} { + if {[catch {uplevel #0 "$cmd;\n"} result]} { + puts "\nError: $result" + fail_test $name + } else { + if {[regexp {^~?/.*/$} $expected]} { + if {[string index $expected 0]=="~"} { + set re [string range $expected 2 end-1] + set ok [expr {![regexp $re $result]}] + } else { + set re [string range $expected 1 end-1] + set ok [regexp $re $result] + } + } else { + set ok [expr {[string compare $result $expected]==0}] + } + if {!$ok} { + puts "\nExpected: \[$expected\]\n Got: \[$result\]" + fail_test $name + } else { + puts " Ok" + } + } } else { - puts " Ok" + puts " Omitted" + omit_test $name "pattern mismatch" 0 } flush stdout } +proc catchcmd {db {cmd ""}} { + global CLI + set out [open cmds.txt w] + puts $out $cmd + close $out + set line "exec $CLI $db < cmds.txt" + set rc [catch { eval $line } msg] + list $rc $msg +} + proc filepath_normalize {p} { # test cases should be written to assume "unix"-like file paths if {$::tcl_platform(platform)!="unix"} { @@ -968,7 +1025,7 @@ proc crashsql {args} { # $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 [pwd] $crashfile]]] + set cfile [string map {\\ \\\\} [file nativename [file join [get_pwd] $crashfile]]] set f [open crash.tcl w] puts $f "sqlite3_crash_enable 1" @@ -1557,5 +1614,8 @@ proc db_delete_and_reopen {{file test.db}} { # to non-zero, then set the global variable $AUTOVACUUM to 1. set AUTOVACUUM $sqlite_options(default_autovacuum) +# Make sure the FTS enhanced query syntax is disabled. +set sqlite_fts3_enable_parentheses 0 + source $testdir/thread_common.tcl source $testdir/malloc_common.tcl |