diff options
Diffstat (limited to 'test/wapptest.tcl')
| -rwxr-xr-x | test/wapptest.tcl | 909 |
1 files changed, 909 insertions, 0 deletions
diff --git a/test/wapptest.tcl b/test/wapptest.tcl new file mode 100755 index 0000000..d37b2e4 --- /dev/null +++ b/test/wapptest.tcl @@ -0,0 +1,909 @@ +#!/bin/sh +# \ +exec wapptclsh "$0" ${1+"$@"} + +# package required wapp +source [file join [file dirname [info script]] wapp.tcl] + +# Variables set by the "control" form: +# +# G(platform) - User selected platform. +# G(cfgglob) - Glob pattern that all configurations must match +# G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only". +# G(keep) - Boolean. True to delete no files after each test. +# G(msvc) - Boolean. True to use MSVC as the compiler. +# G(tcl) - Use Tcl from this directory for builds. +# G(jobs) - How many sub-processes to run simultaneously. +# +set G(platform) $::tcl_platform(os)-$::tcl_platform(machine) +set G(cfgglob) * +set G(test) Normal +set G(keep) 1 +set G(msvc) 0 +set G(tcl) [::tcl::pkgconfig get libdir,install] +set G(jobs) 3 +set G(debug) 0 + +set G(noui) 0 +set G(stdout) 0 + + +proc wapptest_init {} { + global G + + set lSave [list platform test keep msvc tcl jobs debug noui stdout cfgglob] + foreach k $lSave { set A($k) $G($k) } + array unset G + foreach k $lSave { set G($k) $A($k) } + + # The root of the SQLite source tree. + set G(srcdir) [file dirname [file dirname [info script]]] + + set G(sqlite_version) "unknown" + + # Either "config", "running" or "stopped": + set G(state) "config" + + set G(hostname) "(unknown host)" + catch { set G(hostname) [exec hostname] } + set G(host) $G(hostname) + append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)" + append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)" +} + +proc wapptest_run {} { + global G + set_test_array + set G(state) "running" + + wapptest_openlog + + wapptest_output "Running the following for $G(platform). $G(jobs) jobs." + foreach t $G(test_array) { + set config [dict get $t config] + set target [dict get $t target] + wapptest_output [format " %-25s%s" $config $target] + } + wapptest_output [string repeat * 70] +} + +proc releasetest_data {args} { + global G + set rtd [file join $G(srcdir) test releasetest_data.tcl] + set fd [open "|[info nameofexecutable] $rtd $args" r+] + set ret [read $fd] + close $fd + return $ret +} + +# Generate the text for the box at the top of the UI. The current SQLite +# version, according to fossil, along with a warning if there are +# uncommitted changes in the checkout. +# +proc generate_fossil_info {} { + global G + set pwd [pwd] + cd $G(srcdir) + set rc [catch { + set r1 [exec fossil info] + set r2 [exec fossil changes] + }] + cd $pwd + if {$rc} return + + foreach line [split $r1 "\n"] { + if {[regexp {^checkout: *(.*)$} $line -> co]} { + wapp-trim { <br> %html($co) } + } + } + + if {[string trim $r2]!=""} { + wapp-trim { + <br><span class=warning> + WARNING: Uncommitted changes in checkout + </span> + } + } +} + +# If the application is in "config" state, set the contents of the +# ::G(test_array) global to reflect the tests that will be run. If the +# app is in some other state ("running" or "stopped"), this command +# is a no-op. +# +proc set_test_array {} { + global G + if { $G(state)=="config" } { + set G(test_array) [list] + set debug "-debug" + if {$G(debug)==0} { set debug "-nodebug"} + foreach {config target} [releasetest_data tests $debug $G(platform)] { + + # All configuration names must match $g(cfgglob), which defaults to * + # + if {![string match -nocase $G(cfgglob) $config]} continue + + # If using MSVC, do not run sanitize or valgrind tests. Or the + # checksymbols test. + if {$G(msvc) && ( + "Sanitize" == $config + || "checksymbols" in $target + || "valgrindtest" in $target + )} { + continue + } + + # If the test mode is not "Normal", override the target. + # + if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} { + switch -- $G(test) { + Veryquick { set target quicktest } + Smoketest { set target smoketest } + Build-Only { + set target testfixture + if {$::tcl_platform(platform)=="windows"} { + set target testfixture.exe + } + } + } + } + + lappend G(test_array) [dict create config $config target $target] + } + } +} + +proc count_tests_and_errors {name logfile} { + global G + + set fd [open $logfile rb] + set seen 0 + while {![eof $fd]} { + set line [gets $fd] + if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} { + incr G(test.$name.nError) $nerr + incr G(test.$name.nTest) $ntest + set seen 1 + if {$nerr>0} { + set G(test.$name.errmsg) $line + } + } + if {[regexp {runtime error: +(.*)} $line all msg]} { + # skip over "value is outside range" errors + if {[regexp {.* is outside the range of representable} $line]} { + # noop + } else { + incr G(test.$name.nError) + if {$G(test.$name.errmsg)==""} { + set G(test.$name.errmsg) $msg + } + } + } + if {[regexp {fatal error +(.*)} $line all msg]} { + incr G(test.$name.nError) + if {$G(test.$name.errmsg)==""} { + set G(test.$name.errmsg) $msg + } + } + if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} { + incr G(test.$name.nError) + if {$G(test.$name.errmsg)==""} { + set G(test.$name.errmsg) $all + } + } + if {[regexp {^VERSION: 3\.\d+.\d+} $line]} { + set v [string range $line 9 end] + if {$G(sqlite_version) eq "unknown"} { + set G(sqlite_version) $v + } elseif {$G(sqlite_version) ne $v} { + set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}" + } + } + } + close $fd + if {$G(test) == "Build-Only"} { + incr G(test.$name.nTest) + if {$G(test.$name.nError)>0} { + set errmsg "Build failed" + } + } elseif {!$seen} { + set G(test.$name.errmsg) "Test did not complete" + if {[file readable core]} { + append G(test.$name.errmsg) " - core file exists" + } + } +} + +proc wapptest_output {str} { + global G + if {$G(stdout)} { puts $str } + if {[info exists G(log)]} { + puts $G(log) $str + flush $G(log) + } +} +proc wapptest_openlog {} { + global G + set G(log) [open wapptest-out.txt w+] +} +proc wapptest_closelog {} { + global G + close $G(log) + unset G(log) +} + +proc format_seconds {seconds} { + set min [format %.2d [expr ($seconds / 60) % 60]] + set hr [format %.2d [expr $seconds / 3600]] + set sec [format %.2d [expr $seconds % 60]] + return "$hr:$min:$sec" +} + +# This command is invoked once a slave process has finished running its +# tests, successfully or otherwise. Parameter $name is the name of the +# test, $rc the exit code returned by the slave process. +# +proc slave_test_done {name rc} { + global G + set G(test.$name.done) [clock seconds] + set G(test.$name.nError) 0 + set G(test.$name.nTest) 0 + set G(test.$name.errmsg) "" + if {$rc} { + incr G(test.$name.nError) + } + if {[file exists $G(test.$name.log)]} { + count_tests_and_errors $name $G(test.$name.log) + } + + # If the "keep files" checkbox is clear, delete all files except for + # the executables and test logs. And any core file that is present. + if {$G(keep)==0} { + set keeplist { + testfixture testfixture.exe + sqlite3 sqlite3.exe + test.log test-out.txt + core + wapptest_make.sh + wapptest_configure.sh + wapptest_run.tcl + } + foreach f [glob -nocomplain [file join $G(test.$name.dir) *]] { + set t [file tail $f] + if {[lsearch $keeplist $t]<0} { + catch { file delete -force $f } + } + } + } + + # Format a message regarding the success or failure of hte test. + set t [format_seconds [expr $G(test.$name.done) - $G(test.$name.start)]] + set res "OK" + if {$G(test.$name.nError)} { set res "FAILED" } + set dots [string repeat . [expr 60 - [string length $name]]] + set msg "$name $dots $res ($t)" + + wapptest_output $msg + if {[info exists G(test.$name.errmsg)] && $G(test.$name.errmsg)!=""} { + wapptest_output " $G(test.$name.errmsg)" + } +} + +# This is a fileevent callback invoked each time a file-descriptor that +# connects this process to a slave process is readable. +# +proc slave_fileevent {name} { + global G + set fd $G(test.$name.channel) + + if {[eof $fd]} { + fconfigure $fd -blocking 1 + set rc [catch { close $fd }] + unset G(test.$name.channel) + slave_test_done $name $rc + } else { + set line [gets $fd] + if {[string trim $line] != ""} { puts "Trace : $name - \"$line\"" } + } + + do_some_stuff +} + +# Return the contents of the "slave script" - the script run by slave +# processes to actually perform the test. All it does is execute the +# test script already written to disk (wapptest_cmd.sh or wapptest_cmd.bat). +# +proc wapptest_slave_script {} { + global G + if {$G(msvc)==0} { + set dir [file join .. $G(srcdir)] + set res [subst -nocommands { + set rc [catch "exec sh wapptest_cmd.sh {$dir} >>& test.log" ] + exit [set rc] + }] + } else { + set dir [file nativename [file normalize $G(srcdir)]] + set dir [string map [list "\\" "\\\\"] $dir] + set res [subst -nocommands { + set rc [catch "exec wapptest_cmd.bat {$dir} >>& test.log" ] + exit [set rc] + }] + } + + set res +} + + +# Launch a slave process to run a test. +# +proc slave_launch {name target dir} { + global G + + catch { file mkdir $dir } msg + foreach f [glob -nocomplain [file join $dir *]] { + catch { file delete -force $f } + } + set G(test.$name.dir) $dir + + # Write the test command to wapptest_cmd.sh|bat. + # + set ext sh + if {$G(msvc)} { set ext bat } + set fd1 [open [file join $dir wapptest_cmd.$ext] w] + if {$G(msvc)} { + puts $fd1 [releasetest_data script -msvc $name $target] + } else { + puts $fd1 [releasetest_data script $name $target] + } + close $fd1 + + # Write the wapptest_run.tcl script to the test directory. To run the + # commands in the other two files. + # + set fd3 [open [file join $dir wapptest_run.tcl] w] + puts $fd3 [wapptest_slave_script] + close $fd3 + + set pwd [pwd] + cd $dir + set fd [open "|[info nameofexecutable] wapptest_run.tcl" r+] + cd $pwd + + set G(test.$name.channel) $fd + fconfigure $fd -blocking 0 + fileevent $fd readable [list slave_fileevent $name] +} + +proc do_some_stuff {} { + global G + + # Count the number of running jobs. A running job has an entry named + # "channel" in its dictionary. + set nRunning 0 + set bFinished 1 + foreach j $G(test_array) { + set name [dict get $j config] + if { [info exists G(test.$name.channel)]} { incr nRunning } + if {![info exists G(test.$name.done)]} { set bFinished 0 } + } + + if {$bFinished} { + set nError 0 + set nTest 0 + set nConfig 0 + foreach j $G(test_array) { + set name [dict get $j config] + incr nError $G(test.$name.nError) + incr nTest $G(test.$name.nTest) + incr nConfig + } + set G(result) "$nError errors from $nTest tests in $nConfig configurations." + wapptest_output [string repeat * 70] + wapptest_output $G(result) + catch { + append G(result) " SQLite version $G(sqlite_version)" + wapptest_output " SQLite version $G(sqlite_version)" + } + set G(state) "stopped" + wapptest_closelog + if {$G(noui)} { exit 0 } + } else { + set nLaunch [expr $G(jobs) - $nRunning] + foreach j $G(test_array) { + if {$nLaunch<=0} break + set name [dict get $j config] + if { ![info exists G(test.$name.channel)] + && ![info exists G(test.$name.done)] + } { + + set target [dict get $j target] + set dir [string tolower [string map {" " _ "-" _} $name]] + set G(test.$name.start) [clock seconds] + set G(test.$name.log) [file join $dir test.log] + + slave_launch $name $target $dir + + incr nLaunch -1 + } + } + } +} + +proc generate_select_widget {label id lOpt opt} { + wapp-trim { + <label> %string($label) </label> + <select id=%string($id) name=%string($id)> + } + foreach o $lOpt { + set selected "" + if {$o==$opt} { set selected " selected=1" } + wapp-subst "<option $selected>$o</option>" + } + wapp-trim { </select> } +} + +proc generate_main_page {{extra {}}} { + global G + set_test_array + + set hostname $G(hostname) + wapp-trim { + <html> + <head> + <title> %html($hostname): wapptest.tcl </title> + <link rel="stylesheet" type="text/css" href="style.css"/> + </head> + <body> + } + + set host $G(host) + wapp-trim { + <div class="border">%string($host) + } + generate_fossil_info + wapp-trim { + </div> + <div class="border" id=controls> + <form action="control" method="post" name="control"> + } + + # Build the "platform" select widget. + set lOpt [releasetest_data platforms] + generate_select_widget Platform control_platform $lOpt $G(platform) + + # Build the "test" select widget. + set lOpt [list Normal Veryquick Smoketest Build-Only] + generate_select_widget Test control_test $lOpt $G(test) + + # Build the "jobs" select widget. Options are 1 to 8. + generate_select_widget Jobs control_jobs {1 2 3 4 5 6 7 8 12 16} $G(jobs) + + switch $G(state) { + config { + set txt "Run Tests!" + set id control_run + } + running { + set txt "STOP Tests!" + set id control_stop + } + stopped { + set txt "Reset!" + set id control_reset + } + } + wapp-trim { + <div class=right> + <input id=%string($id) name=%string($id) type=submit value="%string($txt)"> + </input> + </div> + } + + wapp-trim { + <br><br> + <label> Tcl: </label> + <input id="control_tcl" name="control_tcl"></input> + <label> Keep files: </label> + <input id="control_keep" name="control_keep" type=checkbox value=1> + </input> + <label> Use MSVC: </label> + <input id="control_msvc" name="control_msvc" type=checkbox value=1> + <label> Debug tests: </label> + <input id="control_debug" name="control_debug" type=checkbox value=1> + </input> + } + wapp-trim { + </form> + } + wapp-trim { + </div> + <div id=tests> + } + wapp-page-tests + + set script "script/$G(state).js" + wapp-trim { + </div> + <script src=%string($script)></script> + </body> + </html> + } +} + +proc wapp-default {} { + generate_main_page +} + +proc wapp-page-tests {} { + global G + wapp-trim { <table class="border" width=100%> } + foreach t $G(test_array) { + set config [dict get $t config] + set target [dict get $t target] + + set class "testwait" + set seconds "" + + if {[info exists G(test.$config.log)]} { + if {[info exists G(test.$config.channel)]} { + set class "testrunning" + set seconds [expr [clock seconds] - $G(test.$config.start)] + } elseif {[info exists G(test.$config.done)]} { + if {$G(test.$config.nError)>0} { + set class "testfail" + } else { + set class "testdone" + } + set seconds [expr $G(test.$config.done) - $G(test.$config.start)] + } + set seconds [format_seconds $seconds] + } + + wapp-trim { + <tr class=%string($class)> + <td class="nowrap"> %html($config) + <td class="padleft nowrap"> %html($target) + <td class="padleft nowrap"> %html($seconds) + <td class="padleft nowrap"> + } + if {[info exists G(test.$config.log)]} { + set log $G(test.$config.log) + set uri "log/$log" + wapp-trim { + <a href=%url($uri)> %html($log) </a> + } + } + if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} { + set errmsg $G(test.$config.errmsg) + wapp-trim { + <tr class=testfail> + <td> <td class="padleft" colspan=3> %html($errmsg) + } + } + } + + wapp-trim { </table> } + + if {[info exists G(result)]} { + set res $G(result) + wapp-trim { + <div class=border id=result> %string($res) </div> + } + } +} + +# URI: /control +# +# Whenever the form at the top of the application page is submitted, it +# is submitted here. +# +proc wapp-page-control {} { + global G + if {$::G(state)=="config"} { + set lControls [list platform test tcl jobs keep msvc debug] + set G(msvc) 0 + set G(keep) 0 + set G(debug) 0 + } else { + set lControls [list jobs] + } + foreach v $lControls { + if {[wapp-param-exists control_$v]} { + set G($v) [wapp-param control_$v] + } + } + + if {[wapp-param-exists control_run]} { + # This is a "run test" command. + wapptest_run + } + + if {[wapp-param-exists control_stop]} { + # A "STOP tests" command. + set G(state) "stopped" + set G(result) "Test halted by user" + foreach j $G(test_array) { + set name [dict get $j config] + if { [info exists G(test.$name.channel)] } { + close $G(test.$name.channel) + unset G(test.$name.channel) + slave_test_done $name 1 + } + } + wapptest_closelog + } + + if {[wapp-param-exists control_reset]} { + # A "reset app" command. + set G(state) "config" + wapptest_init + } + + if {$::G(state) == "running"} { + do_some_stuff + } + wapp-redirect / +} + +# URI: /style.css +# +# Return the stylesheet for the application main page. +# +proc wapp-page-style.css {} { + wapp-subst { + + /* The boxes with black borders use this class */ + .border { + border: 3px groove #444444; + padding: 1em; + margin-top: 1em; + margin-bottom: 1em; + } + + /* Float to the right (used for the Run/Stop/Reset button) */ + .right { float: right; } + + /* Style for the large red warning at the top of the page */ + .warning { + color: red; + font-weight: bold; + } + + /* Styles used by cells in the test table */ + .padleft { padding-left: 5ex; } + .nowrap { white-space: nowrap; } + + /* Styles for individual tests, depending on the outcome */ + .testwait { } + .testrunning { color: blue } + .testdone { color: green } + .testfail { color: red } + } +} + +# URI: /script/${state}.js +# +# The last part of this URI is always "config.js", "running.js" or +# "stopped.js", depending on the state of the application. It returns +# the javascript part of the front-end for the requested state to the +# browser. +# +proc wapp-page-script {} { + regexp {[^/]*$} [wapp-param REQUEST_URI] script + + set tcl $::G(tcl) + set keep $::G(keep) + set msvc $::G(msvc) + set debug $::G(debug) + + wapp-subst { + var lElem = \["control_platform", "control_test", "control_msvc", + "control_jobs", "control_debug" + \]; + lElem.forEach(function(e) { + var elem = document.getElementById(e); + elem.addEventListener("change", function() { control.submit() } ); + }) + + elem = document.getElementById("control_tcl"); + elem.value = "%string($tcl)" + + elem = document.getElementById("control_keep"); + elem.checked = %string($keep); + + elem = document.getElementById("control_msvc"); + elem.checked = %string($msvc); + + elem = document.getElementById("control_debug"); + elem.checked = %string($debug); + } + + if {$script != "config.js"} { + wapp-subst { + var lElem = \["control_platform", "control_test", + "control_tcl", "control_keep", "control_msvc", + "control_debug" + \]; + lElem.forEach(function(e) { + var elem = document.getElementById(e); + elem.disabled = true; + }) + } + } + + if {$script == "running.js"} { + wapp-subst { + function reload_tests() { + fetch('tests') + .then( data => data.text() ) + .then( data => { + document.getElementById("tests").innerHTML = data; + }) + .then( data => { + if( document.getElementById("result") ){ + document.location = document.location; + } else { + setTimeout(reload_tests, 1000) + } + }); + } + + setTimeout(reload_tests, 1000) + } + } +} + +# URI: /env +# +# This is for debugging only. Serves no other purpose. +# +proc wapp-page-env {} { + wapp-allow-xorigin-params + wapp-trim { + <h1>Wapp Environment</h1>\n<pre> + <pre>%html([wapp-debug-env])</pre> + } +} + +# URI: /log/dirname/test.log +# +# This URI reads file "dirname/test.log" from disk, wraps it in a <pre> +# block, and returns it to the browser. Use for viewing log files. +# +proc wapp-page-log {} { + set log [string range [wapp-param REQUEST_URI] 5 end] + set fd [open $log] + set data [read $fd] + close $fd + wapp-trim { + <pre> + %html($data) + </pre> + } +} + +# Print out a usage message. Then do [exit 1]. +# +proc wapptest_usage {} { + puts stderr { +This Tcl script is used to test various configurations of SQLite. By +default it uses "wapp" to provide an interactive interface. Supported +command line options (all optional) are: + + --platform PLATFORM (which tests to run) + --config GLOB (only run configurations matching GLOB) + --smoketest (run "make smoketest" only) + --veryquick (run veryquick.test only) + --buildonly (build executables, do not run tests) + --jobs N (number of concurrent jobs) + --tcl DIR (where to find tclConfig.sh) + --deletefiles (delete extra files after each test) + --msvc (Use MS Visual C) + --debug (Also run [n]debugging versions of tests) + --noui (do not use wapp) + } + exit 1 +} + +# Sort command line arguments into two groups: those that belong to wapp, +# and those that belong to the application. +set WAPPARG(-server) 1 +set WAPPARG(-local) 1 +set WAPPARG(-scgi) 1 +set WAPPARG(-remote-scgi) 1 +set WAPPARG(-fromip) 1 +set WAPPARG(-nowait) 0 +set WAPPARG(-cgi) 0 +set lWappArg [list] +set lTestArg [list] +for {set i 0} {$i < [llength $argv]} {incr i} { + set arg [lindex $argv $i] + if {[string range $arg 0 1]=="--"} { + set arg [string range $arg 1 end] + } + if {[info exists WAPPARG($arg)]} { + lappend lWappArg $arg + if {$WAPPARG($arg)} { + incr i + lappend lWappArg [lindex $argv $i] + } + } else { + lappend lTestArg $arg + } +} + +wapptest_init +for {set i 0} {$i < [llength $lTestArg]} {incr i} { + set opt [lindex $lTestArg $i] + if {[string range $opt 0 1]=="--"} { + set opt [string range $opt 1 end] + } + switch -- $opt { + -platform { + if {$i==[llength $lTestArg]-1} { wapptest_usage } + incr i + set arg [lindex $lTestArg $i] + set lPlatform [releasetest_data platforms] + if {[lsearch $lPlatform $arg]<0} { + puts stderr "No such platform: $arg. Platforms are: $lPlatform" + exit -1 + } + set G(platform) $arg + } + + -smoketest { set G(test) Smoketest } + -veryquick { set G(test) Veryquick } + -buildonly { set G(test) Build-Only } + -jobs { + if {$i==[llength $lTestArg]-1} { wapptest_usage } + incr i + set G(jobs) [lindex $lTestArg $i] + } + + -tcl { + if {$i==[llength $lTestArg]-1} { wapptest_usage } + incr i + set G(tcl) [lindex $lTestArg $i] + } + + -deletefiles { + set G(keep) 0 + } + + -msvc { + set G(msvc) 1 + } + + -debug { + set G(debug) 1 + } + + -noui { + set G(noui) 1 + set G(stdout) 1 + } + + -config { + if {$i==[llength $lTestArg]-1} { wapptest_usage } + incr i + set G(cfgglob) [lindex $lTestArg $i] + } + + -stdout { + set G(stdout) 1 + } + + default { + puts stderr "Unrecognized option: [lindex $lTestArg $i]" + wapptest_usage + } + } +} + +if {$G(noui)==0} { + wapp-start $lWappArg +} else { + wapptest_run + do_some_stuff + vwait forever +} |