1 # Copyright (c) 2012 OPEN CASCADE SAS
3 # The content of this file is subject to the Open CASCADE Technology Public
4 # License Version 6.5 (the "License"). You may not use the content of this file
5 # except in compliance with the License. Please obtain a copy of the License
6 # at http://www.opencascade.org and read it completely before using this file.
8 # The Initial Developer of the Original Code is Open CASCADE S.A.S., having its
9 # main offices at: 1, place des Freres Montgolfier, 78280 Guyancourt, France.
11 # The Original Code and all software distributed under the License is
12 # distributed on an "AS IS" basis, without warranty of any kind, and the
13 # Initial Developer hereby disclaims all such warranties, including without
14 # limitation, any warranties of merchantability, fitness for a particular
15 # purpose or non-infringement. Please see the License for the specific terms
16 # and conditions governing the rights and limitations under the License.
18 ############################################################################
19 # This file defines scripts for execution of OCCT tests.
20 # It should be loaded automatically when DRAW is started, and provides
21 # two top-level commands: 'test' and 'testgrid'.
22 # See OCCT Tests User Guide for description of the test system.
24 # Note: procedures with names starting with underscore are for internal use
25 # inside the test system.
26 ############################################################################
28 # Default verbose level for command _run_test
31 # regexp for parsing test case results in summary log
32 set _test_case_regexp {^CASE\s+([\w.-]+)\s+([\w.-]+)\s+([\w.-]+)\s*:\s*([\w]+)(.*)}
34 # Basic command to run indicated test case in DRAW
35 help test {Run specified test case
36 Use: test group grid casename [verbose_level]
37 Verbose level is 0 by default; can be set to 1 or 2}
38 proc test {group grid casename {verbose {}}} {
40 if { $verbose != "" } {
41 set _tests_verbose $verbose
44 # get test case paths (will raise error if input is invalid)
45 _get_test $group $grid $casename dir gridname casefile
48 uplevel _run_test $dir $group $gridname $casefile
51 _check_log $dir $group $gridname $casename [dlog get]
56 # Basic command to run indicated test case in DRAW
57 help testgrid {Run all tests, or specified group, or one grid
58 Use: testgrid logdir [group [grid]] [options...]
59 Log directory should be empty (or non-existing)
61 -parallel N: run in parallel mode with up to N processes (default 0)
62 -refresh N: save summary logs every N seconds (default 60, minimal 1, 0 to disable)
63 -overwrite: force writing logs in existing non-empty directory
64 -xml filename: write XML report for Jenkins (in JUnit-like format)
66 proc testgrid {logdir args} {
67 global env tcl_platform _tests_verbose
69 ######################################################
71 ######################################################
73 # check that environment variable defining paths to test scripts is defined
74 if { ! [info exists env(CSF_TestScriptsPath)] ||
75 [llength $env(CSF_TestScriptsPath)] <= 0 } {
76 error "Error: Environment variable CSF_TestScriptsPath is not defined"
84 for {set narg 0} {$narg < [llength $args]} {incr narg} {
85 set arg [lindex $args $narg]
88 if { $arg == "-parallel" } {
90 if { $narg < [llength $args] } {
91 set parallel [expr [lindex $args $narg]]
99 if { $arg == "-refresh" } {
101 if { $narg < [llength $args] } {
102 set refresh [expr [lindex $args $narg]]
109 # allow overwrite logs
110 if { $arg == "-overwrite" } {
116 if { $arg == "-xml" } {
118 if { $narg < [llength $args] } {
119 set xmlfile [lindex $args $narg]
121 if { $xmlfile == "" } {
122 set xmlfile TESTS-summary.xml
128 if { [regexp {^-} $arg] } {
129 error "Error: unsupported option \"$arg\""
132 # treat arguments not recognized as options as group and grid names
133 if { ! [info exists groupname] } {
135 } elseif { ! [info exists gridname] } {
138 error "Error: cannot interpret argument $narg ($arg): both group and grid names are already defined by previous args!"
142 # check that target log directory is empty or does not exist
143 set logdir [file normalize [string trim $logdir]]
144 if { $logdir == "" } {
145 # if specified logdir is empty string, generate unique name like "results_2010-12-31T23:59:59"
146 set logdir "results_[clock format [clock seconds] -format {%Y-%m-%dT%H%M}]"
147 set logdir [file normalize $logdir]
149 if { [file isdirectory $logdir] && ! $overwrite && ! [catch {glob -directory $logdir *}] } {
150 error "Error: Specified log directory \"$logdir\" is not empty; please clean it before running tests"
152 if { [catch {file mkdir $logdir}] || ! [file writable $logdir] } {
153 error "Error: Cannot create directory \"$logdir\", or it is not writable"
156 ######################################################
157 # prepare list of tests to be performed
158 ######################################################
160 # list of tests, each defined by a list of:
161 # test scripts directory
162 # group (subfolder) name
163 # grid (subfolder) name
165 # path to test case file
168 # iterate by all script paths
169 foreach dir [_split_path $env(CSF_TestScriptsPath)] {
170 # protection against empty paths
171 set dir [string trim $dir]
172 if { $dir == "" } { continue }
174 if { $_tests_verbose > 0 } { _log_and_puts log "Examining tests directory $dir" }
176 # check that directory exists
177 if { ! [file isdirectory $dir] } {
178 _log_and_puts log "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
182 # if test group is specified, check that directory with given name exists in this dir
183 # if not, continue to the next test dir
184 if { [info exists groupname] && $groupname != "" } {
185 if { [file isdirectory $dir/$groupname] } {
186 set groups $groupname
191 # else search all directories in the current dir
192 if [catch {glob -directory $dir -tail -types d *} groups] { continue }
196 if { $_tests_verbose > 0 } { _log_and_puts log "Groups to be executed: $groups" }
197 foreach group [lsort -dictionary $groups] {
198 if { $_tests_verbose > 0 } { _log_and_puts log "Examining group directory $group" }
200 # file grids.list must exist: it defines sequence of grids in the group
201 if { ! [file exists $dir/$group/grids.list] } {
202 _log_and_puts log "Warning: directory $dir/$group does not contain file grids.list, skipped"
206 # read grids.list file and make a list of grids to be executed
208 set fd [open $dir/$group/grids.list]
210 while { [gets $fd line] >= 0 } {
213 # skip comments and empty lines
214 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
215 if { [string trim $line] == "" } { continue }
217 # get grid id and name
218 if { ! [regexp "^\(\[0-9\]+\)\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridid grid] } {
219 _log_and_puts log "Warning: cannot recognize line $nline in file $dir/$group/grids.list as \"gridid gridname\"; ignored"
223 # if specific grid is requested, check that it is present; otherwise make complete list
224 if { ! [info exists gridname] || $gridname == "" || $gridname == $gridid || $gridname == $grid } {
225 lappend gridlist $grid
230 # iterate by all grids
231 foreach grid $gridlist {
233 # check if this grid is aliased to another one
234 set griddir $dir/$group/$grid
235 if { [file exists $griddir/cases.list] } {
236 set fd [open $griddir/cases.list]
237 if { [gets $fd line] >= 0 } {
238 set griddir [file normalize $dir/$group/$grid/[string trim $line]]
243 # check if grid directory actually exists
244 if { ! [file isdirectory $griddir] } {
245 _log_and_puts log "Error: tests directory for grid $grid ($griddir) is missing; skipped"
249 # create directory for logging test results
250 if { $logdir != "" } { file mkdir $logdir/$group/$grid }
252 # iterate by all tests in the grid directory
253 if { [catch {glob -directory $griddir -type f *} testfiles] } { continue }
254 foreach casefile [lsort -dictionary $testfiles] {
255 # filter out begin and end files
256 set casename [file tail $casefile]
257 if { $casename == "begin" || $casename == "end" } { continue }
259 lappend tests_list [list $dir $group $grid $casename $casefile]
264 if { [llength $tests_list] < 1 } {
265 error "Error: no tests are found, check you input arguments and variable CSF_TestScriptsPath!"
268 ######################################################
270 ######################################################
272 # log command arguments and environment
273 set log "Command: testgrid $args\nHost: [info hostname]\nStarted on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]\n"
274 set log "$log\nEnvironment:\n"
275 foreach envar [array names env] {
276 set log "$log$envar=\"$env($envar)\"\n"
280 set refresh_timer [clock seconds]
281 uplevel dchrono _timer reset
282 uplevel dchrono _timer start
284 # if parallel execution is requested, allocate thread pool
285 if { $parallel > 0 } {
286 if { ! [info exists tcl_platform(threaded)] || [catch {package require Thread}] } {
287 _log_and_puts log "Warning: Tcl package Thread is not available, running in sequential mode"
290 set worker [tpool::create -minworkers $parallel -maxworkers $parallel]
291 # suspend the pool until all jobs are posted, to prevent blocking of the process
292 # of starting / processing jobs by running threads
293 tpool::suspend $worker
294 if { $_tests_verbose > 0 } { _log_and_puts log "Executing tests in (up to) $parallel threads" }
299 foreach test_def $tests_list {
300 set dir [lindex $test_def 0]
301 set group [lindex $test_def 1]
302 set grid [lindex $test_def 2]
303 set casename [lindex $test_def 3]
304 set casefile [lindex $test_def 4]
306 # command to set tests for generation of image in results directory
308 if { $logdir != "" } { set imgdir_cmd "set imagedir $logdir/$group/$grid" }
310 # prepare command file for running test case in separate instance of DRAW
311 set fd_cmd [open $logdir/$group/$grid/${casename}.tcl w]
312 puts $fd_cmd "$imgdir_cmd"
313 puts $fd_cmd "set test_image $casename"
314 puts $fd_cmd "_run_test $dir $group $grid $casefile"
315 # use dlog command to obtain complete output of the test when it is absent (i.e. since OCCT 6.6.0)
316 if { ! [catch {dlog get}] } {
317 puts $fd_cmd "puts \[dlog get\]"
319 # else try to use old-style QA_ variables to get more output...
322 set env(QA_print_command) 1
324 # final 'exit' is needed when running on Linux under VirtualGl
327 set command "exec DRAWEXE -f $logdir/$group/$grid/${casename}.tcl"
328 # alternative method to run without temporary file; disabled as it needs too many backslashes
330 # set command "exec DRAWEXE -c $imgdir_cmd\\\; set test_image $casename\\\; \
331 # _run_test $dir $group $grid $casefile\\\; \
332 # puts \\\[dlog get\\\]\\\; exit"
335 # run test case, either in parallel or sequentially
336 if { $parallel > 0 } {
338 set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
339 set job_def($job) [list $logdir $dir $group $grid $casename]
341 # sequential execution
342 catch {eval $command} output
343 _log_test_case $output $logdir $dir $group $grid $casename log
345 # update summary log with requested period
346 if { $logdir != "" && $refresh > 0 && [expr [clock seconds] - $refresh_timer > $refresh] } {
347 # update and dump summary
348 _log_summarize $logdir $log
349 set refresh_timer [clock seconds]
354 # get results of started threads
355 if { $parallel > 0 } {
356 tpool::resume $worker
357 while { [llength [array names job_def]] > 0 } {
358 foreach job [tpool::wait $worker [array names job_def]] {
359 eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
363 # update summary log with requested period
364 if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
365 _log_summarize $logdir $log
366 set refresh_timer [clock seconds]
369 # release thread pool
370 tpool::release $worker
373 uplevel dchrono _timer stop
374 set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
376 ######################################################
377 # output summary logs and exit
378 ######################################################
380 _log_summarize $logdir $log $time
381 if { $logdir != "" } {
382 puts "Detailed logs are saved in $logdir"
384 if { $logdir != "" && $xmlfile != "" } {
385 # XML output file is assumed relative to log dir unless it is absolute
386 if { [ file pathtype $xmlfile] == "relative" } {
387 set xmlfile [file normalize $logdir/$xmlfile]
389 _log_xml_summary $logdir $xmlfile $log 0
390 puts "XML summary is saved to $xmlfile"
396 # Internal procedure to find test case indicated by group, grid, and test case names;
398 # - dir: path to the base directory of the tests group
399 # - gridname: actual name of the grid
400 # - casefile: path to the test case script
401 # if no such test is found, raises error with appropriate message
402 proc _get_test {group grid casename _dir _gridname _casefile} {
404 upvar $_gridname gridname
405 upvar $_casefile casefile
409 # check that environment variable defining paths to test scripts is defined
410 if { ! [info exists env(CSF_TestScriptsPath)] ||
411 [llength $env(CSF_TestScriptsPath)] <= 0 } {
412 error "Error: Environment variable CSF_TestScriptsPath is not defined"
415 # iterate by all script paths
416 foreach dir [_split_path $env(CSF_TestScriptsPath)] {
417 # protection against empty paths
418 set dir [string trim $dir]
419 if { $dir == "" } { continue }
421 # check that directory exists
422 if { ! [file isdirectory $dir] } {
423 puts "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
427 # check if test group with given name exists in this dir
428 # if not, continue to the next test dir
429 if { ! [file isdirectory $dir/$group] } { continue }
431 # check that grid with given name (possibly alias) exists; stop otherwise
433 if { ! [file isdirectory $dir/$group/$gridname] } {
434 # check if grid is named by alias rather than by actual name
435 if { [file exists $dir/$group/grids.list] } {
436 set fd [open $dir/$group/grids.list]
437 while { [gets $fd line] >= 0 } {
438 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
439 if { [regexp "^$grid\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridname] } {
446 if { ! [file isdirectory $dir/$group/$gridname] } { continue }
448 # get actual file name of the script; stop if it cannot be found
449 set casefile $dir/$group/$gridname/$casename
450 if { ! [file exists $casefile] } {
451 # check if this grid is aliased to another one
452 if { [file exists $dir/$group/$gridname/cases.list] } {
453 set fd [open $dir/$group/$gridname/cases.list]
454 if { [gets $fd line] >= 0 } {
455 set casefile [file normalize $dir/$group/$gridname/[string trim $line]/$casename]
460 if { [file exists $casefile] } {
466 # coming here means specified test is not found; report error
467 error [join [list "Error: test case $group / $grid / $casename is not found in paths listed in variable" \
468 "CSF_TestScriptsPath (current value is \"$env(CSF_TestScriptsPath)\")"] "\n"]
471 # Internal procedure to run test case indicated by base directory,
472 # grid and grid names, and test case file path.
473 # The log can be obtained by command "dlog get".
474 proc _run_test {scriptsdir group gridname casefile} {
478 uplevel dchrono _timer reset
479 uplevel dchrono _timer start
481 # enable commands logging; switch to old-style mode if dlog command is not present
483 if { [catch {dlog reset}] } {
488 rename puts puts-saved
490 global _tests_verbose
492 # log only output to stdout and stderr, not to file!
493 if {[llength $args] > 1} {
494 set optvarg [lindex $args end-1]
495 if { $optarg == stdout || $optarg == stderr || $optarg == -newline } {
496 dlog add [lindex $args end]
499 dlog add [lindex $args end]
502 # reproduce original puts
503 if { $_tests_verbose } {
504 eval puts-saved $args
509 # set datadir for this test case
510 if { [info exists env(CSF_TestDataPath)] } {
511 foreach ddir [regsub -all ";" [regsub "\\\\" $env(CSF_TestDataPath) "/"] " "] {
512 if { [file isdirectory $ddir/$group] } {
513 set save_datadir [datadir]
519 if { ! [info exists save_datadir] } {
520 puts "Warning: no data directory found for group $group in path defined by CSF_TestDataPath"
521 set save_datadir [datadir]
526 uplevel set casename [file tail $casefile]
528 if { [file exists $scriptsdir/$group/begin] } {
529 puts "Executing $scriptsdir/$group/begin..."; flush stdout
530 uplevel source $scriptsdir/$group/begin
532 if { [file exists $scriptsdir/$group/$gridname/begin] } {
533 puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
534 uplevel source $scriptsdir/$group/$gridname/begin
537 puts "Executing $casefile..."; flush stdout
538 uplevel source $casefile
540 if { [file exists $scriptsdir/$group/$gridname/end] } {
541 puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
542 uplevel source $scriptsdir/$group/$gridname/end
544 if { [file exists $scriptsdir/$group/end] } {
545 puts "Executing $scriptsdir/$group/end..."; flush stdout
546 uplevel source $scriptsdir/$group/end
549 puts "Tcl Exception: $res"
552 datadir $save_datadir
555 if { $dlog_exists } {
557 rename puts-saved puts
562 uplevel dchrono _timer stop
563 set time [uplevel dchrono _timer show]
564 if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
565 if { $dlog_exists } {
566 dlog add "TOTAL CPU TIME: $cpu sec"
568 puts "TOTAL CPU TIME: $cpu sec"
573 # Internal procedure to check log of test execution and decide if it passed or failed
574 proc _check_log {dir group gridname casename log {_summary {}} {_html_log {}}} {
576 if { $_summary != "" } { upvar $_summary summary }
577 if { $_html_log != "" } { upvar $_html_log html_log }
583 # load definition of 'bad words' indicating test failure
584 # note that rules are loaded in the order of decreasing priority (grid - group - common),
585 # thus grid rules will override group ones
587 foreach rulesfile [list $dir/$group/$gridname/parse.rules $dir/$group/parse.rules $dir/parse.rules] {
588 if [catch {set fd [open $rulesfile r]}] { continue }
589 while { [gets $fd line] >= 0 } {
590 # skip comments and empty lines
591 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
592 if { [string trim $line] == "" } { continue }
594 if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } {
595 puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
598 set status [string trim $status]
599 if { $comment != "" } { set status "$status ([string trim $comment])" }
600 set rexp [regsub -all {\\b} $rexp {\\y}] ;# convert regexp from Perl to Tcl style
601 lappend badwords [list $status $rexp]
605 if { [llength $badwords] <= 0 } {
606 puts "Warning: no definition of error indicators found (check files parse.rules)"
609 # analyse log line-by-line
612 foreach line [split $log "\n"] {
613 # check if line defines specific treatment of some messages
614 if [regexp -nocase {^[ \t]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
615 if { ! [regexp -nocase {\mAll\M} $platforms] &&
616 ! [regexp -nocase "\\m$env(os_type)\\M" $platforms] } {
617 set html_log "$html_log\n$line"
618 continue ;# TODO statement is for another platform
621 # record TODOs that mark unstable cases
622 if { [regexp {[\?]} $platforms] } {
623 set todos_unstable([llength $todos]) 1
626 lappend todos [regsub -all {\\b} [string trim $pattern] {\\y}] ;# convert regexp from Perl to Tcl style
627 set html_log "$html_log\n[_html_highlight BAD $line]"
631 # check for presence of messages indicating test result
633 foreach bw $badwords {
634 if { [regexp [lindex $bw 1] $line] } {
635 # check if this is known bad case
637 for {set i 0} {$i < [llength $todos]} {incr i} {
638 if { [regexp [lindex $todos $i] $line] } {
641 set html_log "$html_log\n[_html_highlight BAD $line]"
646 # if it is not in todo, define status
648 set stat [lindex $bw 0 0]
649 set html_log "$html_log\n[_html_highlight $stat $line]"
650 if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
651 set status [lindex $bw 0]
659 set html_log "$html_log\n$line"
663 # check for presence of TEST COMPLETED statement
664 if { $status == "" && ! [regexp {TEST COMPLETED} $log] } {
665 # check whether absence of TEST COMPLETED is known problem
666 set i [lsearch $todos "TEST INCOMPLETE"]
670 set status "FAILED (no final message is found)"
674 # check declared bad cases and diagnose possible improvement
675 # (bad case declared but not detected).
676 # Note that absence of the problem marked by TODO with question mark
677 # (unstable) is not reported as improvement.
678 if { $status == "" } {
679 for {set i 0} {$i < [llength $todos]} {incr i} {
680 if { ! [info exists todos_unstable($i)] &&
681 (! [info exists todo_count($i)] || $todo_count($i) <= 0) } {
682 set status "IMPROVEMENT (expected problem TODO no. [expr $i + 1] is not detected)"
688 # report test as known bad if at least one of expected problems is found
689 if { $status == "" && [llength [array names todo_count]] > 0 } {
690 set status "BAD (known problem)"
694 if { $status == "" } {set status "OK" }
697 set status "FAILED ($res)"
701 _log_and_puts summary "CASE $group $gridname $casename: $status"
702 set html_log "[_html_highlight [lindex $status 0] $summary]\n$html_log"
705 # Auxiliary procedure putting message to both cout and log variable (list)
706 proc _log_and_puts {logvar message} {
707 if { $logvar != "" } {
709 if [info exists log] {
710 set log "$log$message\n"
718 # Auxiliary procedure to log result on single test case
719 proc _log_test_case {output logdir dir group grid casename logvar} {
722 # check result and make HTML log
723 _check_log $dir $group $grid $casename $output summary html_log
724 set log "$log$summary"
727 if { $logdir != "" } {
728 _log_html $logdir/$group/$grid/$casename.html $html_log "Test $group $grid $casename"
729 _log_save $logdir/$group/$grid/$casename.log "$output\n$summary" "Test $group $grid $casename"
733 # Auxiliary procedure to save log to file
734 proc _log_save {file log {title {}}} {
735 # create missing directories as needed
736 catch {file mkdir [file dirname $file]}
739 if [catch {set fd [open $file w]} res] {
740 error "Error saving log file $file: $res"
750 # Auxiliary procedure to save log to file
751 proc _log_html {file log {title {}}} {
752 # create missing directories as needed
753 catch {file mkdir [file dirname $file]}
756 if [catch {set fd [open $file w]} res] {
757 error "Error saving log file $file: $res"
761 puts $fd "<html><head><title>$title</title><head><body><h1>$title</h1>"
763 # add images if present
764 set imgbasename [file rootname [file tail $file]]
765 foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails ${imgbasename}*.gif ${imgbasename}*.png ${imgbasename}*.jpg]] {
766 puts $fd "<p><img src=\"$img\"/><p>"
769 # print body, then end and close
772 puts $fd "</pre></body></html>"
778 # Auxiliary method to make text with HTML highlighting according to status
779 proc _html_color {status} {
780 # choose a color for the cell according to result
781 if { $status == "OK" } {
783 } elseif { [regexp -nocase {^FAIL} $status] } {
785 } elseif { [regexp -nocase {^BAD} $status] } {
787 } elseif { [regexp -nocase {^IMP} $status] } {
789 } elseif { [regexp -nocase {^SKIP} $status] } {
791 } elseif { [regexp -nocase {^IGNOR} $status] } {
794 puts "Warning: no color defined for status $status, using red as if FAILED"
799 # Format text line in HTML to be colored according to the status
800 proc _html_highlight {status line} {
801 return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
804 # Internal procedure to generate HTML page presenting log of the tests
805 # execution in tabular form, with links to reports on individual cases
806 proc _log_html_summary {logdir log totals regressions improvements total_time} {
807 global _test_case_regexp
809 # create missing directories as needed
810 catch {file mkdir $logdir}
812 # try to open a file and start HTML
813 if [catch {set fd [open $logdir/summary.html w]} res] {
814 error "Error creating log file: $res"
817 # write HRML header, including command to refresh log if still in progress
818 puts $fd "<html><head>"
819 puts $fd "<title>Tests summary</title>"
820 if { $total_time == "" } {
821 puts $fd "<meta http-equiv=\"refresh\" content=\"10\">"
823 puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
824 puts $fd "</head><body>"
827 set legend(OK) "Test passed OK"
828 set legend(FAILED) "Test failed (regression)"
829 set legend(BAD) "Known problem"
830 set legend(IMPROVEMENT) "Possible improvement (expected problem not detected)"
831 set legend(SKIPPED) "Test skipped due to lack of data file"
832 puts $fd "<h1>Summary</h1><table>"
833 foreach nbstat $totals {
834 set status [lindex $nbstat 1]
835 if { [info exists legend($status)] } {
836 set comment $legend($status)
838 set comment "User-defined status"
840 puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
844 # time stamp and elapsed time info
845 if { $total_time != "" } {
846 puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname] <p> $total_time"
848 puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
851 # print regressions and improvements
852 foreach featured [list $regressions $improvements] {
853 if { [llength $featured] <= 1 } { continue }
854 set status [string trim [lindex $featured 0] { :}]
855 puts $fd "<h2>$status</h2>"
858 foreach test [lrange $featured 1 end] {
859 if { ! [regexp {^(.*)\s+([\w.]+)$} $test res gg name] } {
861 set name "Error building short list; check details"
863 if { $gg != $groupgrid } {
864 if { $groupgrid != "" } { puts $fd "</tr>" }
866 puts $fd "<tr><td>$gg</td>"
868 puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
870 if { $groupgrid != "" } { puts $fd "</tr>" }
875 puts $fd "<h1>Details</h1>"
877 # process log line-by-line
880 foreach line [lsort -dictionary [split $log "\n"]] {
881 # check that the line is case report in the form "CASE group grid name: result (explanation)"
882 if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
887 if { $grp != $group } {
888 if { $letter != "" } { puts $fd "</tr></table>" }
892 puts $fd "<h2>Group $group</h2>"
896 if { $grd != $grid } {
897 if { $letter != "" } { puts $fd "</tr></table>" }
900 puts $fd "<h3>Grid $grid</h3>"
903 # check if test case name is <letter><digit>;
904 # if not, set alnum to period "." to recognize non-standard test name
905 if { ! [regexp {([A-Za-z]+)([0-9]+)} $casename res alnum number] } {
909 # start new row when letter changes or for non-standard names
910 if { $alnum != $letter || $alnum == "." } {
911 if { $letter != "" } {
914 puts $fd "<table><tr>"
919 puts $fd "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
921 puts $fd "</tr></table>"
923 # add remaining lines of log as plain text
924 puts $fd "<h2>Plain text messages</h2>\n<pre>"
925 foreach line [split $log "\n"] {
926 if { ! [regexp $_test_case_regexp $line] } {
932 # close file and exit
938 # Procedure to dump summary logs of tests
939 proc _log_summarize {logdir log {total_time {}}} {
941 # sort log records alphabetically to have the same behavior on Linux and Windows
942 # (also needed if tests are run in parallel)
943 set loglist [lsort -dictionary [split $log "\n"]]
945 # classify test cases by status
946 foreach line $loglist {
947 if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
948 lappend stat($status) $caseid
952 set improvements {Improvements:}
953 set regressions {Failed:}
954 if { [info exists stat] } {
955 foreach status [lsort [array names stat]] {
956 lappend totals [list [llength $stat($status)] $status]
958 # separately count improvements (status starting with IMP) and regressions (all except IMP, OK, BAD, and SKIP)
959 if { [regexp -nocase {^IMP} $status] } {
960 eval lappend improvements $stat($status)
961 } elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
962 eval lappend regressions $stat($status)
967 # if time is specified, add totals
968 if { $total_time != "" } {
969 if { [llength $improvements] > 1 } {
970 _log_and_puts log [join $improvements "\n "]
972 if { [llength $regressions] > 1 } {
973 _log_and_puts log [join $regressions "\n "]
975 if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
976 _log_and_puts log "No regressions"
978 _log_and_puts log "Total cases: [join $totals {, }]"
979 _log_and_puts log $total_time
983 if { $logdir != "" } {
984 _log_html_summary $logdir $log $totals $regressions $improvements $total_time
985 _log_save $logdir/tests.log $log "Tests summary"
991 # Internal procedure to generate XML log in JUnit style, for further
992 # consumption by Jenkins or similar systems.
994 # The output is intended to conform to XML schema supported by Jenkins found at
995 # https://svn.jenkins-ci.org/trunk/hudson/dtkit/dtkit-format/dtkit-junit-model/src/main/resources/com/thalesgroup/dtkit/junit/model/xsd/junit-4.xsd
997 # The mapping of the fields is inspired by annotated schema of Apache Ant JUnit XML format found at
998 # http://windyroad.org/dl/Open%20Source/JUnit.xsd
999 proc _log_xml_summary {logdir filename log include_cout} {
1000 global _test_case_regexp
1002 catch {file mkdir [file dirname $filename]}
1004 # try to open a file and start XML
1005 if [catch {set fd [open $filename w]} res] {
1006 error "Error creating XML summary file $filename: $res"
1008 puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1009 puts $fd "<testsuites>"
1011 # prototype for command to generate test suite tag
1012 set time_and_host "timestamp=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\" hostname=\"[info hostname]\""
1013 set cmd_testsuite {puts $fd "<testsuite name=\"$group $grid\" tests=\"$nbtests\" failures=\"$nbfail\" errors=\"$nberr\" time=\"$time\" skipped=\"$nbskip\" $time_and_host>\n$testcases\n</testsuite>\n"}
1015 # sort log and process it line-by-line
1017 foreach line [lsort -dictionary [split $log "\n"]] {
1018 # check that the line is case report in the form "CASE group grid name: result (explanation)"
1019 if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1022 set message [string trim $message " \t\r\n()"]
1024 # start new testsuite for each grid
1025 if { $grp != $group || $grd != $grid } {
1027 # write previous test suite
1028 if [info exists testcases] { eval $cmd_testsuite }
1043 # parse test log and get its CPU time
1046 if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } {
1047 puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1049 while { [gets $fdlog logline] >= 0 } {
1050 if { $include_cout } {
1051 set testout "$testout$logline\n"
1053 if [regexp -nocase {TOTAL CPU TIME:\s*([\d.]+)\s*sec} $logline res cpu] {
1054 set add_cpu " time=\"$cpu\""
1055 set time [expr $time + $cpu]
1060 if { ! $include_cout } {
1061 set testout "$line\n"
1064 # record test case with its output and status
1065 # Mapping is: SKIPPED, BAD, and OK to OK, all other to failure
1066 set testcases "$testcases\n <testcase name=\"$casename\"$add_cpu status=\"$result\">\n"
1067 set testcases "$testcases\n <system-out>\n$testout </system-out>"
1068 if { $result != "OK" } {
1069 if { [regexp -nocase {^SKIP} $result] } {
1071 set testcases "$testcases\n <error name=\"$result\" message=\"$message\"/>"
1072 } elseif { [regexp -nocase {^BAD} $result] } {
1074 set testcases "$testcases\n <skipped>$message</skipped>"
1077 set testcases "$testcases\n <failure name=\"$result\" message=\"$message\"/>"
1080 set testcases "$testcases\n </testcase>"
1083 # write last test suite
1084 if [info exists testcases] { eval $cmd_testsuite }
1087 puts $fd "</testsuites>"
1092 # define custom platform name
1093 proc _tests_platform_def {} {
1094 global env tcl_platform
1096 if [info exists env(os_type)] { return }
1098 set env(os_type) $tcl_platform(platform)
1100 # use detailed mapping for various versions of Lunix
1101 # (note that mapping is rather non-uniform, for historical reasons)
1102 if { $env(os_type) == "unix" && ! [catch {exec cat /etc/issue} issue] } {
1103 if { [regexp {Mandriva[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1104 set env(os_type) Mandriva$num
1105 } elseif { [regexp {Red Hat[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1106 set env(os_type) RedHat$num
1107 } elseif { [regexp {Debian[ \tA-Za-z/]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1108 set env(os_type) Debian$num$subnum
1109 } elseif { [regexp {CentOS[ \tA-Za-z]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1110 set env(os_type) CentOS$num$subnum
1111 } elseif { [regexp {Scientific[ \tA-Za-z]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1112 set env(os_type) SL$num$subnum
1113 } elseif { [regexp {Fedora Core[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1114 set env(os_type) FedoraCore$num
1116 if { [exec uname -m] == "x86_64" } {
1117 set env(os_type) "$env(os_type)-64"
1123 # Auxiliary procedure to split path specification (usually defined by
1124 # environment variable) into list of directories or files
1125 proc _split_path {pathspec} {
1128 # first replace all \ (which might occur on Windows) by /
1129 regsub -all "\\\\" $pathspec "/" pathspec
1131 # split path by platform-specific separator
1132 return [split $pathspec [_path_separator]]
1135 # Auxiliary procedure to define platform-specific separator for directories in
1136 # path specification
1137 proc _path_separator {} {
1140 # split path by platform-specific separator
1141 if { $tcl_platform(platform) == "windows" } {
1148 # Procedure to locate data file for test given its name.
1149 # The search is performed assuming that the function is called
1150 # from the test case script; the search order is:
1151 # - directory where test script is located
1152 # - directories ../data and ../../data from the script dir
1153 # - subdirectories <group>/<grid> and <group> of directories listed in
1154 # environment variable CSF_TestDataPath
1155 # If file is not found, raises Tcl error.
1156 proc locate_data_file {filename} {
1159 set scriptfile [info script]
1160 if { $scriptfile == "" } {
1161 error "Error: This procedure (locate_data_file) is for use only in test scripts!"
1164 # look in subdirectories 'data' of grid and group directories
1165 set scriptdir [file normalize [file dirname $scriptfile]]
1166 if { [file tail $scriptdir] == "data" } {
1167 if [file exists $scriptdir/$filename] {
1168 return $scriptdir/$filename
1171 if [file exists $scriptdir/data/$filename] {
1172 return [file normalize $scriptdir/data/$filename]
1175 if [file exists $scriptdir/../data/$filename] {
1176 return [file normalize $scriptdir/../data/$filename]
1179 # check sub-directories corresponding to group and grid of
1180 # the current test case in paths indicated by CSF_TestDataPath
1181 if [info exists env(CSF_TestDataPath)] {
1182 set grid [file tail $scriptdir]
1183 set group [file tail [file dirname $scriptdir]]
1184 foreach dir [_split_path $env(CSF_TestDataPath)] {
1185 if [file exists $dir/$group/$grid/$filename] {
1186 return [file normalize $dir/$group/$grid/$filename]
1188 if [file exists $dir/$group/$filename] {
1189 return [file normalize $dir/$group/$filename]
1195 error [join [list "Error: file $filename could not be found neither in script" \
1196 "directories nor in paths indicated by CSF_TestDataPath environment variable"] "\n"]