From: dan <dan@noemail.net>
Date: Wed, 10 Apr 2019 18:56:30 +0000 (+0000)
Subject: Various fixes for the wapptest.tcl script.
X-Git-Tag: version-3.28.0~20^2~4
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=523fb53f72ad41bddfe02f1f5d667dfdd164240f;p=thirdparty%2Fsqlite.git

Various fixes for the wapptest.tcl script.

FossilOrigin-Name: cbf423656047f0cb5200be6981a205e0ae206eef8263aa686f4a3621fb07fb57
---

diff --git a/manifest b/manifest
index bed37db080..6ce69b7e05 100644
--- a/manifest
+++ b/manifest
@@ -1,5 +1,5 @@
-C Add\stest/wapptest.tcl,\sa\swapp\salternative\sto\sreleasetest.tcl.
-D 2019-04-09T19:53:32.352
+C Various\sfixes\sfor\sthe\swapptest.tcl\sscript.
+D 2019-04-10T18:56:30.771
 F .fossil-settings/empty-dirs dbb81e8fc0401ac46a1491ab34a7f2c7c0452f2f06b54ebb845d024ca8283ef1
 F .fossil-settings/ignore-glob 35175cdfcf539b2318cb04a9901442804be81cd677d8b889fcc9149c21f239ea
 F LICENSE.md df5091916dbb40e6e9686186587125e1b2ff51f022cc334e886c19a0e9982724
@@ -1651,7 +1651,7 @@ F test/walslow.test c05c68d4dc2700a982f89133ce103a1a84cc285f
 F test/walthread.test 14b20fcfa6ae152f5d8e12f5dc8a8a724b7ef189f5d8ef1e2ceab79f2af51747
 F test/walvfs.test c0faffda13d045a96dfc541347886bb1a3d6f3205857fc98e683edfab766ea88
 F test/wapp.tcl b440cd8cf57953d3a49e7ee81e6a18f18efdaf113b69f7d8482b0710a64566ec
-F test/wapptest.tcl 2475dd60ac518bedb9c1021e9fdeaa74f4356dd44ca569328b9e91e16a85f95e x
+F test/wapptest.tcl e2eedf5a63cb22c51c2d19b5d192c901d55cd691ff1c28ffca9f15674a9826ea x
 F test/where.test 0607caa5a1fbfe7b93b95705981b463a3a0408038f22ae6e9dc11b36902b0e95
 F test/where2.test 478d2170637b9211f593120648858593bf2445a1
 F test/where3.test 2341a294e17193a6b1699ea7f192124a5286ca6acfcc3f4b06d16c931fbcda2c
@@ -1817,10 +1817,8 @@ F vsixtest/vsixtest.tcl 6a9a6ab600c25a91a7acc6293828957a386a8a93
 F vsixtest/vsixtest.vcxproj.data 2ed517e100c66dc455b492e1a33350c1b20fbcdc
 F vsixtest/vsixtest.vcxproj.filters 37e51ffedcdb064aad6ff33b6148725226cd608e
 F vsixtest/vsixtest_TemporaryKey.pfx e5b1b036facdb453873e7084e1cae9102ccc67a0
-P 80704a16f6dbbeacc65fa36a3623df10292a28aeacf9e2c1d2891258479e3b89
-R 06080d39da3db81d6f3cab91a1103d90
-T *branch * wapptest
-T *sym-wapptest *
-T -sym-trunk *
+P a4af0c2fee05aaa2e95ae6a5c847ff2d363e24f325f4ffdcf51bc264b9bf5e2d
+R 405204ee657d743c9c004fd0b9e7ec67
+T +closed cabb6489f0c1a31c817ca19ff2c6bd116848e73d13dc2ddf4f61de86619515bc
 U dan
-Z 106b952a53453ebb55ee818fa0cbefd7
+Z 1bc937cc049ea25e5bc28d800c0060d1
diff --git a/manifest.uuid b/manifest.uuid
index 3def84f552..29edfac8c5 100644
--- a/manifest.uuid
+++ b/manifest.uuid
@@ -1 +1 @@
-a4af0c2fee05aaa2e95ae6a5c847ff2d363e24f325f4ffdcf51bc264b9bf5e2d
\ No newline at end of file
+cbf423656047f0cb5200be6981a205e0ae206eef8263aa686f4a3621fb07fb57
\ No newline at end of file
diff --git a/test/wapptest.tcl b/test/wapptest.tcl
index cb9234bd7f..3dbbe95b34 100755
--- a/test/wapptest.tcl
+++ b/test/wapptest.tcl
@@ -2,9 +2,12 @@
 # \
 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:
 #
@@ -22,28 +25,25 @@ 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]]]
+proc wapptest_init {} {
+  global G
 
-# Either "config", "running", "stopped":
-#
-set G(state) "config"
+  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) }
 
-# releasetest.tcl script
-#
-set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
+  # The root of the SQLite source tree.
+  set G(srcdir)   [file dirname [file dirname [info script]]]
 
-set G(cnt) 0
+  # releasetest.tcl script
+  set G(releaseTest) [file join [file dirname [info script]] releasetest.tcl]
 
-# package required wapp
-source [file join [file dirname [info script]] wapp.tcl]
+  set G(sqlite_version) "unknown"
 
-# Read the data from the releasetest_data.tcl script.
-#
-source [file join [file dirname [info script]] releasetest_data.tcl]
+  # 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.
@@ -162,6 +162,20 @@ proc count_tests_and_errors {name logfile} {
   }
 }
 
+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)
@@ -170,16 +184,7 @@ proc slave_fileevent {name} {
     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\"" }
@@ -215,6 +220,7 @@ proc do_some_stuff {} {
     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) {
@@ -241,10 +247,24 @@ proc do_some_stuff {} {
   }
 }
 
+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
 
+  # <meta http-equiv="refresh" content="5; URL=/">
   wapp-trim {
     <html>
     <head>
@@ -265,62 +285,77 @@ proc generate_main_page {{extra {}}} {
 
   wapp-trim {
       <div class=div id=controls> 
-        <form action="control" method="post" name="control">
-        <label> Platform: </label>
-        <select id="control_platform" name="control_platform">
+      <form action="control" method="post" name="control">
   }
-  foreach platform [array names ::Platforms] {
-    set selected ""
-    if {$platform==$G(platform)} { set selected " selected=1" }
-    wapp-subst "<option $selected>$platform</option>"
+
+  # Build the "platform" select widget. 
+  set lOpt [array names ::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} $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 {
-        </select>
-        <label> Test: </label>
-        <select id="control_test" name="control_test">
-  }
-  foreach test [list Normal Veryquick Smoketest Build-Only] {
-    set selected ""
-    if {$test==$G(test)} { set selected " selected=1" }
-    wapp-subst "<option $selected>$test</option>"
+    <div class=right>
+    <input id=%string($id) name=%string($id) type=submit value="%string($txt)">
+    </input>
+    </div>
   }
-  wapp-trim [subst -nocommands {
-        </select>
+
+  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>
         </input>
-        <hr>
-        <div class=right>
-          <label> Jobs: </label>
-          <select id="control_jobs" name="control_jobs">
-  }]
-  for {set i 1} {$i <= 8} {incr i} {
-    if {$G(jobs)==$i} {
-      wapp-trim {
-        <option selected=1>%string($i)</option>
-      }
-    } else {
-      wapp-trim {
-        <option>%string($i)</option>
-      }
-    }
   }
   wapp-trim {
-          </select>
-          <input id=control_go name=control_go type=submit value="Run Tests!">
-          </input>
-        </div>
      </form>
-      </div>
-      <div class=div id=tests>    
-      <table>
   }
+  wapp-trim {
+     </div>
+     <div class=div2 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> }
   foreach t $G(test_array) {
     set config [dict get $t config]
     set target [dict get $t target]
@@ -371,52 +406,73 @@ proc generate_main_page {{extra {}}} {
     }
   }
 
-  wapp-trim {
-      </table>
-      </div>
-  }
+  wapp-trim { </table> }
+
   if {[info exists G(result)]} {
     set res $G(result)
     wapp-trim {
-      <div class=div id=log> %string($res) </div>
+      <div class=border id=result> %string($res) </div>
     }
   }
-  wapp-trim {
-    <script src="script.js"></script>
-    </body>
-    </html>
-  }
-  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_go]} {
-    # This is an actual "run test" command, not just a change of 
-    # configuration!
+  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_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 {
@@ -425,6 +481,23 @@ proc wapp-page-style.css {} {
       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;
@@ -432,28 +505,39 @@ proc wapp-page-style.css {} {
       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() } );
@@ -469,10 +553,10 @@ proc wapp-page-script.js {} {
     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);
@@ -480,8 +564,33 @@ proc wapp-page-script.js {} {
       })
     }
   }
+
+  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 {
@@ -490,6 +599,11 @@ proc wapp-page-env {} {
   }
 }
 
+# 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]
@@ -502,5 +616,6 @@ proc wapp-page-log {} {
   }
 }
 
+wapptest_init
 wapp-start $argv