Index: test/wapptest.tcl ================================================================== --- test/wapptest.tcl +++ test/wapptest.tcl @@ -1,12 +1,15 @@ #!/bin/sh # \ exec wapptclsh "$0" ${1+"$@"} +# package required wapp +source [file join [file dirname [info script]] wapp.tcl] + +# Read the data from the releasetest_data.tcl script. # -# -# +source [file join [file dirname [info script]] releasetest_data.tcl] # Variables set by the "control" form: # # G(platform) - User selected platform. # G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only". @@ -20,32 +23,29 @@ set G(keep) 0 set G(msvc) 0 set G(tcl) "" set G(jobs) 3 -set G(sqlite_version) unknown - -# The root of the SQLite source tree. -# -set G(srcdir) [file dirname [file dirname [info script]]] - -# Either "config", "running", "stopped": -# -set G(state) "config" - -# releasetest.tcl script -# -set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl] - -set G(cnt) 0 - -# package required wapp -source [file join [file dirname [info script]] wapp.tcl] - -# Read the data from the releasetest_data.tcl script. -# -source [file join [file dirname [info script]] releasetest_data.tcl] +proc wapptest_init {} { + global G + + set lSave [list platform test keep msvc tcl jobs] + 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]]] + + # releasetest.tcl script + set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl] + + set G(sqlite_version) "unknown" + + # Either "config", "running" or "stopped": + set G(state) "config" +} # Check to see if there are uncommitted changes in the SQLite source # directory. Return true if there are, or false otherwise. # proc check_uncommitted {} { @@ -159,29 +159,34 @@ if {[file readable core]} { append G(test.$name.errmsg) " - core file exists" } } } + +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) + } +} 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) - 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) - } + slave_test_done $name $rc } else { set line [gets $fd] if {[string trim $line] != ""} { puts "Trace : $name - \"$line\"" } } @@ -213,10 +218,11 @@ } set G(result) "$nError errors from $nTest tests in $nConfig configurations." catch { append G(result) " SQLite version $G(sqlite_version)" } + set G(state) "stopped" } else { set nLaunch [expr $G(jobs) - $nRunning] foreach j $G(test_array) { if {$nLaunch<=0} break set name [dict get $j config] @@ -238,15 +244,29 @@ incr nLaunch -1 } } } } + +proc generate_select_widget {label id lOpt opt} { + wapp-trim { + + } +} proc generate_main_page {{extra {}}} { global G set_test_array + # wapp-trim { @@ -263,52 +283,62 @@ } } wapp-trim {
-
- - + +
+ } + wapp-trim { - - - +

- -
-
- - - - -
- - -
- + + + + } +} + +proc wapp-default {} { + generate_main_page +} + +proc wapp-page-tests {} { + global G + wapp-trim {
} foreach t $G(test_array) { set config [dict get $t config] set target [dict get $t target] set class "testwait" @@ -369,93 +404,142 @@
%html($errmsg) } } } - wapp-trim { -
-
- } + wapp-trim { } + if {[info exists G(result)]} { set res $G(result) wapp-trim { -
%string($res)
+
%string($res)
} } - wapp-trim { - - - - } - incr G(cnt) } -proc wapp-default {} { - generate_main_page -} - +# URI: /control +# +# Whenever the form at the top of the application page is submitted, it +# is submitted here. +# proc wapp-page-control {} { global G - foreach v {platform test tcl jobs keep msvc} { + catch { puts [wapp-param control_msvc] } + if {$::G(state)=="config"} { + set lControls [list platform test tcl jobs keep msvc] + set G(msvc) 0 + set G(keep) 0 + } else { + set lControls [list jobs] + } + foreach v $lControls { if {[wapp-param-exists control_$v]} { set G($v) [wapp-param control_$v] - } else { - set G($v) 0 + } + } + + if {[wapp-param-exists control_run]} { + # This is a "run test" command. + set_test_array + set ::G(state) "running" + } + + 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 + } } } - if {[wapp-param-exists control_go]} { - # This is an actual "run test" command, not just a change of - # configuration! - set_test_array - set ::G(state) "running" + 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 { .div { border: 3px groove #444444; margin: 1em; padding: 1em; } + + .border { + border: 3px groove #444444; + padding: 1em; + margin-top: 1em; + margin-bottom: 1em; + } + + .div2 { + margin: 1em; + } + + table { + padding: 1em; + width:100%; + border: 3px groove #444444; + } .warning { text-align:center; color: red; font-size: 2em; font-weight: bold; } - .right { - } - .testfield { padding-right: 10ex; + white-space: nowrap; } .testwait {} .testrunning { color: blue } .testdone { color: green } .testfail { color: red } + + .right { float: right; } + } } -proc wapp-page-script.js {} { +# 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) wapp-subst { - var lElem = \["control_platform", "control_test", "control_msvc", "control_jobs"\]; + var lElem = \["control_platform", "control_test", "control_msvc", + "control_jobs" + \]; lElem.forEach(function(e) { var elem = document.getElementById(e); elem.addEventListener("change", function() { control.submit() } ); }) @@ -467,31 +551,61 @@ elem = document.getElementById("control_msvc"); elem.checked = %string($msvc); } - if {$::G(state)!="config"} { + if {$script != "config.js"} { wapp-subst { var lElem = \["control_platform", "control_test", - "control_tcl", "control_keep", "control_msvc", "control_go" + "control_tcl", "control_keep", "control_msvc" \]; 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 {

Wapp Environment

\n
     
%html([wapp-debug-env])

   }
 }
 
+# URI: /log/dirname/test.log
+#
+# This URI reads file "dirname/test.log" from disk, wraps it in a 
+# 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
@@ -500,7 +614,8 @@
     %html($data)
     

   }
 }
 
+wapptest_init
 wapp-start $argv