3 exec wapptclsh
"$0" ${1+"$@"}
5 # package required wapp
6 source [file join [file dirname [info
script]] wapp.tcl
]
8 # Read the data from the releasetest_data.tcl script.
10 source [file join [file dirname [info
script]] releasetest_data.tcl
]
12 # Variables set by the "control" form:
14 # G(platform) - User selected platform.
15 # G(test) - Set to "Normal", "Veryquick", "Smoketest" or "Build-Only".
16 # G(keep) - Boolean. True to delete no files after each test.
17 # G(msvc) - Boolean. True to use MSVC as the compiler.
18 # G(tcl) - Use Tcl from this directory for builds.
19 # G(jobs) - How many sub-processes to run simultaneously.
21 set G
(platform
) $
::tcl_platform
(os
)-$
::tcl_platform
(machine
)
25 set G
(tcl
) [::tcl
::pkgconfig get libdir
,install]
29 proc wapptest_init
{} {
32 set lSave
[list platform
test keep msvc tcl
jobs debug
]
33 foreach k
$lSave { set A
($k) $G($k) }
35 foreach k
$lSave { set G
($k) $A($k) }
37 # The root of the SQLite source tree.
38 set G
(srcdir
) [file dirname [file dirname [info
script]]]
40 # releasetest.tcl script
41 set G
(releaseTest
) [file join [file dirname [info
script]] releasetest.tcl
]
43 set G
(sqlite_version
) "unknown"
45 # Either "config", "running" or "stopped":
48 set G
(hostname
) "(unknown host)"
49 catch
{ set G
(hostname
) [exec hostname
] }
50 set G
(host) $G(hostname
)
51 append G
(host) " $::tcl_platform(os) $::tcl_platform(osVersion)"
52 append G
(host) " $::tcl_platform(machine) $::tcl_platform(byteOrder)"
55 # Check to see if there are uncommitted changes in the SQLite source
56 # directory. Return true if there are, or false otherwise.
58 proc check_uncommitted
{} {
63 if {[catch
{exec fossil changes
} res
]==0 && [string trim
$res]!=""} {
70 proc generate_fossil_info
{} {
74 if {[catch
{exec fossil info
} r1
]} return
75 if {[catch
{exec fossil changes
} r2
]} return
78 foreach line
[split $r1 "\n"] {
79 if {[regexp
{^checkout
: *(.
*)$
} $line -> co
]} {
80 wapp-trim
{ <br
> %html
($co) }
84 if {[string trim
$r2]!=""} {
86 <br
><span class
=warning
>
87 WARNING
: Uncommitted changes
in checkout
93 # If the application is in "config" state, set the contents of the
94 # ::G(test_array) global to reflect the tests that will be run. If the
95 # app is in some other state ("running" or "stopped"), this command
98 proc set_test_array
{} {
100 if { $G(state
)=="config" } {
101 set G
(test_array
) [list
]
102 foreach
{config target
} $
::Platforms
($G(platform
)) {
104 # If using MSVC, do not run sanitize or valgrind tests. Or the
107 "Sanitize" == $config
108 ||
"checksymbols" in $target
109 ||
"valgrindtest" in $target
114 # If the test mode is not "Normal", override the target.
116 if {$target!="checksymbols" && $G(platform
)!="Failure-Detection"} {
118 Veryquick
{ set target quicktest
}
119 Smoketest
{ set target smoketest
}
121 set target testfixture
122 if {$
::tcl_platform
(platform
)=="windows"} {
123 set target testfixture.exe
129 lappend G
(test_array
) [dict create config
$config target
$target]
131 set exclude
[list checksymbols valgrindtest fuzzoomtest
]
132 if {$G(debug
) && !($target in $exclude)} {
133 set debug_idx
[lsearch
-glob $
::Configs
($config) -DSQLITE_DEBUG*]
135 regsub
-all {fulltest
[a-z
]*} $xtarget test xtarget
137 lappend G
(test_array
) [
138 dict create config
$config-(Debug
) target
$xtarget
141 lappend G
(test_array
) [
142 dict create config
$config-(NDebug
) target
$xtarget
150 proc count_tests_and_errors
{name logfile
} {
153 set fd
[open
$logfile rb
]
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
162 set G
(test.
$name.errmsg
) $line
165 if {[regexp
{runtime error
: +(.
*)} $line all msg
]} {
166 # skip over "value is outside range" errors
167 if {[regexp
{value .
* is outside the range of representable
} $line]} {
170 incr G
(test.
$name.nError
)
171 if {$G(test.
$name.errmsg
)==""} {
172 set G
(test.
$name.errmsg
) $msg
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
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
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}"
198 if {$G(test) == "Build-Only"} {
199 incr G
(test.
$name.nTest
)
200 if {$G(test.
$name.nError
)>0} {
201 set errmsg
"Build failed"
204 set G
(test.
$name.errmsg
) "Test did not complete"
205 if {[file readable core
]} {
206 append G
(test.
$name.errmsg
) " - core file exists"
211 proc slave_test_done
{name rc
} {
213 set G
(test.
$name.
done) [clock seconds
]
214 set G
(test.
$name.nError
) 0
215 set G
(test.
$name.nTest
) 0
216 set G
(test.
$name.errmsg
) ""
218 incr G
(test.
$name.nError
)
220 if {[file exists
$G(test.
$name.log
)]} {
221 count_tests_and_errors
$name $G(test.
$name.log
)
225 proc slave_fileevent
{name
} {
227 set fd
$G(test.
$name.channel
)
230 fconfigure
$fd -blocking 1
231 set rc
[catch
{ close
$fd }]
232 unset G
(test.
$name.channel
)
233 slave_test_done
$name $rc
236 if {[string trim
$line] != ""} { puts
"Trace : $name - \"$line\"" }
242 proc do_some_stuff
{} {
245 # Count the number of running jobs. A running job has an entry named
246 # "channel" in its dictionary.
249 foreach j
$G(test_array
) {
250 set name
[dict get
$j config
]
251 if { [info exists G
(test.
$name.channel
)]} { incr nRunning
}
252 if {![info exists G
(test.
$name.
done)]} { set bFinished
0 }
259 foreach j
$G(test_array
) {
260 set name
[dict get
$j config
]
261 incr nError
$G(test.
$name.nError
)
262 incr nTest
$G(test.
$name.nTest
)
265 set G
(result
) "$nError errors from $nTest tests in $nConfig configurations."
267 append G
(result
) " SQLite version $G(sqlite_version)"
269 set G
(state
) "stopped"
271 set nLaunch
[expr $G(jobs) - $nRunning]
272 foreach j
$G(test_array
) {
273 if {$nLaunch<=0} break
274 set name
[dict get
$j config
]
275 if { ![info exists G
(test.
$name.channel
)]
276 && ![info exists G
(test.
$name.
done)]
278 set target
[dict get
$j target
]
279 set G
(test.
$name.start
) [clock seconds
]
280 set fd
[open
"|[info nameofexecutable] $G(releaseTest) --slave" r
+]
281 set G
(test.
$name.channel
) $fd
282 fconfigure
$fd -blocking 0
283 fileevent
$fd readable
[list slave_fileevent
$name]
285 puts
$fd [list
0 $G(msvc
) 0 $G(keep
)]
288 if {$G(tcl
)!=""} { set wtcl
"--with-tcl=$G(tcl)" }
290 # If this configuration is named <name>-(Debug) or <name>-(NDebug),
291 # then add or remove the SQLITE_DEBUG option from the base
292 # configuration before running the test.
293 if {[regexp
-- {(.
*)-(\
(.
*\
))} $name -> head tail]} {
294 set opts $
::Configs
($head)
295 if {$tail=="(Debug)"} {
296 append opts
" -DSQLITE_DEBUG=1 -DSQLITE_EXTRA_IFNULLROW=1"
298 regsub
{ *-DSQLITE_MEMDEBUG[^
]* *} $opts { } opts
299 regsub
{ *-DSQLITE_DEBUG[^
]* *} $opts { } opts
302 set opts $
::Configs
($name)
305 set L
[make_test_suite
$G(msvc
) $wtcl $name $target $opts]
308 set G
(test.
$name.log
) [file join [lindex
$L 1] test.log
]
315 proc generate_select_widget
{label id lOpt opt
} {
317 <label
> %string
($label) </label
>
318 <select id
=%string
($id) name
=%string
($id)>
322 if {$o==$opt} { set selected
" selected=1" }
323 wapp-subst
"<option $selected>$o</option>"
325 wapp-trim
{ </select> }
328 proc generate_main_page
{{extra
{}}} {
332 set hostname
$G(hostname
)
336 <title
> %html
($hostname): wapptest.tcl
</title
>
337 <link rel
="stylesheet" type="text/css" href
="style.css"/>
344 <div class
="border">%string
($host)
349 <div class
="border" id
=controls
>
350 <form action
="control" method
="post" name
="control">
353 # Build the "platform" select widget.
354 set lOpt
[array names
::Platforms
]
355 generate_select_widget Platform control_platform
$lOpt $G(platform
)
357 # Build the "test" select widget.
358 set lOpt
[list Normal Veryquick Smoketest Build-Only
]
359 generate_select_widget Test control_test
$lOpt $G(test)
361 # Build the "jobs" select widget. Options are 1 to 8.
362 generate_select_widget Jobs control_jobs
{1 2 3 4 5 6 7 8} $G(jobs)
370 set txt
"STOP Tests!"
380 <input id
=%string
($id) name
=%string
($id) type=submit value
="%string($txt)">
387 <label
> Tcl
: </label
>
388 <input id
="control_tcl" name
="control_tcl"></input
>
389 <label
> Keep files
: </label
>
390 <input id
="control_keep" name
="control_keep" type=checkbox value
=1>
392 <label
> Use MSVC
: </label
>
393 <input id
="control_msvc" name
="control_msvc" type=checkbox value
=1>
394 <label
> Debug tests
: </label
>
395 <input id
="control_debug" name
="control_debug" type=checkbox value
=1>
407 set script "script/$G(state).js"
410 <script src
=%string
($script)></script>
416 proc wapp-default
{} {
420 proc wapp-page-tests
{} {
422 wapp-trim
{ <table class
="border" width
=100%> }
423 foreach t
$G(test_array
) {
424 set config
[dict get
$t config
]
425 set target
[dict get
$t target
]
430 if {[info exists G
(test.
$config.log
)]} {
431 if {[info exists G
(test.
$config.channel
)]} {
432 set class
"testrunning"
433 set seconds
[expr [clock seconds
] - $G(test.
$config.start
)]
434 } elseif
{[info exists G
(test.
$config.
done)]} {
435 if {$G(test.
$config.nError
)>0} {
440 set seconds
[expr $G(test.
$config.
done) - $G(test.
$config.start
)]
443 set min
[format
%.2d
[expr ($seconds / 60) % 60]]
444 set hr
[format
%.2d
[expr $seconds / 3600]]
445 set sec
[format
%.2d
[expr $seconds % 60]]
446 set seconds
"$hr:$min:$sec"
450 <tr class
=%string
($class)>
451 <td class
="nowrap"> %html
($config)
452 <td class
="padleft nowrap"> %html
($target)
453 <td class
="padleft nowrap"> %html
($seconds)
454 <td class
="padleft nowrap">
456 if {[info exists G
(test.
$config.log
)]} {
457 set log
$G(test.
$config.log
)
460 <a href
=%url
($uri)> %html
($log) </a
>
463 if {[info exists G
(test.
$config.errmsg
)] && $G(test.
$config.errmsg
)!=""} {
464 set errmsg
$G(test.
$config.errmsg
)
467 <td
> <td class
="padleft" colspan
=3> %html
($errmsg)
472 wapp-trim
{ </table
> }
474 if {[info exists G
(result
)]} {
477 <div class
=border id
=result
> %string
($res) </div
>
484 # Whenever the form at the top of the application page is submitted, it
487 proc wapp-page-control
{} {
489 if {$
::G
(state
)=="config"} {
490 set lControls
[list platform
test tcl
jobs keep msvc debug
]
495 set lControls
[list
jobs]
497 foreach v
$lControls {
498 if {[wapp-param-exists control_
$v]} {
499 set G
($v) [wapp-param control_
$v]
503 if {[wapp-param-exists control_run
]} {
504 # This is a "run test" command.
506 set ::G
(state
) "running"
509 if {[wapp-param-exists control_stop
]} {
510 # A "STOP tests" command.
511 set G
(state
) "stopped"
512 set G
(result
) "Test halted by user"
513 foreach j
$G(test_array
) {
514 set name
[dict get
$j config
]
515 if { [info exists G
(test.
$name.channel
)] } {
516 close
$G(test.
$name.channel
)
517 unset G
(test.
$name.channel
)
518 slave_test_done
$name 1
523 if {[wapp-param-exists control_reset
]} {
524 # A "reset app" command.
525 set G
(state
) "config"
529 if {$
::G
(state
) == "running"} {
537 # Return the stylesheet for the application main page.
539 proc wapp-page-style.css
{} {
542 /* The boxes with black borders use this class
*/
544 border
: 3px groove
#444444;
550 /* Float to the right
(used
for the Run
/Stop
/Reset button
) */
551 .right
{ float
: right
; }
553 /* Style
for the large red warning
at the top of the page
*/
559 /* Styles used by cells
in the
test table
*/
560 .padleft
{ padding-left
: 5ex
; }
561 .nowrap
{ white-space
: nowrap
; }
563 /* Styles
for individual tests
, depending on the outcome
*/
565 .testrunning
{ color
: blue
}
566 .testdone
{ color
: green
}
567 .testfail
{ color
: red
}
571 # URI: /script/${state}.js
573 # The last part of this URI is always "config.js", "running.js" or
574 # "stopped.js", depending on the state of the application. It returns
575 # the javascript part of the front-end for the requested state to the
578 proc wapp-page-script
{} {
579 regexp
{[^
/]*$
} [wapp-param REQUEST_URI
] script
584 set debug $
::G
(debug
)
587 var lElem
= \
["control_platform", "control_test", "control_msvc",
588 "control_jobs", "control_debug"
590 lElem.forEach
(function(e
) {
591 var elem
= document.getElementById
(e
);
592 elem.addEventListener
("change", function() { control.submit
() } );
595 elem
= document.getElementById
("control_tcl");
596 elem.value
= "%string($tcl)"
598 elem
= document.getElementById
("control_keep");
599 elem.checked
= %string
($keep);
601 elem
= document.getElementById
("control_msvc");
602 elem.checked
= %string
($msvc);
604 elem
= document.getElementById
("control_debug");
605 elem.checked
= %string
($debug);
608 if {$script != "config.js"} {
610 var lElem
= \
["control_platform", "control_test",
611 "control_tcl", "control_keep", "control_msvc",
614 lElem.forEach
(function(e
) {
615 var elem
= document.getElementById
(e
);
616 elem.disabled
= true
;
621 if {$script == "running.js"} {
623 function reload_tests
() {
625 .
then( data
=> data.text
() )
627 document.getElementById
("tests").innerHTML
= data
;
630 if( document.getElementById
("result") ){
631 document.location
= document.location
;
633 setTimeout
(reload_tests
, 1000)
638 setTimeout
(reload_tests
, 1000)
645 # This is for debugging only. Serves no other purpose.
647 proc wapp-page-env
{} {
648 wapp-allow-xorigin-params
650 <h1
>Wapp Environment
</h1
>\n<pre
>
651 <pre
>%html
([wapp-debug-env
])</pre
>
655 # URI: /log/dirname/test.log
657 # This URI reads file "dirname/test.log" from disk, wraps it in a <pre>
658 # block, and returns it to the browser. Use for viewing log files.
660 proc wapp-page-log
{} {
661 set log
[string range
[wapp-param REQUEST_URI
] 5 end
]