gitlab.com/CoiaPrant/sqlite3@v1.19.1/testdata/tcl/wapptest.tcl (about) 1 #!/bin/sh 2 # \ 3 exec wapptclsh "$0" ${1+"$@"} 4 5 # package required wapp 6 source [file join [file dirname [info script]] wapp.tcl] 7 8 # Variables set by the "control" form: 9 # 10 # G(platform) - User selected platform. 11 # G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only". 12 # G(keep) - Boolean. True to delete no files after each test. 13 # G(msvc) - Boolean. True to use MSVC as the compiler. 14 # G(tcl) - Use Tcl from this directory for builds. 15 # G(jobs) - How many sub-processes to run simultaneously. 16 # 17 set G(platform) $::tcl_platform(os)-$::tcl_platform(machine) 18 set G(test) Normal 19 set G(keep) 1 20 set G(msvc) 0 21 set G(tcl) [::tcl::pkgconfig get libdir,install] 22 set G(jobs) 3 23 set G(debug) 0 24 25 set G(noui) 0 26 set G(stdout) 0 27 28 29 proc wapptest_init {} { 30 global G 31 32 set lSave [list platform test keep msvc tcl jobs debug noui stdout] 33 foreach k $lSave { set A($k) $G($k) } 34 array unset G 35 foreach k $lSave { set G($k) $A($k) } 36 37 # The root of the SQLite source tree. 38 set G(srcdir) [file dirname [file dirname [info script]]] 39 40 set G(sqlite_version) "unknown" 41 42 # Either "config", "running" or "stopped": 43 set G(state) "config" 44 45 set G(hostname) "(unknown host)" 46 catch { set G(hostname) [exec hostname] } 47 set G(host) $G(hostname) 48 append G(host) " $::tcl_platform(os) $::tcl_platform(osVersion)" 49 append G(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)" 50 } 51 52 proc wapptest_run {} { 53 global G 54 set_test_array 55 set G(state) "running" 56 57 wapptest_openlog 58 59 wapptest_output "Running the following for $G(platform). $G(jobs) jobs." 60 foreach t $G(test_array) { 61 set config [dict get $t config] 62 set target [dict get $t target] 63 wapptest_output [format " %-25s%s" $config $target] 64 } 65 wapptest_output [string repeat * 70] 66 } 67 68 proc releasetest_data {args} { 69 global G 70 set rtd [file join $G(srcdir) test releasetest_data.tcl] 71 set fd [open "|[info nameofexecutable] $rtd $args" r+] 72 set ret [read $fd] 73 close $fd 74 return $ret 75 } 76 77 # Generate the text for the box at the top of the UI. The current SQLite 78 # version, according to fossil, along with a warning if there are 79 # uncommitted changes in the checkout. 80 # 81 proc generate_fossil_info {} { 82 global G 83 set pwd [pwd] 84 cd $G(srcdir) 85 set rc [catch { 86 set r1 [exec fossil info] 87 set r2 [exec fossil changes] 88 }] 89 cd $pwd 90 if {$rc} return 91 92 foreach line [split $r1 "\n"] { 93 if {[regexp {^checkout: *(.*)$} $line -> co]} { 94 wapp-trim { <br> %html($co) } 95 } 96 } 97 98 if {[string trim $r2]!=""} { 99 wapp-trim { 100 <br><span class=warning> 101 WARNING: Uncommitted changes in checkout 102 </span> 103 } 104 } 105 } 106 107 # If the application is in "config" state, set the contents of the 108 # ::G(test_array) global to reflect the tests that will be run. If the 109 # app is in some other state ("running" or "stopped"), this command 110 # is a no-op. 111 # 112 proc set_test_array {} { 113 global G 114 if { $G(state)=="config" } { 115 set G(test_array) [list] 116 set debug "-debug" 117 if {$G(debug)==0} { set debug "-nodebug"} 118 foreach {config target} [releasetest_data tests $debug $G(platform)] { 119 120 # If using MSVC, do not run sanitize or valgrind tests. Or the 121 # checksymbols test. 122 if {$G(msvc) && ( 123 "Sanitize" == $config 124 || "checksymbols" in $target 125 || "valgrindtest" in $target 126 )} { 127 continue 128 } 129 130 # If the test mode is not "Normal", override the target. 131 # 132 if {$target!="checksymbols" && $G(platform)!="Failure-Detection"} { 133 switch -- $G(test) { 134 Veryquick { set target quicktest } 135 Smoketest { set target smoketest } 136 Build-Only { 137 set target testfixture 138 if {$::tcl_platform(platform)=="windows"} { 139 set target testfixture.exe 140 } 141 } 142 } 143 } 144 145 lappend G(test_array) [dict create config $config target $target] 146 } 147 } 148 } 149 150 proc count_tests_and_errors {name logfile} { 151 global G 152 153 set fd [open $logfile rb] 154 set seen 0 155 while {![eof $fd]} { 156 set line [gets $fd] 157 if {[regexp {(\d+) errors out of (\d+) tests} $line all nerr ntest]} { 158 incr G(test.$name.nError) $nerr 159 incr G(test.$name.nTest) $ntest 160 set seen 1 161 if {$nerr>0} { 162 set G(test.$name.errmsg) $line 163 } 164 } 165 if {[regexp {runtime error: +(.*)} $line all msg]} { 166 # skip over "value is outside range" errors 167 if {[regexp {.* is outside the range of representable} $line]} { 168 # noop 169 } else { 170 incr G(test.$name.nError) 171 if {$G(test.$name.errmsg)==""} { 172 set G(test.$name.errmsg) $msg 173 } 174 } 175 } 176 if {[regexp {fatal error +(.*)} $line all msg]} { 177 incr G(test.$name.nError) 178 if {$G(test.$name.errmsg)==""} { 179 set G(test.$name.errmsg) $msg 180 } 181 } 182 if {[regexp {ERROR SUMMARY: (\d+) errors.*} $line all cnt] && $cnt>0} { 183 incr G(test.$name.nError) 184 if {$G(test.$name.errmsg)==""} { 185 set G(test.$name.errmsg) $all 186 } 187 } 188 if {[regexp {^VERSION: 3\.\d+.\d+} $line]} { 189 set v [string range $line 9 end] 190 if {$G(sqlite_version) eq "unknown"} { 191 set G(sqlite_version) $v 192 } elseif {$G(sqlite_version) ne $v} { 193 set G(test.$name.errmsg) "version conflict: {$G(sqlite_version)} vs. {$v}" 194 } 195 } 196 } 197 close $fd 198 if {$G(test) == "Build-Only"} { 199 incr G(test.$name.nTest) 200 if {$G(test.$name.nError)>0} { 201 set errmsg "Build failed" 202 } 203 } elseif {!$seen} { 204 set G(test.$name.errmsg) "Test did not complete" 205 if {[file readable core]} { 206 append G(test.$name.errmsg) " - core file exists" 207 } 208 } 209 } 210 211 proc wapptest_output {str} { 212 global G 213 if {$G(stdout)} { puts $str } 214 if {[info exists G(log)]} { 215 puts $G(log) $str 216 flush $G(log) 217 } 218 } 219 proc wapptest_openlog {} { 220 global G 221 set G(log) [open wapptest-out.txt w+] 222 } 223 proc wapptest_closelog {} { 224 global G 225 close $G(log) 226 unset G(log) 227 } 228 229 proc format_seconds {seconds} { 230 set min [format %.2d [expr ($seconds / 60) % 60]] 231 set hr [format %.2d [expr $seconds / 3600]] 232 set sec [format %.2d [expr $seconds % 60]] 233 return "$hr:$min:$sec" 234 } 235 236 # This command is invoked once a slave process has finished running its 237 # tests, successfully or otherwise. Parameter $name is the name of the 238 # test, $rc the exit code returned by the slave process. 239 # 240 proc slave_test_done {name rc} { 241 global G 242 set G(test.$name.done) [clock seconds] 243 set G(test.$name.nError) 0 244 set G(test.$name.nTest) 0 245 set G(test.$name.errmsg) "" 246 if {$rc} { 247 incr G(test.$name.nError) 248 } 249 if {[file exists $G(test.$name.log)]} { 250 count_tests_and_errors $name $G(test.$name.log) 251 } 252 253 # If the "keep files" checkbox is clear, delete all files except for 254 # the executables and test logs. And any core file that is present. 255 if {$G(keep)==0} { 256 set keeplist { 257 testfixture testfixture.exe 258 sqlite3 sqlite3.exe 259 test.log test-out.txt 260 core 261 wapptest_make.sh 262 wapptest_configure.sh 263 wapptest_run.tcl 264 } 265 foreach f [glob -nocomplain [file join $G(test.$name.dir) *]] { 266 set t [file tail $f] 267 if {[lsearch $keeplist $t]<0} { 268 catch { file delete -force $f } 269 } 270 } 271 } 272 273 # Format a message regarding the success or failure of hte test. 274 set t [format_seconds [expr $G(test.$name.done) - $G(test.$name.start)]] 275 set res "OK" 276 if {$G(test.$name.nError)} { set res "FAILED" } 277 set dots [string repeat . [expr 60 - [string length $name]]] 278 set msg "$name $dots $res ($t)" 279 280 wapptest_output $msg 281 if {[info exists G(test.$name.errmsg)] && $G(test.$name.errmsg)!=""} { 282 wapptest_output " $G(test.$name.errmsg)" 283 } 284 } 285 286 # This is a fileevent callback invoked each time a file-descriptor that 287 # connects this process to a slave process is readable. 288 # 289 proc slave_fileevent {name} { 290 global G 291 set fd $G(test.$name.channel) 292 293 if {[eof $fd]} { 294 fconfigure $fd -blocking 1 295 set rc [catch { close $fd }] 296 unset G(test.$name.channel) 297 slave_test_done $name $rc 298 } else { 299 set line [gets $fd] 300 if {[string trim $line] != ""} { puts "Trace : $name - \"$line\"" } 301 } 302 303 do_some_stuff 304 } 305 306 # Return the contents of the "slave script" - the script run by slave 307 # processes to actually perform the test. All it does is execute the 308 # test script already written to disk (wapptest_cmd.sh or wapptest_cmd.bat). 309 # 310 proc wapptest_slave_script {} { 311 global G 312 if {$G(msvc)==0} { 313 set dir [file join .. $G(srcdir)] 314 set res [subst -nocommands { 315 set rc [catch "exec sh wapptest_cmd.sh {$dir} >>& test.log" ] 316 exit [set rc] 317 }] 318 } else { 319 set dir [file nativename [file normalize $G(srcdir)]] 320 set dir [string map [list "\\" "\\\\"] $dir] 321 set res [subst -nocommands { 322 set rc [catch "exec wapptest_cmd.bat {$dir} >>& test.log" ] 323 exit [set rc] 324 }] 325 } 326 327 set res 328 } 329 330 331 # Launch a slave process to run a test. 332 # 333 proc slave_launch {name target dir} { 334 global G 335 336 catch { file mkdir $dir } msg 337 foreach f [glob -nocomplain [file join $dir *]] { 338 catch { file delete -force $f } 339 } 340 set G(test.$name.dir) $dir 341 342 # Write the test command to wapptest_cmd.sh|bat. 343 # 344 set ext sh 345 if {$G(msvc)} { set ext bat } 346 set fd1 [open [file join $dir wapptest_cmd.$ext] w] 347 if {$G(msvc)} { 348 puts $fd1 [releasetest_data script -msvc $name $target] 349 } else { 350 puts $fd1 [releasetest_data script $name $target] 351 } 352 close $fd1 353 354 # Write the wapptest_run.tcl script to the test directory. To run the 355 # commands in the other two files. 356 # 357 set fd3 [open [file join $dir wapptest_run.tcl] w] 358 puts $fd3 [wapptest_slave_script] 359 close $fd3 360 361 set pwd [pwd] 362 cd $dir 363 set fd [open "|[info nameofexecutable] wapptest_run.tcl" r+] 364 cd $pwd 365 366 set G(test.$name.channel) $fd 367 fconfigure $fd -blocking 0 368 fileevent $fd readable [list slave_fileevent $name] 369 } 370 371 proc do_some_stuff {} { 372 global G 373 374 # Count the number of running jobs. A running job has an entry named 375 # "channel" in its dictionary. 376 set nRunning 0 377 set bFinished 1 378 foreach j $G(test_array) { 379 set name [dict get $j config] 380 if { [info exists G(test.$name.channel)]} { incr nRunning } 381 if {![info exists G(test.$name.done)]} { set bFinished 0 } 382 } 383 384 if {$bFinished} { 385 set nError 0 386 set nTest 0 387 set nConfig 0 388 foreach j $G(test_array) { 389 set name [dict get $j config] 390 incr nError $G(test.$name.nError) 391 incr nTest $G(test.$name.nTest) 392 incr nConfig 393 } 394 set G(result) "$nError errors from $nTest tests in $nConfig configurations." 395 wapptest_output [string repeat * 70] 396 wapptest_output $G(result) 397 catch { 398 append G(result) " SQLite version $G(sqlite_version)" 399 wapptest_output " SQLite version $G(sqlite_version)" 400 } 401 set G(state) "stopped" 402 wapptest_closelog 403 if {$G(noui)} { exit 0 } 404 } else { 405 set nLaunch [expr $G(jobs) - $nRunning] 406 foreach j $G(test_array) { 407 if {$nLaunch<=0} break 408 set name [dict get $j config] 409 if { ![info exists G(test.$name.channel)] 410 && ![info exists G(test.$name.done)] 411 } { 412 413 set target [dict get $j target] 414 set dir [string tolower [string map {" " _ "-" _} $name]] 415 set G(test.$name.start) [clock seconds] 416 set G(test.$name.log) [file join $dir test.log] 417 418 slave_launch $name $target $dir 419 420 incr nLaunch -1 421 } 422 } 423 } 424 } 425 426 proc generate_select_widget {label id lOpt opt} { 427 wapp-trim { 428 <label> %string($label) </label> 429 <select id=%string($id) name=%string($id)> 430 } 431 foreach o $lOpt { 432 set selected "" 433 if {$o==$opt} { set selected " selected=1" } 434 wapp-subst "<option $selected>$o</option>" 435 } 436 wapp-trim { </select> } 437 } 438 439 proc generate_main_page {{extra {}}} { 440 global G 441 set_test_array 442 443 set hostname $G(hostname) 444 wapp-trim { 445 <html> 446 <head> 447 <title> %html($hostname): wapptest.tcl </title> 448 <link rel="stylesheet" type="text/css" href="style.css"/> 449 </head> 450 <body> 451 } 452 453 set host $G(host) 454 wapp-trim { 455 <div class="border">%string($host) 456 } 457 generate_fossil_info 458 wapp-trim { 459 </div> 460 <div class="border" id=controls> 461 <form action="control" method="post" name="control"> 462 } 463 464 # Build the "platform" select widget. 465 set lOpt [releasetest_data platforms] 466 generate_select_widget Platform control_platform $lOpt $G(platform) 467 468 # Build the "test" select widget. 469 set lOpt [list Normal Veryquick Smoketest Build-Only] 470 generate_select_widget Test control_test $lOpt $G(test) 471 472 # Build the "jobs" select widget. Options are 1 to 8. 473 generate_select_widget Jobs control_jobs {1 2 3 4 5 6 7 8} $G(jobs) 474 475 switch $G(state) { 476 config { 477 set txt "Run Tests!" 478 set id control_run 479 } 480 running { 481 set txt "STOP Tests!" 482 set id control_stop 483 } 484 stopped { 485 set txt "Reset!" 486 set id control_reset 487 } 488 } 489 wapp-trim { 490 <div class=right> 491 <input id=%string($id) name=%string($id) type=submit value="%string($txt)"> 492 </input> 493 </div> 494 } 495 496 wapp-trim { 497 <br><br> 498 <label> Tcl: </label> 499 <input id="control_tcl" name="control_tcl"></input> 500 <label> Keep files: </label> 501 <input id="control_keep" name="control_keep" type=checkbox value=1> 502 </input> 503 <label> Use MSVC: </label> 504 <input id="control_msvc" name="control_msvc" type=checkbox value=1> 505 <label> Debug tests: </label> 506 <input id="control_debug" name="control_debug" type=checkbox value=1> 507 </input> 508 } 509 wapp-trim { 510 </form> 511 } 512 wapp-trim { 513 </div> 514 <div id=tests> 515 } 516 wapp-page-tests 517 518 set script "script/$G(state).js" 519 wapp-trim { 520 </div> 521 <script src=%string($script)></script> 522 </body> 523 </html> 524 } 525 } 526 527 proc wapp-default {} { 528 generate_main_page 529 } 530 531 proc wapp-page-tests {} { 532 global G 533 wapp-trim { <table class="border" width=100%> } 534 foreach t $G(test_array) { 535 set config [dict get $t config] 536 set target [dict get $t target] 537 538 set class "testwait" 539 set seconds "" 540 541 if {[info exists G(test.$config.log)]} { 542 if {[info exists G(test.$config.channel)]} { 543 set class "testrunning" 544 set seconds [expr [clock seconds] - $G(test.$config.start)] 545 } elseif {[info exists G(test.$config.done)]} { 546 if {$G(test.$config.nError)>0} { 547 set class "testfail" 548 } else { 549 set class "testdone" 550 } 551 set seconds [expr $G(test.$config.done) - $G(test.$config.start)] 552 } 553 set seconds [format_seconds $seconds] 554 } 555 556 wapp-trim { 557 <tr class=%string($class)> 558 <td class="nowrap"> %html($config) 559 <td class="padleft nowrap"> %html($target) 560 <td class="padleft nowrap"> %html($seconds) 561 <td class="padleft nowrap"> 562 } 563 if {[info exists G(test.$config.log)]} { 564 set log $G(test.$config.log) 565 set uri "log/$log" 566 wapp-trim { 567 <a href=%url($uri)> %html($log) </a> 568 } 569 } 570 if {[info exists G(test.$config.errmsg)] && $G(test.$config.errmsg)!=""} { 571 set errmsg $G(test.$config.errmsg) 572 wapp-trim { 573 <tr class=testfail> 574 <td> <td class="padleft" colspan=3> %html($errmsg) 575 } 576 } 577 } 578 579 wapp-trim { </table> } 580 581 if {[info exists G(result)]} { 582 set res $G(result) 583 wapp-trim { 584 <div class=border id=result> %string($res) </div> 585 } 586 } 587 } 588 589 # URI: /control 590 # 591 # Whenever the form at the top of the application page is submitted, it 592 # is submitted here. 593 # 594 proc wapp-page-control {} { 595 global G 596 if {$::G(state)=="config"} { 597 set lControls [list platform test tcl jobs keep msvc debug] 598 set G(msvc) 0 599 set G(keep) 0 600 set G(debug) 0 601 } else { 602 set lControls [list jobs] 603 } 604 foreach v $lControls { 605 if {[wapp-param-exists control_$v]} { 606 set G($v) [wapp-param control_$v] 607 } 608 } 609 610 if {[wapp-param-exists control_run]} { 611 # This is a "run test" command. 612 wapptest_run 613 } 614 615 if {[wapp-param-exists control_stop]} { 616 # A "STOP tests" command. 617 set G(state) "stopped" 618 set G(result) "Test halted by user" 619 foreach j $G(test_array) { 620 set name [dict get $j config] 621 if { [info exists G(test.$name.channel)] } { 622 close $G(test.$name.channel) 623 unset G(test.$name.channel) 624 slave_test_done $name 1 625 } 626 } 627 wapptest_closelog 628 } 629 630 if {[wapp-param-exists control_reset]} { 631 # A "reset app" command. 632 set G(state) "config" 633 wapptest_init 634 } 635 636 if {$::G(state) == "running"} { 637 do_some_stuff 638 } 639 wapp-redirect / 640 } 641 642 # URI: /style.css 643 # 644 # Return the stylesheet for the application main page. 645 # 646 proc wapp-page-style.css {} { 647 wapp-subst { 648 649 /* The boxes with black borders use this class */ 650 .border { 651 border: 3px groove #444444; 652 padding: 1em; 653 margin-top: 1em; 654 margin-bottom: 1em; 655 } 656 657 /* Float to the right (used for the Run/Stop/Reset button) */ 658 .right { float: right; } 659 660 /* Style for the large red warning at the top of the page */ 661 .warning { 662 color: red; 663 font-weight: bold; 664 } 665 666 /* Styles used by cells in the test table */ 667 .padleft { padding-left: 5ex; } 668 .nowrap { white-space: nowrap; } 669 670 /* Styles for individual tests, depending on the outcome */ 671 .testwait { } 672 .testrunning { color: blue } 673 .testdone { color: green } 674 .testfail { color: red } 675 } 676 } 677 678 # URI: /script/${state}.js 679 # 680 # The last part of this URI is always "config.js", "running.js" or 681 # "stopped.js", depending on the state of the application. It returns 682 # the javascript part of the front-end for the requested state to the 683 # browser. 684 # 685 proc wapp-page-script {} { 686 regexp {[^/]*$} [wapp-param REQUEST_URI] script 687 688 set tcl $::G(tcl) 689 set keep $::G(keep) 690 set msvc $::G(msvc) 691 set debug $::G(debug) 692 693 wapp-subst { 694 var lElem = \["control_platform", "control_test", "control_msvc", 695 "control_jobs", "control_debug" 696 \]; 697 lElem.forEach(function(e) { 698 var elem = document.getElementById(e); 699 elem.addEventListener("change", function() { control.submit() } ); 700 }) 701 702 elem = document.getElementById("control_tcl"); 703 elem.value = "%string($tcl)" 704 705 elem = document.getElementById("control_keep"); 706 elem.checked = %string($keep); 707 708 elem = document.getElementById("control_msvc"); 709 elem.checked = %string($msvc); 710 711 elem = document.getElementById("control_debug"); 712 elem.checked = %string($debug); 713 } 714 715 if {$script != "config.js"} { 716 wapp-subst { 717 var lElem = \["control_platform", "control_test", 718 "control_tcl", "control_keep", "control_msvc", 719 "control_debug" 720 \]; 721 lElem.forEach(function(e) { 722 var elem = document.getElementById(e); 723 elem.disabled = true; 724 }) 725 } 726 } 727 728 if {$script == "running.js"} { 729 wapp-subst { 730 function reload_tests() { 731 fetch('tests') 732 .then( data => data.text() ) 733 .then( data => { 734 document.getElementById("tests").innerHTML = data; 735 }) 736 .then( data => { 737 if( document.getElementById("result") ){ 738 document.location = document.location; 739 } else { 740 setTimeout(reload_tests, 1000) 741 } 742 }); 743 } 744 745 setTimeout(reload_tests, 1000) 746 } 747 } 748 } 749 750 # URI: /env 751 # 752 # This is for debugging only. Serves no other purpose. 753 # 754 proc wapp-page-env {} { 755 wapp-allow-xorigin-params 756 wapp-trim { 757 <h1>Wapp Environment</h1>\n<pre> 758 <pre>%html([wapp-debug-env])</pre> 759 } 760 } 761 762 # URI: /log/dirname/test.log 763 # 764 # This URI reads file "dirname/test.log" from disk, wraps it in a <pre> 765 # block, and returns it to the browser. Use for viewing log files. 766 # 767 proc wapp-page-log {} { 768 set log [string range [wapp-param REQUEST_URI] 5 end] 769 set fd [open $log] 770 set data [read $fd] 771 close $fd 772 wapp-trim { 773 <pre> 774 %html($data) 775 </pre> 776 } 777 } 778 779 # Print out a usage message. Then do [exit 1]. 780 # 781 proc wapptest_usage {} { 782 puts stderr { 783 This Tcl script is used to test various configurations of SQLite. By 784 default it uses "wapp" to provide an interactive interface. Supported 785 command line options (all optional) are: 786 787 --platform PLATFORM (which tests to run) 788 --smoketest (run "make smoketest" only) 789 --veryquick (run veryquick.test only) 790 --buildonly (build executables, do not run tests) 791 --jobs N (number of concurrent jobs) 792 --tcl DIR (where to find tclConfig.sh) 793 --deletefiles (delete extra files after each test) 794 --msvc (Use MS Visual C) 795 --debug (Also run [n]debugging versions of tests) 796 --noui (do not use wapp) 797 } 798 exit 1 799 } 800 801 # Sort command line arguments into two groups: those that belong to wapp, 802 # and those that belong to the application. 803 set WAPPARG(-server) 1 804 set WAPPARG(-local) 1 805 set WAPPARG(-scgi) 1 806 set WAPPARG(-remote-scgi) 1 807 set WAPPARG(-fromip) 1 808 set WAPPARG(-nowait) 0 809 set WAPPARG(-cgi) 0 810 set lWappArg [list] 811 set lTestArg [list] 812 for {set i 0} {$i < [llength $argv]} {incr i} { 813 set arg [lindex $argv $i] 814 if {[string range $arg 0 1]=="--"} { 815 set arg [string range $arg 1 end] 816 } 817 if {[info exists WAPPARG($arg)]} { 818 lappend lWappArg $arg 819 if {$WAPPARG($arg)} { 820 incr i 821 lappend lWappArg [lindex $argv $i] 822 } 823 } else { 824 lappend lTestArg $arg 825 } 826 } 827 828 wapptest_init 829 for {set i 0} {$i < [llength $lTestArg]} {incr i} { 830 set opt [lindex $lTestArg $i] 831 if {[string range $opt 0 1]=="--"} { 832 set opt [string range $opt 1 end] 833 } 834 switch -- $opt { 835 -platform { 836 if {$i==[llength $lTestArg]-1} { wapptest_usage } 837 incr i 838 set arg [lindex $lTestArg $i] 839 set lPlatform [releasetest_data platforms] 840 if {[lsearch $lPlatform $arg]<0} { 841 puts stderr "No such platform: $arg. Platforms are: $lPlatform" 842 exit -1 843 } 844 set G(platform) $arg 845 } 846 847 -smoketest { set G(test) Smoketest } 848 -veryquick { set G(test) Veryquick } 849 -buildonly { set G(test) Build-Only } 850 -jobs { 851 if {$i==[llength $lTestArg]-1} { wapptest_usage } 852 incr i 853 set G(jobs) [lindex $lTestArg $i] 854 } 855 856 -tcl { 857 if {$i==[llength $lTestArg]-1} { wapptest_usage } 858 incr i 859 set G(tcl) [lindex $lTestArg $i] 860 } 861 862 -deletefiles { 863 set G(keep) 0 864 } 865 866 -msvc { 867 set G(msvc) 1 868 } 869 870 -debug { 871 set G(debug) 1 872 } 873 874 -noui { 875 set G(noui) 1 876 set G(stdout) 1 877 } 878 879 -stdout { 880 set G(stdout) 1 881 } 882 883 default { 884 puts stderr "Unrecognized option: [lindex $lTestArg $i]" 885 wapptest_usage 886 } 887 } 888 } 889 890 if {$G(noui)==0} { 891 wapp-start $lWappArg 892 } else { 893 wapptest_run 894 do_some_stuff 895 vwait forever 896 }