| #!/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(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(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] |
| 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)] { |
| |
| # 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} $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) |
| --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 |
| } |
| |
| -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 |
| } |