0023260: Regression: Instability in parallel incmesh on Linux.
[occt.git] / src / DrawResources / TestCommands.tcl
CommitLineData
40093367 1# Copyright (c) 2012 OPEN CASCADE SAS
2#
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.
7#
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.
10#
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.
17
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.
23#
24# Note: procedures with names starting with underscore are for internal use
25# inside the test system.
26############################################################################
27
28# Default verbose level for command _run_test
29set _tests_verbose 0
30
31# regexp for parsing test case results in summary log
32set _test_case_regexp {^CASE\s+([\w.-]+)\s+([\w.-]+)\s+([\w.-]+)\s*:\s*([\w]+)(.*)}
33
34# Basic command to run indicated test case in DRAW
35help 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}
38proc test {group grid casename {verbose {}}} {
39 global _tests_verbose
40 if { $verbose != "" } {
41 set _tests_verbose $verbose
42 }
43
44 # get test case paths (will raise error if input is invalid)
45 _get_test $group $grid $casename dir gridname casefile
46
47 # run test
48 uplevel _run_test $dir $group $gridname $casefile
49
50 # check log
51 _check_log $dir $group $gridname $casename [dlog get]
52
53 return
54}
55
56# Basic command to run indicated test case in DRAW
57help 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)
60 Allowed options are:
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)
65}
66proc testgrid {logdir args} {
67 global env tcl_platform _tests_verbose
68
69 ######################################################
70 # check arguments
71 ######################################################
72
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"
77 }
78
79 # treat options
80 set parallel 0
81 set refresh 60
82 set overwrite 0
83 set xmlfile ""
84 for {set narg 0} {$narg < [llength $args]} {incr narg} {
85 set arg [lindex $args $narg]
86
87 # parallel execution
88 if { $arg == "-parallel" } {
89 incr narg
90 if { $narg < [llength $args] } {
91 set parallel [expr [lindex $args $narg]]
92 } else {
93 set paralell 2
94 }
95 continue
96 }
97
98 # refresh logs time
99 if { $arg == "-refresh" } {
100 incr narg
101 if { $narg < [llength $args] } {
102 set refresh [expr [lindex $args $narg]]
103 } else {
104 set refresh 10
105 }
106 continue
107 }
108
109 # allow overwrite logs
110 if { $arg == "-overwrite" } {
111 set overwrite 1
112 continue
113 }
114
115 # refresh logs time
116 if { $arg == "-xml" } {
117 incr narg
118 if { $narg < [llength $args] } {
119 set xmlfile [lindex $args $narg]
120 }
121 if { $xmlfile == "" } {
122 set xmlfile TESTS-summary.xml
123 }
124 continue
125 }
126
127 # unsupported option
128 if { [regexp {^-} $arg] } {
129 error "Error: unsupported option \"$arg\""
130 }
131
132 # treat arguments not recognized as options as group and grid names
133 if { ! [info exists groupname] } {
134 set groupname $arg
135 } elseif { ! [info exists gridname] } {
136 set gridname $arg
137 } else {
138 error "Error: cannot interpret argument $narg ($arg): both group and grid names are already defined by previous args!"
139 }
140 }
141
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]
148 }
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"
151 }
152 if { [catch {file mkdir $logdir}] || ! [file writable $logdir] } {
153 error "Error: Cannot create directory \"$logdir\", or it is not writable"
154 }
155
156 ######################################################
157 # prepare list of tests to be performed
158 ######################################################
159
160 # list of tests, each defined by a list of:
161 # test scripts directory
162 # group (subfolder) name
163 # grid (subfolder) name
164 # test case name
165 # path to test case file
166 set tests_list {}
167
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 }
173
174 if { $_tests_verbose > 0 } { _log_and_puts log "Examining tests directory $dir" }
175
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"
179 continue
180 }
181
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
187 } else {
188 continue
189 }
190 } else {
191 # else search all directories in the current dir
192 if [catch {glob -directory $dir -tail -types d *} groups] { continue }
193 }
194
195 # iterate by groups
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" }
199
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"
203 continue
204 }
205
206 # read grids.list file and make a list of grids to be executed
207 set gridlist {}
208 set fd [open $dir/$group/grids.list]
209 set nline 0
210 while { [gets $fd line] >= 0 } {
211 incr nline
212
213 # skip comments and empty lines
214 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
215 if { [string trim $line] == "" } { continue }
216
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"
220 continue
221 }
222
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
226 }
227 }
228 close $fd
229
230 # iterate by all grids
231 foreach grid $gridlist {
232
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]]
239 }
240 close $fd
241 }
242
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"
246 continue
247 }
248
249 # create directory for logging test results
250 if { $logdir != "" } { file mkdir $logdir/$group/$grid }
251
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 }
258
259 lappend tests_list [list $dir $group $grid $casename $casefile]
260 }
261 }
262 }
263 }
264 if { [llength $tests_list] < 1 } {
265 error "Error: no tests are found, check you input arguments and variable CSF_TestScriptsPath!"
266 }
267
268 ######################################################
269 # run tests
270 ######################################################
271
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"
277 }
278 set log "$log\n"
279
280 set refresh_timer [clock seconds]
281 uplevel dchrono _timer reset
282 uplevel dchrono _timer start
283
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"
288 set parallel 0
289 } else {
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" }
295 }
296 }
297
298 # start test cases
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]
305
306 # command to set tests for generation of image in results directory
307 set imgdir_cmd ""
308 if { $logdir != "" } { set imgdir_cmd "set imagedir $logdir/$group/$grid" }
309
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\]"
318 } else {
319 # else try to use old-style QA_ variables to get more output...
320 set env(QA_DUMP) 1
321 set env(QA_DUP) 1
322 set env(QA_print_command) 1
323 }
324 # final 'exit' is needed when running on Linux under VirtualGl
325 puts $fd_cmd "exit"
326 close $fd_cmd
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
329# else {
330# set command "exec DRAWEXE -c $imgdir_cmd\\\; set test_image $casename\\\; \
331# _run_test $dir $group $grid $casefile\\\; \
332# puts \\\[dlog get\\\]\\\; exit"
333# }
334
335 # run test case, either in parallel or sequentially
336 if { $parallel > 0 } {
337 # parallel execution
338 set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
339 set job_def($job) [list $logdir $dir $group $grid $casename]
340 } else {
341 # sequential execution
342 catch {eval $command} output
343 _log_test_case $output $logdir $dir $group $grid $casename log
344
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]
350 }
351 }
352 }
353
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
360 unset job_def($job)
361 }
362
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]
367 }
368 }
369 # release thread pool
370 tpool::release $worker
371 }
372
373 uplevel dchrono _timer stop
374 set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
375
376 ######################################################
377 # output summary logs and exit
378 ######################################################
379
380 _log_summarize $logdir $log $time
381 if { $logdir != "" } {
382 puts "Detailed logs are saved in $logdir"
383 }
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]
388 }
389 _log_xml_summary $logdir $xmlfile $log 0
390 puts "XML summary is saved to $xmlfile"
391 }
392
393 return
394}
395
396# Internal procedure to find test case indicated by group, grid, and test case names;
397# returns:
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
402proc _get_test {group grid casename _dir _gridname _casefile} {
403 upvar $_dir dir
404 upvar $_gridname gridname
405 upvar $_casefile casefile
406
407 global env
408
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"
413 }
414
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 }
420
421 # check that directory exists
422 if { ! [file isdirectory $dir] } {
423 puts "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
424 continue
425 }
426
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 }
430
431 # check that grid with given name (possibly alias) exists; stop otherwise
432 set gridname $grid
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] } {
440 break
441 }
442 }
443 close $fd
444 }
445 }
446 if { ! [file isdirectory $dir/$group/$gridname] } { continue }
447
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]
456 }
457 close $fd
458 }
459 }
460 if { [file exists $casefile] } {
461 # normal return
462 return
463 }
464 }
465
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"]
469}
470
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".
474proc _run_test {scriptsdir group gridname casefile} {
475 global env
476
477 # start timer
478 uplevel dchrono _timer reset
479 uplevel dchrono _timer start
480
481 # enable commands logging; switch to old-style mode if dlog command is not present
482 set dlog_exists 1
483 if { [catch {dlog reset}] } {
484 set dlog_exists 0
485 } else {
486 dlog reset
487 dlog on
488 rename puts puts-saved
489 proc puts args {
490 global _tests_verbose
491
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]
497 }
498 } else {
499 dlog add [lindex $args end]
500 }
501
502 # reproduce original puts
503 if { $_tests_verbose } {
504 eval puts-saved $args
505 }
506 }
507 }
508
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]
514 datadir $ddir/$group
515 break
516 }
517 }
518 }
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]
522 }
523
524 # evaluate test case
525 if [catch {
526 uplevel set casename [file tail $casefile]
527
528 if { [file exists $scriptsdir/$group/begin] } {
529 puts "Executing $scriptsdir/$group/begin..."; flush stdout
530 uplevel source $scriptsdir/$group/begin
531 }
532 if { [file exists $scriptsdir/$group/$gridname/begin] } {
533 puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
534 uplevel source $scriptsdir/$group/$gridname/begin
535 }
536
537 puts "Executing $casefile..."; flush stdout
538 uplevel source $casefile
539
540 if { [file exists $scriptsdir/$group/$gridname/end] } {
541 puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
542 uplevel source $scriptsdir/$group/$gridname/end
543 }
544 if { [file exists $scriptsdir/$group/end] } {
545 puts "Executing $scriptsdir/$group/end..."; flush stdout
546 uplevel source $scriptsdir/$group/end
547 }
548 } res] {
549 puts "Tcl Exception: $res"
550 }
551
552 datadir $save_datadir
553
554 # stop logging
555 if { $dlog_exists } {
556 rename puts {}
557 rename puts-saved puts
558 dlog off
559 }
560
561 # add timing info
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"
567 } else {
568 puts "TOTAL CPU TIME: $cpu sec"
569 }
570 }
571}
572
573# Internal procedure to check log of test execution and decide if it passed or failed
574proc _check_log {dir group gridname casename log {_summary {}} {_html_log {}}} {
575 global env
576 if { $_summary != "" } { upvar $_summary summary }
577 if { $_html_log != "" } { upvar $_html_log html_log }
578 set summary ""
579 set html_log ""
580
581if [catch {
582
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
586 set badwords {}
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 }
593 # extract regexp
594 if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } {
595 puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
596 continue
597 }
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]
602 }
603 close $fd
604 }
605 if { [llength $badwords] <= 0 } {
606 puts "Warning: no definition of error indicators found (check files parse.rules)"
607 }
608
609 # analyse log line-by-line
610 set todos {}
611 set status ""
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
619 }
620
621 # record TODOs that mark unstable cases
622 if { [regexp {[\?]} $platforms] } {
623 set todos_unstable([llength $todos]) 1
624 }
625
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]"
628 continue
629 }
630
631 # check for presence of messages indicating test result
632 set ismarked 0
633 foreach bw $badwords {
634 if { [regexp [lindex $bw 1] $line] } {
635 # check if this is known bad case
636 set is_known 0
637 for {set i 0} {$i < [llength $todos]} {incr i} {
638 if { [regexp [lindex $todos $i] $line] } {
639 set is_known 1
640 incr todo_count($i)
641 set html_log "$html_log\n[_html_highlight BAD $line]"
642 break
643 }
644 }
645
646 # if it is not in todo, define status
647 if { ! $is_known } {
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]
652 }
653 }
654 set ismarked 1
655 break
656 }
657 }
658 if { ! $ismarked } {
659 set html_log "$html_log\n$line"
660 }
661 }
662
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"]
667 if { $i >= 0 } {
668 incr todo_count($i)
669 } else {
670 set status "FAILED (no final message is found)"
671 }
672 }
673
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)"
683 break;
684 }
685 }
686 }
687
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)"
691 }
692
693 # report normal OK
694 if { $status == "" } {set status "OK" }
695
696} res] {
697 set status "FAILED ($res)"
698}
699
700 # put final message
701 _log_and_puts summary "CASE $group $gridname $casename: $status"
702 set html_log "[_html_highlight [lindex $status 0] $summary]\n$html_log"
703}
704
705# Auxiliary procedure putting message to both cout and log variable (list)
706proc _log_and_puts {logvar message} {
707 if { $logvar != "" } {
708 upvar $logvar log
709 if [info exists log] {
710 set log "$log$message\n"
711 } else {
712 set log "$message\n"
713 }
714 }
715 puts $message
716}
717
718# Auxiliary procedure to log result on single test case
719proc _log_test_case {output logdir dir group grid casename logvar} {
720 upvar $logvar log
721
722 # check result and make HTML log
723 _check_log $dir $group $grid $casename $output summary html_log
724 set log "$log$summary"
725
726 # save log to file
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"
730 }
731}
732
733# Auxiliary procedure to save log to file
734proc _log_save {file log {title {}}} {
735 # create missing directories as needed
736 catch {file mkdir [file dirname $file]}
737
738 # try to open a file
739 if [catch {set fd [open $file w]} res] {
740 error "Error saving log file $file: $res"
741 }
742
743 # dump log and close
744 puts $fd "$title\n"
745 puts $fd $log
746 close $fd
747 return
748}
749
750# Auxiliary procedure to save log to file
751proc _log_html {file log {title {}}} {
752 # create missing directories as needed
753 catch {file mkdir [file dirname $file]}
754
755 # try to open a file
756 if [catch {set fd [open $file w]} res] {
757 error "Error saving log file $file: $res"
758 }
759
760 # print header
761 puts $fd "<html><head><title>$title</title><head><body><h1>$title</h1>"
762
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>"
767 }
768
769 # print body, then end and close
770 puts $fd "<pre>"
771 puts $fd $log
772 puts $fd "</pre></body></html>"
773
774 close $fd
775 return
776}
777
778# Auxiliary method to make text with HTML highlighting according to status
779proc _html_color {status} {
780 # choose a color for the cell according to result
781 if { $status == "OK" } {
782 return lightgreen
783 } elseif { [regexp -nocase {^FAIL} $status] } {
784 return red
785 } elseif { [regexp -nocase {^BAD} $status] } {
786 return yellow
787 } elseif { [regexp -nocase {^IMP} $status] } {
788 return orange
789 } elseif { [regexp -nocase {^SKIP} $status] } {
790 return gray
791 } elseif { [regexp -nocase {^IGNOR} $status] } {
792 return gray
793 } else {
794 puts "Warning: no color defined for status $status, using red as if FAILED"
795 return red
796 }
797}
798
799# Format text line in HTML to be colored according to the status
800proc _html_highlight {status line} {
801 return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
802}
803
804# Internal procedure to generate HTML page presenting log of the tests
805# execution in tabular form, with links to reports on individual cases
806proc _log_html_summary {logdir log totals regressions improvements total_time} {
807 global _test_case_regexp
808
809 # create missing directories as needed
810 catch {file mkdir $logdir}
811
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"
815 }
816
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\">"
822 }
823 puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
824 puts $fd "</head><body>"
825
826 # put summary
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)
837 } else {
838 set comment "User-defined status"
839 }
840 puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
841 }
842 puts $fd "</table>"
843
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"
847 } else {
848 puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
849 }
850
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>"
856 puts $fd "<table>"
857 set groupgrid ""
858 foreach test [lrange $featured 1 end] {
859 if { ! [regexp {^(.*)\s+([\w.]+)$} $test res gg name] } {
860 set gg UNKNOWN
861 set name "Error building short list; check details"
862 }
863 if { $gg != $groupgrid } {
864 if { $groupgrid != "" } { puts $fd "</tr>" }
865 set groupgrid $gg
866 puts $fd "<tr><td>$gg</td>"
867 }
868 puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
869 }
870 if { $groupgrid != "" } { puts $fd "</tr>" }
871 puts $fd "</table>"
872 }
873
874 # put detailed log
875 puts $fd "<h1>Details</h1>"
876
877 # process log line-by-line
878 set group {}
879 set letter {}
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] } {
883 continue
884 }
885
886 # start new group
887 if { $grp != $group } {
888 if { $letter != "" } { puts $fd "</tr></table>" }
889 set letter {}
890 set group $grp
891 set grid {}
892 puts $fd "<h2>Group $group</h2>"
893 }
894
895 # start new grid
896 if { $grd != $grid } {
897 if { $letter != "" } { puts $fd "</tr></table>" }
898 set letter {}
899 set grid $grd
900 puts $fd "<h3>Grid $grid</h3>"
901 }
902
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] } {
906 set alnum .
907 }
908
909 # start new row when letter changes or for non-standard names
910 if { $alnum != $letter || $alnum == "." } {
911 if { $letter != "" } {
912 puts $fd "</tr><tr>"
913 } else {
914 puts $fd "<table><tr>"
915 }
916 set letter $alnum
917 }
918
919 puts $fd "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
920 }
921 puts $fd "</tr></table>"
922
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] } {
927 puts $fd "$line"
928 }
929 }
930 puts $fd "</pre>"
931
932 # close file and exit
933 puts $fd "</body>"
934 close $fd
935 return
936}
937
938# Procedure to dump summary logs of tests
939proc _log_summarize {logdir log {total_time {}}} {
940
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"]]
944
945 # classify test cases by status
946 foreach line $loglist {
947 if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
948 lappend stat($status) $caseid
949 }
950 }
951 set totals {}
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]
957
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)
963 }
964 }
965 }
966
967 # if time is specified, add totals
968 if { $total_time != "" } {
969 if { [llength $improvements] > 1 } {
970 _log_and_puts log [join $improvements "\n "]
971 }
972 if { [llength $regressions] > 1 } {
973 _log_and_puts log [join $regressions "\n "]
974 }
975 if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
976 _log_and_puts log "No regressions"
977 }
978 _log_and_puts log "Total cases: [join $totals {, }]"
979 _log_and_puts log $total_time
980 }
981
982 # save log to files
983 if { $logdir != "" } {
984 _log_html_summary $logdir $log $totals $regressions $improvements $total_time
985 _log_save $logdir/tests.log $log "Tests summary"
986 }
987
988 return
989}
990
991# Internal procedure to generate XML log in JUnit style, for further
992# consumption by Jenkins or similar systems.
993#
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
996#
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
999proc _log_xml_summary {logdir filename log include_cout} {
1000 global _test_case_regexp
1001
1002 catch {file mkdir [file dirname $filename]}
1003
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"
1007 }
1008 puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1009 puts $fd "<testsuites>"
1010
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"}
1014
1015 # sort log and process it line-by-line
1016 set group {}
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] } {
1020 continue
1021 }
1022 set message [string trim $message " \t\r\n()"]
1023
1024 # start new testsuite for each grid
1025 if { $grp != $group || $grd != $grid } {
1026
1027 # write previous test suite
1028 if [info exists testcases] { eval $cmd_testsuite }
1029
1030 set testcases {}
1031 set nbtests 0
1032 set nberr 0
1033 set nbfail 0
1034 set nbskip 0
1035 set time 0.
1036
1037 set group $grp
1038 set grid $grd
1039 }
1040
1041 incr nbtests
1042
1043 # parse test log and get its CPU time
1044 set testout {}
1045 set add_cpu {}
1046 if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } {
1047 puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1048 } else {
1049 while { [gets $fdlog logline] >= 0 } {
1050 if { $include_cout } {
1051 set testout "$testout$logline\n"
1052 }
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]
1056 }
1057 }
1058 close $fdlog
1059 }
1060 if { ! $include_cout } {
1061 set testout "$line\n"
1062 }
1063
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] } {
1070 incr nberr
1071 set testcases "$testcases\n <error name=\"$result\" message=\"$message\"/>"
1072 } elseif { [regexp -nocase {^BAD} $result] } {
1073 incr nbskip
1074 set testcases "$testcases\n <skipped>$message</skipped>"
1075 } else {
1076 incr nbfail
1077 set testcases "$testcases\n <failure name=\"$result\" message=\"$message\"/>"
1078 }
1079 }
1080 set testcases "$testcases\n </testcase>"
1081 }
1082
1083 # write last test suite
1084 if [info exists testcases] { eval $cmd_testsuite }
1085
1086 # the end
1087 puts $fd "</testsuites>"
1088 close $fd
1089 return
1090}
1091
1092# define custom platform name
1093proc _tests_platform_def {} {
1094 global env tcl_platform
1095
1096 if [info exists env(os_type)] { return }
1097
1098 set env(os_type) $tcl_platform(platform)
1099
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
1115 }
1116 if { [exec uname -m] == "x86_64" } {
1117 set env(os_type) "$env(os_type)-64"
1118 }
1119 }
1120}
1121_tests_platform_def
1122
1123# Auxiliary procedure to split path specification (usually defined by
1124# environment variable) into list of directories or files
1125proc _split_path {pathspec} {
1126 global tcl_platform
1127
1128 # first replace all \ (which might occur on Windows) by /
1129 regsub -all "\\\\" $pathspec "/" pathspec
1130
1131 # split path by platform-specific separator
1132 return [split $pathspec [_path_separator]]
1133}
1134
1135# Auxiliary procedure to define platform-specific separator for directories in
1136# path specification
1137proc _path_separator {} {
1138 global tcl_platform
1139
1140 # split path by platform-specific separator
1141 if { $tcl_platform(platform) == "windows" } {
1142 return ";"
1143 } else {
1144 return ":"
1145 }
1146}
1147
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.
1156proc locate_data_file {filename} {
1157 global env
1158
1159 set scriptfile [info script]
1160 if { $scriptfile == "" } {
1161 error "Error: This procedure (locate_data_file) is for use only in test scripts!"
1162 }
1163
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
1169 }
1170 } else {
1171 if [file exists $scriptdir/data/$filename] {
1172 return [file normalize $scriptdir/data/$filename]
1173 }
1174 }
1175 if [file exists $scriptdir/../data/$filename] {
1176 return [file normalize $scriptdir/../data/$filename]
1177 }
1178
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]
1187 }
1188 if [file exists $dir/$group/$filename] {
1189 return [file normalize $dir/$group/$filename]
1190 }
1191 }
1192 }
1193
1194 # raise error
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"]
1197}