0030071: Tests - locate_data_file does not skip .git folders
[occt.git] / src / DrawResources / TestCommands.tcl
CommitLineData
d5f74e42 1# Copyright (c) 2013-2014 OPEN CASCADE SAS
40093367 2#
973c2be1 3# This file is part of Open CASCADE Technology software library.
40093367 4#
d5f74e42 5# This library is free software; you can redistribute it and/or modify it under
6# the terms of the GNU Lesser General Public License version 2.1 as published
973c2be1 7# by the Free Software Foundation, with special exception defined in the file
8# OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9# distribution for complete text of the license and disclaimer of any warranty.
40093367 10#
973c2be1 11# Alternatively, this file may be used under the terms of Open CASCADE
12# commercial license or contractual agreement.
40093367 13
14############################################################################
15# This file defines scripts for execution of OCCT tests.
16# It should be loaded automatically when DRAW is started, and provides
351bbcba 17# top-level commands starting with 'test'. Type 'help test' to get their
18# synopsys.
40093367 19# See OCCT Tests User Guide for description of the test system.
20#
21# Note: procedures with names starting with underscore are for internal use
22# inside the test system.
23############################################################################
24
25# Default verbose level for command _run_test
26set _tests_verbose 0
27
28# regexp for parsing test case results in summary log
29set _test_case_regexp {^CASE\s+([\w.-]+)\s+([\w.-]+)\s+([\w.-]+)\s*:\s*([\w]+)(.*)}
30
31# Basic command to run indicated test case in DRAW
b725d7c5 32help test {
33 Run specified test case
433673e0 34 Use: test group grid casename [options...]
35 Allowed options are:
36 -echo: all commands and results are echoed immediately,
37 but log is not saved and summary is not produced
38 It is also possible to use "1" instead of "-echo"
39 If echo is OFF, log is stored in memory and only summary
40 is output (the log can be obtained with command "dlog get")
41 -outfile filename: set log file (should be non-existing),
42 it is possible to save log file in text file or
43 in html file(with snapshot), for that "filename"
44 should have ".html" extension
45 -overwrite: force writing log in existing file
46 -beep: play sound signal at the end of the test
5fd3308a 47 -errors: show all lines from the log report that are recognized as errors
48 This key will be ignored if the "-echo" key is already set.
b725d7c5 49}
433673e0 50proc test {group grid casename {args {}}} {
51 # set default values of arguments
52 set echo 0
5fd3308a 53 set errors 0
433673e0 54 set logfile ""
55 set overwrite 0
56 set signal 0
57
40093367 58 # get test case paths (will raise error if input is invalid)
59 _get_test $group $grid $casename dir gridname casefile
60
433673e0 61 # check arguments
62 for {set narg 0} {$narg < [llength $args]} {incr narg} {
63 set arg [lindex $args $narg]
433673e0 64 # if echo specified as "-echo", convert it to bool
65 if { $arg == "-echo" || $arg == "1" } {
6d368502 66 set echo t
67 continue
433673e0 68 }
69
70 # output log file
71 if { $arg == "-outfile" } {
6d368502 72 incr narg
73 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
74 set logfile [lindex $args $narg]
75 } else {
76 error "Option -outfile requires argument"
77 }
78 continue
433673e0 79 }
80
81 # allow overwrite existing log
82 if { $arg == "-overwrite" } {
6d368502 83 set overwrite 1
84 continue
433673e0 85 }
86
87 # sound signal at the end of the test
88 if { $arg == "-beep" } {
6d368502 89 set signal t
90 continue
433673e0 91 }
92
5fd3308a 93 # if errors specified as "-errors", convert it to bool
94 if { $arg == "-errors" } {
6d368502 95 set errors t
96 continue
5fd3308a 97 }
98
433673e0 99 # unsupported option
100 error "Error: unsupported option \"$arg\""
101 }
40093367 102 # run test
c97067ad 103 uplevel _run_test $dir $group $gridname $casefile $echo
40093367 104
105 # check log
433673e0 106 if { !$echo } {
5fd3308a 107 _check_log $dir $group $gridname $casename $errors [dlog get] summary html_log
433673e0 108
109 # create log file
110 if { ! $overwrite && [file isfile $logfile] } {
111 error "Error: Specified log file \"$logfile\" exists; please remove it before running test or use -overwrite option"
112 }
113 if {$logfile != ""} {
6d368502 114 if {[file extension $logfile] == ".html"} {
115 if {[regexp {vdump ([^\s\n]+)} $html_log dump snapshot]} {
116 catch {file copy -force $snapshot [file rootname $logfile][file extension $snapshot]}
117 }
118 _log_html $logfile $html_log "Test $group $grid $casename"
119 } else {
120 _log_save $logfile "[dlog get]\n$summary" "Test $group $grid $casename"
433673e0 121 }
433673e0 122 }
5df3a117 123 }
40093367 124
433673e0 125 # play sound signal at the end of test
126 if {$signal} {
6d368502 127 puts "\7\7\7\7"
433673e0 128 }
40093367 129 return
130}
131
132# Basic command to run indicated test case in DRAW
b725d7c5 133help testgrid {
134 Run all tests, or specified group, or one grid
87f42a3f 135 Use: testgrid [groupmask [gridmask [casemask]]] [options...]
b725d7c5 136 Allowed options are:
137 -parallel N: run N parallel processes (default is number of CPUs, 0 to disable)
9753e6de 138 -refresh N: save summary logs every N seconds (default 600, minimal 1, 0 to disable)
b725d7c5 139 -outdir dirname: set log directory (should be empty or non-existing)
140 -overwrite: force writing logs in existing non-empty directory
141 -xml filename: write XML report for Jenkins (in JUnit-like format)
433673e0 142 -beep: play sound signal at the end of the tests
b502ddc1 143 -regress dirname: re-run only a set of tests that have been detected as regressions on some previous run.
144 Here "dirname" is path to directory containing results of previous run.
87f42a3f 145 Groups, grids, and test cases to be executed can be specified by list of file
146 masks, separated by spaces or comma; default is all (*).
40093367 147}
b725d7c5 148proc testgrid {args} {
40093367 149 global env tcl_platform _tests_verbose
150
151 ######################################################
152 # check arguments
153 ######################################################
154
155 # check that environment variable defining paths to test scripts is defined
156 if { ! [info exists env(CSF_TestScriptsPath)] ||
6d368502 157 [llength $env(CSF_TestScriptsPath)] <= 0 } {
40093367 158 error "Error: Environment variable CSF_TestScriptsPath is not defined"
159 }
160
161 # treat options
b725d7c5 162 set parallel [_get_nb_cpus]
40093367 163 set refresh 60
b725d7c5 164 set logdir ""
40093367 165 set overwrite 0
166 set xmlfile ""
433673e0 167 set signal 0
b502ddc1 168 set regress 0
169 set prev_logdir ""
40093367 170 for {set narg 0} {$narg < [llength $args]} {incr narg} {
6d368502 171 set arg [lindex $args $narg]
172
173 # parallel execution
174 if { $arg == "-parallel" } {
175 incr narg
176 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
177 set parallel [expr [lindex $args $narg]]
178 } else {
179 error "Option -parallel requires argument"
180 }
181 continue
182 }
183
184 # refresh logs time
185 if { $arg == "-refresh" } {
186 incr narg
187 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
188 set refresh [expr [lindex $args $narg]]
189 } else {
190 error "Option -refresh requires argument"
191 }
192 continue
193 }
194
195 # output directory
196 if { $arg == "-outdir" } {
197 incr narg
198 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
199 set logdir [lindex $args $narg]
200 } else {
201 error "Option -outdir requires argument"
202 }
203 continue
204 }
205
206 # allow overwrite logs
207 if { $arg == "-overwrite" } {
208 set overwrite 1
209 continue
210 }
211
212 # refresh logs time
213 if { $arg == "-xml" } {
214 incr narg
215 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
216 set xmlfile [lindex $args $narg]
217 }
218 if { $xmlfile == "" } {
219 set xmlfile TESTS-summary.xml
220 }
221 continue
222 }
223
224 # sound signal at the end of the test
225 if { $arg == "-beep" } {
226 set signal t
227 continue
228 }
229
b502ddc1 230 # re-run only a set of tests that have been detected as regressions on some previous run
231 if { $arg == "-regress" } {
232 incr narg
233 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
234 set prev_logdir [lindex $args $narg]
235 set regress 1
236 } else {
237 error "Option -regress requires argument"
238 }
239 continue
240 }
241
6d368502 242 # unsupported option
243 if { [regexp {^-} $arg] } {
244 error "Error: unsupported option \"$arg\""
245 }
246
247 # treat arguments not recognized as options as group and grid names
248 if { ! [info exists groupmask] } {
249 set groupmask [split $arg ,]
250 } elseif { ! [info exists gridmask] } {
251 set gridmask [split $arg ,]
252 } elseif { ! [info exists casemask] } {
253 set casemask [split $arg ,]
254 } else {
255 error "Error: cannot interpret argument $narg ($arg)"
256 }
40093367 257 }
258
259 # check that target log directory is empty or does not exist
260 set logdir [file normalize [string trim $logdir]]
b502ddc1 261 set prev_logdir [file normalize [string trim $prev_logdir]]
40093367 262 if { $logdir == "" } {
6d368502 263 # if specified logdir is empty string, generate unique name like
ffc26091 264 # results/<branch>_<timestamp>
265 set prefix ""
b725d7c5 266 if { ! [catch {exec git branch} gitout] &&
b502ddc1 267 [regexp {[*] ([\w-]+)} $gitout res branch] } {
ffc26091 268 set prefix "${branch}_"
b725d7c5 269 }
6d368502 270 set logdir "results/${prefix}[clock format [clock seconds] -format {%Y-%m-%dT%H%M}]"
096ef695 271
6d368502 272 set logdir [file normalize $logdir]
40093367 273 }
274 if { [file isdirectory $logdir] && ! $overwrite && ! [catch {glob -directory $logdir *}] } {
6d368502 275 error "Error: Specified log directory \"$logdir\" is not empty; please clean it before running tests"
40093367 276 }
277 if { [catch {file mkdir $logdir}] || ! [file writable $logdir] } {
6d368502 278 error "Error: Cannot create directory \"$logdir\", or it is not writable"
40093367 279 }
280
87f42a3f 281 # masks for search of test groups, grids, and cases
282 if { ! [info exists groupmask] } { set groupmask * }
283 if { ! [info exists gridmask ] } { set gridmask * }
284 if { ! [info exists casemask ] } { set casemask * }
285
b502ddc1 286 # Find test cases with FAILED and IMPROVEMENT statuses in previous run
287 # if option "regress" is given
288 set rerun_group_grid_case {}
289
290 if { ${regress} > 0 } {
291 if { "${groupmask}" != "*"} {
292 lappend rerun_group_grid_case [list $groupmask $gridmask $casemask]
293 }
294 } else {
295 lappend rerun_group_grid_case [list $groupmask $gridmask $casemask]
296 }
297
298 if { ${regress} > 0 } {
299 if { [file exists ${prev_logdir}/tests.log] } {
300 set fd [open ${prev_logdir}/tests.log]
301 while { [gets $fd line] >= 0 } {
302 if {[regexp {CASE ([^\s]+) ([^\s]+) ([^\s]+): FAILED} $line dump group grid casename] ||
303 [regexp {CASE ([^\s]+) ([^\s]+) ([^\s]+): IMPROVEMENT} $line dump group grid casename]} {
304 lappend rerun_group_grid_case [list $group $grid $casename]
305 }
306 }
307 close $fd
308 } else {
309 error "Error: file ${prev_logdir}/tests.log is not found, check your input arguments!"
310 }
311 }
312
40093367 313 ######################################################
314 # prepare list of tests to be performed
315 ######################################################
316
317 # list of tests, each defined by a list of:
318 # test scripts directory
319 # group (subfolder) name
320 # grid (subfolder) name
321 # test case name
322 # path to test case file
323 set tests_list {}
324
b502ddc1 325 foreach group_grid_case ${rerun_group_grid_case} {
326 set groupmask [lindex $group_grid_case 0]
327 set gridmask [lindex $group_grid_case 1]
328 set casemask [lindex $group_grid_case 2]
40093367 329
b502ddc1 330 # iterate by all script paths
331 foreach dir [lsort -unique [_split_path $env(CSF_TestScriptsPath)]] {
332 # protection against empty paths
333 set dir [string trim $dir]
334 if { $dir == "" } { continue }
40093367 335
b502ddc1 336 if { $_tests_verbose > 0 } { _log_and_puts log "Examining tests directory $dir" }
40093367 337
b502ddc1 338 # check that directory exists
339 if { ! [file isdirectory $dir] } {
340 _log_and_puts log "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
6d368502 341 continue
342 }
343
b502ddc1 344 # search all directories in the current dir with specified mask
345 if [catch {glob -directory $dir -tail -types d {*}$groupmask} groups] { continue }
6d368502 346
b502ddc1 347 # iterate by groups
348 if { $_tests_verbose > 0 } { _log_and_puts log "Groups to be executed: $groups" }
349 foreach group [lsort -dictionary $groups] {
350 if { $_tests_verbose > 0 } { _log_and_puts log "Examining group directory $group" }
6d368502 351
b502ddc1 352 # file grids.list must exist: it defines sequence of grids in the group
353 if { ! [file exists $dir/$group/grids.list] } {
354 _log_and_puts log "Warning: directory $dir/$group does not contain file grids.list, skipped"
6d368502 355 continue
356 }
357
b502ddc1 358 # read grids.list file and make a list of grids to be executed
359 set gridlist {}
360 set fd [open $dir/$group/grids.list]
361 set nline 0
362 while { [gets $fd line] >= 0 } {
363 incr nline
6d368502 364
b502ddc1 365 # skip comments and empty lines
366 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
367 if { [string trim $line] == "" } { continue }
6d368502 368
b502ddc1 369 # get grid id and name
370 if { ! [regexp "^\(\[0-9\]+\)\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridid grid] } {
371 _log_and_puts log "Warning: cannot recognize line $nline in file $dir/$group/grids.list as \"gridid gridname\"; ignored"
372 continue
87f42a3f 373 }
6d368502 374
b502ddc1 375 # check that grid fits into the specified mask
376 foreach mask $gridmask {
377 if { $mask == $gridid || [string match $mask $grid] } {
378 lappend gridlist $grid
379 }
380 }
6d368502 381 }
b502ddc1 382 close $fd
383
384 # iterate by all grids
385 foreach grid $gridlist {
386
387 # check if this grid is aliased to another one
388 set griddir $dir/$group/$grid
389 if { [file exists $griddir/cases.list] } {
390 set fd [open $griddir/cases.list]
391 if { [gets $fd line] >= 0 } {
392 set griddir [file normalize $dir/$group/$grid/[string trim $line]]
393 }
394 close $fd
395 }
6d368502 396
b502ddc1 397 # check if grid directory actually exists
398 if { ! [file isdirectory $griddir] } {
399 _log_and_puts log "Error: tests directory for grid $grid ($griddir) is missing; skipped"
6d368502 400 continue
87f42a3f 401 }
40093367 402
b502ddc1 403 # create directory for logging test results
404 if { $logdir != "" } { file mkdir $logdir/$group/$grid }
405
406 # iterate by all tests in the grid directory
407 if { [catch {glob -directory $griddir -type f {*}$casemask} testfiles] } { continue }
408 foreach casefile [lsort -dictionary $testfiles] {
409 # filter out files with reserved names
410 set casename [file tail $casefile]
411 if { $casename == "begin" || $casename == "end" ||
412 $casename == "parse.rules" } {
413 continue
414 }
415
416 lappend tests_list [list $dir $group $grid $casename $casefile]
417 }
6d368502 418 }
419 }
420 }
40093367 421 }
422 if { [llength $tests_list] < 1 } {
b502ddc1 423 error "Error: no tests are found, check your input arguments and variable CSF_TestScriptsPath!"
433673e0 424 } else {
6d368502 425 puts "Running tests (total [llength $tests_list] test cases)..."
40093367 426 }
427
428 ######################################################
429 # run tests
430 ######################################################
431
432 # log command arguments and environment
9753e6de 433 lappend log "Command: testgrid $args"
434 lappend log "Host: [info hostname]"
435 lappend log "Started on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]"
436 catch {lappend log "DRAW build:\n[dversion]" }
437 lappend log "Environment:"
8a262fa1 438 foreach envar [lsort [array names env]] {
6d368502 439 lappend log "$envar=\"$env($envar)\""
40093367 440 }
9753e6de 441 lappend log ""
40093367 442
443 set refresh_timer [clock seconds]
444 uplevel dchrono _timer reset
445 uplevel dchrono _timer start
446
447 # if parallel execution is requested, allocate thread pool
448 if { $parallel > 0 } {
6d368502 449 if { ! [info exists tcl_platform(threaded)] || [catch {package require Thread}] } {
450 _log_and_puts log "Warning: Tcl package Thread is not available, running in sequential mode"
451 set parallel 0
452 } else {
453 set worker [tpool::create -minworkers $parallel -maxworkers $parallel]
454 # suspend the pool until all jobs are posted, to prevent blocking of the process
455 # of starting / processing jobs by running threads
456 catch {tpool::suspend $worker}
457 if { $_tests_verbose > 0 } { _log_and_puts log "Executing tests in (up to) $parallel threads" }
9753e6de 458 # limit number of jobs in the queue by reasonable value
459 # to prevent slowdown due to unnecessary queue processing
460 set nbpooled 0
461 set nbpooled_max [expr 10 * $parallel]
462 set nbpooled_ok [expr 5 * $parallel]
6d368502 463 }
40093367 464 }
465
466 # start test cases
8a262fa1 467 set userbreak 0
40093367 468 foreach test_def $tests_list {
8a262fa1 469 # check for user break
9753e6de 470 if { $userbreak || "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
8a262fa1 471 set userbreak 1
472 break
473 }
474
6d368502 475 set dir [lindex $test_def 0]
476 set group [lindex $test_def 1]
477 set grid [lindex $test_def 2]
478 set casename [lindex $test_def 3]
479 set casefile [lindex $test_def 4]
480
481 # command to set tests for generation of image in results directory
482 set imgdir_cmd ""
483 if { $logdir != "" } { set imgdir_cmd "set imagedir $logdir/$group/$grid" }
484
485 # prepare command file for running test case in separate instance of DRAW
486 set fd_cmd [open $logdir/$group/$grid/${casename}.tcl w]
487 puts $fd_cmd "$imgdir_cmd"
488 puts $fd_cmd "set test_image $casename"
489 puts $fd_cmd "_run_test $dir $group $grid $casefile t"
490
491 # use dlog command to obtain complete output of the test when it is absent (i.e. since OCCT 6.6.0)
492 # note: this is not needed if echo is set to 1 in call to _run_test above
493 if { ! [catch {dlog get}] } {
494 puts $fd_cmd "puts \[dlog get\]"
495 } else {
496 # else try to use old-style QA_ variables to get more output...
497 set env(QA_DUMP) 1
498 set env(QA_DUP) 1
499 set env(QA_print_command) 1
500 }
501
502 # final 'exit' is needed when running on Linux under VirtualGl
503 puts $fd_cmd "exit"
504 close $fd_cmd
8418c617 505
506 # commant to run DRAW with a command file;
507 # note that empty string is passed as standard input to avoid possible
508 # hang-ups due to waiting for stdin of the launching process
6d368502 509 set command "exec <<{} DRAWEXE -f $logdir/$group/$grid/${casename}.tcl"
510
511 # alternative method to run without temporary file; disabled as it needs too many backslashes
512 # else {
513 # set command "exec <<\"\" DRAWEXE -c $imgdir_cmd\\\; set test_image $casename\\\; \
514 # _run_test $dir $group $grid $casefile\\\; \
515 # puts \\\[dlog get\\\]\\\; exit"
516 # }
517
518 # run test case, either in parallel or sequentially
519 if { $parallel > 0 } {
520 # parallel execution
521 set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
522 set job_def($job) [list $logdir $dir $group $grid $casename]
9753e6de 523 incr nbpooled
524 if { $nbpooled > $nbpooled_max } {
525 _testgrid_process_jobs $worker $nbpooled_ok
526 }
6d368502 527 } else {
528 # sequential execution
529 catch {eval $command} output
530 _log_test_case $output $logdir $dir $group $grid $casename log
531
532 # update summary log with requested period
533 if { $logdir != "" && $refresh > 0 && [expr [clock seconds] - $refresh_timer > $refresh] } {
534 # update and dump summary
535 _log_summarize $logdir $log
536 set refresh_timer [clock seconds]
537 }
538 }
40093367 539 }
540
541 # get results of started threads
542 if { $parallel > 0 } {
9753e6de 543 _testgrid_process_jobs $worker
6d368502 544 # release thread pool
9753e6de 545 if { $nbpooled > 0 } {
6d368502 546 tpool::cancel $worker [array names job_def]
9753e6de 547 }
548 catch {tpool::resume $worker}
6d368502 549 tpool::release $worker
40093367 550 }
551
552 uplevel dchrono _timer stop
553 set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
554
8a262fa1 555 if { $userbreak } {
9753e6de 556 _log_and_puts log "*********** Stopped by user break ***********"
8a262fa1 557 set time "${time} \nNote: the process is not finished, stopped by user break!"
558 }
559
40093367 560 ######################################################
561 # output summary logs and exit
562 ######################################################
563
564 _log_summarize $logdir $log $time
565 if { $logdir != "" } {
6d368502 566 puts "Detailed logs are saved in $logdir"
40093367 567 }
568 if { $logdir != "" && $xmlfile != "" } {
6d368502 569 # XML output file is assumed relative to log dir unless it is absolute
570 if { [ file pathtype $xmlfile] == "relative" } {
571 set xmlfile [file normalize $logdir/$xmlfile]
572 }
573 _log_xml_summary $logdir $xmlfile $log 0
574 puts "XML summary is saved to $xmlfile"
40093367 575 }
433673e0 576 # play sound signal at the end of test
577 if {$signal} {
6d368502 578 puts "\7\7\7\7"
433673e0 579 }
40093367 580 return
581}
582
22db40eb 583# Procedure to regenerate summary log from logs of test cases
584help testsummarize {
585 Regenerate summary log in the test directory from logs of test cases.
586 This can be necessary if test grids are executed separately (e.g. on
587 different stations) or some grids have been re-executed.
588 Use: testsummarize dir
589}
590proc testsummarize {dir} {
591 global _test_case_regexp
592
593 if { ! [file isdirectory $dir] } {
6d368502 594 error "Error: \"$dir\" is not a directory"
22db40eb 595 }
596
597 # get summary statements from all test cases in one log
9753e6de 598 set log {}
22db40eb 599
600 # to avoid huge listing of logs, first find all subdirectories and iterate
601 # by them, parsing log files in each subdirectory independently
602 foreach grid [glob -directory $dir -types d -tails */*] {
603 foreach caselog [glob -nocomplain -directory [file join $dir $grid] -types f -tails *.log] {
604 set file [file join $dir $grid $caselog]
605 set nbfound 0
606 set fd [open $file r]
6d368502 607 while { [gets $fd line] >= 0 } {
608 if { [regexp $_test_case_regexp $line res grp grd cas status message] } {
22db40eb 609 if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } {
610 puts "Error: $file contains status line for another test case ($line)"
611 }
6d368502 612 lappend log $line
613 incr nbfound
614 }
615 }
22db40eb 616 close $fd
617
618 if { $nbfound != 1 } {
619 puts "Error: $file contains $nbfound status lines, expected 1"
620 }
621 }
622 }
623
624 _log_summarize $dir $log "Summary regenerated from logs at [clock format [clock seconds]]"
625 return
626}
627
cc6a292d 628# Procedure to compare results of two runs of test cases
b725d7c5 629help testdiff {
630 Compare results of two executions of tests (CPU times, ...)
22db40eb 631 Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
b725d7c5 632 Where dir1 and dir2 are directories containing logs of two test runs.
633 Allowed options are:
28cab376 634 -image [filename]: compare only images and save its in specified file (default
635 name is <dir1>/diffimage-<dir2>.log)
636 -cpu [filename]: compare only CPU and save it in specified file (default
637 name is <dir1>/diffcpu-<dir2>.log)
638 -memory [filename]: compare only memory and save it in specified file (default
639 name is <dir1>/diffmemory-<dir2>.log)
22db40eb 640 -save filename: save resulting log in specified file (default name is
60874ff8 641 <dir1>/diff-<dir2>.log); HTML log is saved with same name
22db40eb 642 and extension .html
b725d7c5 643 -status {same|ok|all}: filter cases for comparing by their status:
644 same - only cases with same status are compared (default)
645 ok - only cases with OK status in both logs are compared
646 all - results are compared regardless of status
647 -verbose level:
648 1 - output only differences
22db40eb 649 2 - output also list of logs and directories present in one of dirs only
650 3 - (default) output also progress messages
d5f061b6 651 -highlight_percent value: highlight considerable (>value in %) deviations
652 of CPU and memory (default value is 5%)
cc6a292d 653}
654proc testdiff {dir1 dir2 args} {
655 if { "$dir1" == "$dir2" } {
6d368502 656 error "Input directories are the same"
cc6a292d 657 }
658
659 ######################################################
660 # check arguments
661 ######################################################
662
663 # treat options
22db40eb 664 set logfile [file join $dir1 "diff-[file tail $dir2].log"]
28cab376 665 set logfile_image ""
666 set logfile_cpu ""
667 set logfile_memory ""
668 set image false
669 set cpu false
670 set memory false
cc6a292d 671 set basename ""
28cab376 672 set save false
cc6a292d 673 set status "same"
674 set verbose 3
6d368502 675 set highlight_percent 5
cc6a292d 676 for {set narg 0} {$narg < [llength $args]} {incr narg} {
6d368502 677 set arg [lindex $args $narg]
6d368502 678 # log file name
679 if { $arg == "-save" } {
680 incr narg
681 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
682 set logfile [lindex $args $narg]
683 } else {
684 error "Error: Option -save must be followed by log file name"
685 }
28cab376 686 set save true
6d368502 687 continue
688 }
28cab376 689
690 # image compared log
691 if { $arg == "-image" } {
692 incr narg
693 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
694 set logfile_image [lindex $args $narg]
695 } else {
696 set logfile_image [file join $dir1 "diffimage-[file tail $dir2].log"]
697 incr narg -1
698 }
699 set image true
700 continue
701 }
702
703 # CPU compared log
704 if { $arg == "-cpu" } {
705 incr narg
706 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
707 set logfile_cpu [lindex $args $narg]
708 } else {
709 set logfile_cpu [file join $dir1 "diffcpu-[file tail $dir2].log"]
710 incr narg -1
711 }
712 set cpu true
713 continue
714 }
715
716 # memory compared log
717 if { $arg == "-memory" } {
718 incr narg
719 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
720 set logfile_memory [lindex $args $narg]
721 } else {
722 set logfile_memory [file join $dir1 "diffmemory-[file tail $dir2].log"]
723 incr narg -1
724 }
725 set memory true
726 continue
727 }
728
6d368502 729 # status filter
730 if { $arg == "-status" } {
731 incr narg
732 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
733 set status [lindex $args $narg]
734 } else {
735 set status ""
736 }
737 if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
738 error "Error: Option -status must be followed by one of \"same\", \"all\", or \"ok\""
739 }
740 continue
741 }
742
743 # verbose level
744 if { $arg == "-verbose" } {
745 incr narg
746 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
747 set verbose [expr [lindex $args $narg]]
748 } else {
749 error "Error: Option -verbose must be followed by integer verbose level"
750 }
751 continue
752 }
753
754 # highlight_percent
755 if { $arg == "-highlight_percent" } {
756 incr narg
757 if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
758 set highlight_percent [expr [lindex $args $narg]]
759 } else {
760 error "Error: Option -highlight_percent must be followed by integer value"
761 }
762 continue
763 }
764
765 if { [regexp {^-} $arg] } {
766 error "Error: unsupported option \"$arg\""
767 }
22db40eb 768
769 # non-option arguments form a subdirectory path
6d368502 770 set basename [file join $basename $arg]
cc6a292d 771 }
28cab376 772
773 if {$image != false || $cpu != false || $memory != false} {
774 if {$save != false} {
775 error "Error: Option -save can not be used with image/cpu/memory options"
776 }
777 }
cc6a292d 778
779 # run diff procedure (recursive)
28cab376 780 _test_diff $dir1 $dir2 $basename $image $cpu $memory $status $verbose log log_image log_cpu log_memory
781
cc6a292d 782 # save result to log file
28cab376 783 if {$image == false && $cpu == false && $memory == false} {
784 if { "$logfile" != "" } {
785 _log_save $logfile [join $log "\n"]
786 _log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2 ${highlight_percent}
787 puts "Log is saved to $logfile (and .html)"
788 }
789 } else {
790 foreach mode {image cpu memory} {
791 if {"[set logfile_${mode}]" != ""} {
792 _log_save "[set logfile_${mode}]" [join "[set log_${mode}]" "\n"]
793 _log_html_diff "[file rootname [set logfile_${mode}]].html" "[set log_${mode}]" $dir1 $dir2 ${highlight_percent}
794 puts "Log (${mode}) is saved to [set logfile_${mode}] (and .html)"
795 }
796 }
cc6a292d 797 }
cc6a292d 798 return
799}
800
351bbcba 801# Procedure to check data file before adding it to repository
802help testfile {
4eb6e8f4 803 Checks specified data files for putting them into the test data files repository.
804
805 Use: testfile filelist
351bbcba 806
807 Will report if:
808 - data file (non-binary) is in DOS encoding (CR/LF)
809 - same data file (with same or another name) already exists in the repository
810 - another file with the same name already exists
4eb6e8f4 811 Note that names are considered to be case-insensitive (for compatibility
812 with Windows).
351bbcba 813
814 Unless the file is already in the repository, tries to load it, reports
815 the recognized file format, file size, number of faces and edges in the
4eb6e8f4 816 loaded shape (if any), information contained its triangulation, and makes
817 snapshot (in the temporary directory).
818
351bbcba 819 Finally it advises whether the file should be put to public section of the
820 repository.
4eb6e8f4 821
822 Use: testfile -check
823
824 If "-check" is given as an argument, then procedure will check files already
825 located in the repository (for possible duplicates and for DOS encoding).
351bbcba 826}
827proc testfile {filelist} {
828 global env
829
830 # check that CSF_TestDataPath is defined
831 if { ! [info exists env(CSF_TestDataPath)] } {
832 error "Environment variable CSF_TestDataPath must be defined!"
833 }
834
4eb6e8f4 835 set checkrepo f
836 if { "$filelist" == "-check" } { set checkrepo t }
837
351bbcba 838 # build registry of existing data files (name -> path) and (size -> path)
4eb6e8f4 839 puts "Collecting info on test data files repository..."
351bbcba 840 foreach dir [_split_path $env(CSF_TestDataPath)] {
841 while {[llength $dir] != 0} {
842 set curr [lindex $dir 0]
843 set dir [lrange $dir 1 end]
844 eval lappend dir [glob -nocomplain -directory $curr -type d *]
845 foreach file [glob -nocomplain -directory $curr -type f *] {
846 set name [file tail $file]
847 set name_lower [string tolower $name]
4eb6e8f4 848 set size [file size $file]
351bbcba 849
850 # check that the file is not in DOS encoding
4eb6e8f4 851 if { $checkrepo } {
852 if { [_check_dos_encoding $file] } {
853 puts "Warning: file $file is in DOS encoding; was this intended?"
351bbcba 854 }
4eb6e8f4 855 _check_file_format $file
856
857 # check if file with the same name is present twice or more
858 if { [info exists names($name_lower)] } {
859 puts "Error: more than one file with name $name is present in the repository:"
860 if { [_diff_files $file $names($name_lower)] } {
861 puts "(files are different by content)"
862 } else {
863 puts "(files are same by content)"
864 }
865 puts "--> $file"
866 puts "--> $names($name_lower)"
867 continue
868 }
351bbcba 869
4eb6e8f4 870 # check if file with the same content exists
871 if { [info exists sizes($size)] } {
872 foreach other $sizes($size) {
873 if { ! [_diff_files $file $other] } {
874 puts "Warning: two files with the same content found:"
875 puts "--> $file"
876 puts "--> $other"
877 }
351bbcba 878 }
879 }
880 }
881
882 # add the file to the registry
4eb6e8f4 883 lappend names($name_lower) $file
351bbcba 884 lappend sizes($size) $file
6d368502 885 }
886 }
351bbcba 887 }
4eb6e8f4 888 if { $checkrepo || [llength $filelist] <= 0 } { return }
351bbcba 889
890 # check the new files
891 set has_images f
892 puts "Checking new file(s)..."
893 foreach file $filelist {
351bbcba 894 set name [file tail $file]
895 set name_lower [string tolower $name]
4eb6e8f4 896 set found f
351bbcba 897
898 # check for presence of the file with same name
899 if { [info exists names($name_lower)] } {
4eb6e8f4 900 set found f
901 foreach other $names($name_lower) {
902 # avoid comparing the file with itself
903 if { [file normalize $file] == [file normalize $other] } {
904 continue
905 }
906 # compare content
907 if { [_diff_files $file $other] } {
908 puts "\n* $file: error\n name is already used by existing file\n --> $other"
909 } else {
910 puts "\n* $file: already present \n --> $other"
911 }
912 set found t
913 break
351bbcba 914 }
4eb6e8f4 915 if { $found } { continue }
916 }
917
918 # get size of the file; if it is in DOS encoding and less than 1 MB,
919 # estimate also its size in UNIX encoding to be able to find same
920 # file if already present but in UNIX encoding
921 set sizeact [file size $file]
922 set sizeunx ""
923 set isdos [_check_dos_encoding $file]
924 if { $isdos && $sizeact < 10000000 } {
925 set fd [open $file r]
926 fconfigure $fd -translation crlf
927 set sizeunx [string length [read $fd]]
928 close $fd
351bbcba 929 }
930
931 # check if file with the same content exists
4eb6e8f4 932 foreach size "$sizeact $sizeunx" {
933 if { [info exists sizes($size)] } {
351bbcba 934 foreach other $sizes($size) {
4eb6e8f4 935 # avoid comparing the file with itself
936 if { [file normalize $file] == [file normalize $other] } {
937 continue
938 }
939 # compare content
351bbcba 940 if { ! [_diff_files $file $other] } {
4eb6e8f4 941 puts "\n* $file: duplicate \n already present under name [file tail $other]\n --> $other"
6d368502 942 set found t
943 break
351bbcba 944 }
945 }
4eb6e8f4 946 if { $found } { break }
947 }
948 }
949 if { $found } { continue }
950
951 # file is not present yet, so to be analyzed
952 puts "\n* $file: new file"
953
954 # add the file to the registry as if it were added to the repository,
955 # to report possible duplicates among the currently processed files
956 lappend names($name_lower) $file
957 if { "$sizeunx" != "" } {
958 lappend sizes($sizeunx) $file
959 } else {
960 lappend sizes($sizeact) $file
961 }
962
963 # first of all, complain if it is in DOS encoding
964 if { $isdos } {
965 puts " Warning: DOS encoding detected, consider converting to"
966 puts " UNIX unless DOS line ends are needed for the test"
351bbcba 967 }
968
969 # try to read the file
970 set format [_check_file_format $file]
971 if { [catch {uplevel load_data_file $file $format a}] } {
4eb6e8f4 972 puts " Warning: Cannot read as $format file"
351bbcba 973 continue
974 }
975
4eb6e8f4 976 # warn if shape contains triangulation
977 pload MODELING
978 if { "$format" != "STL" &&
979 [regexp {contains\s+([0-9]+)\s+triangles} [uplevel trinfo a] res nbtriangles] &&
980 $nbtriangles != 0 } {
981 puts " Warning: shape contains triangulation ($nbtriangles triangles),"
982 puts " consider removing them unless they are needed for the test!"
983 }
984
351bbcba 985 # get number of faces and edges
986 set edges 0
987 set faces 0
988 set nbs [uplevel nbshapes a]
989 regexp {EDGE[ \t:]*([0-9]+)} $nbs res edges
990 regexp {FACE[ \t:]*([0-9]+)} $nbs res faces
991
992 # classify; first check file size and number of faces and edges
993 if { $size < 95000 && $faces < 20 && $edges < 100 } {
994 set dir public
995 } else {
996 set dir private
351bbcba 997 }
998
999 # add stats
4eb6e8f4 1000 puts " $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
351bbcba 1001
60874ff8 1002 set tmpdir [_get_temp_dir]
1003 file mkdir $tmpdir/$dir
351bbcba 1004
1005 # make snapshot
1006 pload AISV
1007 uplevel vdisplay a
4eb6e8f4 1008 uplevel vsetdispmode 1
351bbcba 1009 uplevel vfit
1010 uplevel vzfit
60874ff8 1011 uplevel vdump $tmpdir/$dir/[file rootname [file tail $file]].png
351bbcba 1012 set has_images t
1013 }
1014 if { $has_images } {
60874ff8 1015 puts "Snapshots are saved in subdirectory [_get_temp_dir]"
351bbcba 1016 }
1017}
1018
22db40eb 1019# Procedure to locate data file for test given its name.
1020# The search is performed assuming that the function is called
1021# from the test case script; the search order is:
1022# - subdirectory "data" of the test script (grid) folder
1023# - subdirectories in environment variable CSF_TestDataPath
1024# - subdirectory set by datadir command
1025# If file is not found, raises Tcl error.
1026proc locate_data_file {filename} {
1027 global env groupname gridname casename
1028
1029 # check if the file is located in the subdirectory data of the script dir
1030 set scriptfile [info script]
1031 if { $scriptfile != "" } {
1032 set path [file join [file dirname $scriptfile] data $filename]
6d368502 1033 if { [file exists $path] } {
1034 return [file normalize $path]
1035 }
22db40eb 1036 }
1037
1038 # check sub-directories in paths indicated by CSF_TestDataPath
1039 if { [info exists env(CSF_TestDataPath)] } {
6d368502 1040 foreach dir [_split_path $env(CSF_TestDataPath)] {
1041 while {[llength $dir] != 0} {
1042 set name [lindex $dir 0]
1043 set dir [lrange $dir 1 end]
343f7e4d 1044
80482e01 1045 # skip directories starting with dot
343f7e4d 1046 set aTail [file tail $name]
1047 if { [regexp {^[.]} $aTail] } { continue }
6d368502 1048 if { [file exists $name/$filename] } {
1049 return [file normalize $name/$filename]
1050 }
1051 eval lappend dir [glob -nocomplain -directory $name -type d *]
1052 }
1053 }
22db40eb 1054 }
1055
1056 # check current datadir
1057 if { [file exists [uplevel datadir]/$filename] } {
6d368502 1058 return [file normalize [uplevel datadir]/$filename]
22db40eb 1059 }
1060
1061 # raise error
c97067ad 1062 error [join [list "File $filename could not be found" \
6d368502 1063 "(should be in paths indicated by CSF_TestDataPath environment variable, " \
22db40eb 1064 "or in subfolder data in the script directory)"] "\n"]
1065}
1066
40093367 1067# Internal procedure to find test case indicated by group, grid, and test case names;
1068# returns:
1069# - dir: path to the base directory of the tests group
1070# - gridname: actual name of the grid
1071# - casefile: path to the test case script
1072# if no such test is found, raises error with appropriate message
1073proc _get_test {group grid casename _dir _gridname _casefile} {
1074 upvar $_dir dir
1075 upvar $_gridname gridname
1076 upvar $_casefile casefile
1077
1078 global env
1079
1080 # check that environment variable defining paths to test scripts is defined
1081 if { ! [info exists env(CSF_TestScriptsPath)] ||
1082 [llength $env(CSF_TestScriptsPath)] <= 0 } {
1083 error "Error: Environment variable CSF_TestScriptsPath is not defined"
1084 }
1085
1086 # iterate by all script paths
1087 foreach dir [_split_path $env(CSF_TestScriptsPath)] {
6d368502 1088 # protection against empty paths
1089 set dir [string trim $dir]
1090 if { $dir == "" } { continue }
40093367 1091
1092 # check that directory exists
1093 if { ! [file isdirectory $dir] } {
1094 puts "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
6d368502 1095 continue
40093367 1096 }
1097
1098 # check if test group with given name exists in this dir
1099 # if not, continue to the next test dir
1100 if { ! [file isdirectory $dir/$group] } { continue }
1101
1102 # check that grid with given name (possibly alias) exists; stop otherwise
1103 set gridname $grid
1104 if { ! [file isdirectory $dir/$group/$gridname] } {
1105 # check if grid is named by alias rather than by actual name
1106 if { [file exists $dir/$group/grids.list] } {
1107 set fd [open $dir/$group/grids.list]
1108 while { [gets $fd line] >= 0 } {
1109 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
1110 if { [regexp "^$grid\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridname] } {
1111 break
1112 }
1113 }
1114 close $fd
6d368502 1115 }
1116 }
40093367 1117 if { ! [file isdirectory $dir/$group/$gridname] } { continue }
1118
1119 # get actual file name of the script; stop if it cannot be found
1120 set casefile $dir/$group/$gridname/$casename
1121 if { ! [file exists $casefile] } {
1122 # check if this grid is aliased to another one
1123 if { [file exists $dir/$group/$gridname/cases.list] } {
1124 set fd [open $dir/$group/$gridname/cases.list]
1125 if { [gets $fd line] >= 0 } {
1126 set casefile [file normalize $dir/$group/$gridname/[string trim $line]/$casename]
1127 }
6d368502 1128 close $fd
1129 }
40093367 1130 }
1131 if { [file exists $casefile] } {
1132 # normal return
1133 return
1134 }
1135 }
1136
1137 # coming here means specified test is not found; report error
1138 error [join [list "Error: test case $group / $grid / $casename is not found in paths listed in variable" \
6d368502 1139 "CSF_TestScriptsPath (current value is \"$env(CSF_TestScriptsPath)\")"] "\n"]
40093367 1140}
1141
1142# Internal procedure to run test case indicated by base directory,
1143# grid and grid names, and test case file path.
1144# The log can be obtained by command "dlog get".
5df3a117 1145proc _run_test {scriptsdir group gridname casefile echo} {
40093367 1146 global env
1147
1148 # start timer
1149 uplevel dchrono _timer reset
1150 uplevel dchrono _timer start
433673e0 1151 catch {uplevel meminfo h} membase
40093367 1152
1153 # enable commands logging; switch to old-style mode if dlog command is not present
1154 set dlog_exists 1
1155 if { [catch {dlog reset}] } {
6d368502 1156 set dlog_exists 0
5df3a117 1157 } elseif { $echo } {
1158 decho on
40093367 1159 } else {
6d368502 1160 dlog reset
1161 dlog on
1162 rename puts puts-saved
1163 proc puts args {
1164 global _tests_verbose
1165
1166 # log only output to stdout and stderr, not to file!
1167 if {[llength $args] > 1} {
1168 set optarg [lindex $args end-1]
1169 if { $optarg == "stdout" || $optarg == "stderr" || $optarg == "-newline" } {
1170 dlog add [lindex $args end]
1171 } else {
1172 eval puts-saved $args
1173 }
1174 } else {
1175 dlog add [lindex $args end]
1176 }
1177 }
40093367 1178 }
1179
40093367 1180 # evaluate test case
936f43da 1181 set tmp_imagedir 0
40093367 1182 if [catch {
60874ff8 1183 # set variables identifying test case
6d368502 1184 uplevel set casename [file tail $casefile]
1185 uplevel set groupname $group
1186 uplevel set gridname $gridname
1187 uplevel set dirname $scriptsdir
40093367 1188
6d368502 1189 # set path for saving of log and images (if not yet set) to temp dir
1190 if { ! [uplevel info exists imagedir] } {
1191 uplevel set test_image \$casename
a3ef6605 1192
1193 # create subdirectory in temp named after group and grid with timestamp
1194 set rootlogdir [_get_temp_dir]
1195
1196 set imagedir "${group}-${gridname}-${::casename}-[clock format [clock seconds] -format {%Y-%m-%dT%Hh%Mm%Ss}]"
1197 set imagedir [file normalize ${rootlogdir}/$imagedir]
1198
1199 if { [catch {file mkdir $imagedir}] || ! [file writable $imagedir] ||
1200 ! [catch {glob -directory $imagedir *}] } {
6d368502 1201 # puts "Warning: Cannot create directory \"$imagedir\", or it is not empty; \"${rootlogdir}\" is used"
a3ef6605 1202 set imagedir $rootlogdir
1203 }
1204
d16b64f1 1205 uplevel set imagedir \"$imagedir\"
936f43da 1206 set tmp_imagedir 1
6d368502 1207 }
60874ff8 1208
6d368502 1209 # execute test scripts
40093367 1210 if { [file exists $scriptsdir/$group/begin] } {
6d368502 1211 puts "Executing $scriptsdir/$group/begin..."; flush stdout
1212 uplevel source $scriptsdir/$group/begin
1213 }
1214 if { [file exists $scriptsdir/$group/$gridname/begin] } {
1215 puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
1216 uplevel source $scriptsdir/$group/$gridname/begin
1217 }
1218
1219 puts "Executing $casefile..."; flush stdout
1220 uplevel source $casefile
1221
1222 if { [file exists $scriptsdir/$group/$gridname/end] } {
1223 puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
1224 uplevel source $scriptsdir/$group/$gridname/end
1225 }
1226 if { [file exists $scriptsdir/$group/end] } {
1227 puts "Executing $scriptsdir/$group/end..."; flush stdout
1228 uplevel source $scriptsdir/$group/end
1229 }
40093367 1230 } res] {
6d368502 1231 puts "Tcl Exception: $res"
40093367 1232 }
1233
40093367 1234 # stop logging
1235 if { $dlog_exists } {
5df3a117 1236 if { $echo } {
6d368502 1237 decho off
5df3a117 1238 } else {
1239 rename puts {}
6d368502 1240 rename puts-saved puts
1241 dlog off
1242 }
40093367 1243 }
1244
8418c617 1245 # stop cpulimit killer if armed by the test
1246 cpulimit
1247
22db40eb 1248 # add memory and timing info
1249 set stats ""
433673e0 1250 if { ! [catch {uplevel meminfo h} memuse] } {
936f43da 1251 append stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
22db40eb 1252 }
40093367 1253 uplevel dchrono _timer stop
1254 set time [uplevel dchrono _timer show]
936f43da 1255 if { [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu_usr] } {
6d368502 1256 append stats "TOTAL CPU TIME: $cpu_usr sec\n"
22db40eb 1257 }
1258 if { $dlog_exists && ! $echo } {
6d368502 1259 dlog add $stats
22db40eb 1260 } else {
6d368502 1261 puts $stats
40093367 1262 }
936f43da 1263
1264 # unset global vars
1265 uplevel unset casename groupname gridname dirname
1266 if { $tmp_imagedir } { uplevel unset imagedir test_image }
40093367 1267}
1268
1269# Internal procedure to check log of test execution and decide if it passed or failed
5fd3308a 1270proc _check_log {dir group gridname casename errors log {_summary {}} {_html_log {}}} {
40093367 1271 global env
1272 if { $_summary != "" } { upvar $_summary summary }
1273 if { $_html_log != "" } { upvar $_html_log html_log }
9753e6de 1274 set summary {}
1275 set html_log {}
5fd3308a 1276 set errors_log {}
40093367 1277
6d368502 1278 if [catch {
1279
1280 # load definition of 'bad words' indicating test failure
1281 # note that rules are loaded in the order of decreasing priority (grid - group - common),
1282 # thus grid rules will override group ones
1283 set badwords {}
1284 foreach rulesfile [list $dir/$group/$gridname/parse.rules $dir/$group/parse.rules $dir/parse.rules] {
1285 if [catch {set fd [open $rulesfile r]}] { continue }
1286 while { [gets $fd line] >= 0 } {
1287 # skip comments and empty lines
1288 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
1289 if { [string trim $line] == "" } { continue }
1290 # extract regexp
1291 if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } {
1292 puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
1293 continue
1294 }
1295 set status [string trim $status]
1296 if { $comment != "" } { append status " ([string trim $comment])" }
1297 set rexp [regsub -all {\\b} $rexp {\\y}] ;# convert regexp from Perl to Tcl style
1298 lappend badwords [list $status $rexp]
1299 }
1300 close $fd
1301 }
1302 if { [llength $badwords] <= 0 } {
1303 puts "Warning: no definition of error indicators found (check files parse.rules)"
1304 }
1305
1306 # analyse log line-by-line
1307 set todos {} ;# TODO statements
1308 set requs {} ;# REQUIRED statements
1309 set todo_incomplete -1
1310 set status ""
1311 foreach line [split $log "\n"] {
1312 # check if line defines specific treatment of some messages
1313 if [regexp -nocase {^[ \s]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
1314 if { ! [regexp -nocase {\mAll\M} $platforms] &&
863f782a 1315 ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
6d368502 1316 lappend html_log [_html_highlight IGNORE $line]
1317 continue ;# TODO statement is for another platform
1318 }
1319
1320 # record TODOs that mark unstable cases
1321 if { [regexp {[\?]} $platforms] } {
1322 set todos_unstable([llength $todos]) 1
1323 }
1324
1325 # convert legacy regexps from Perl to Tcl style
1326 set pattern [regsub -all {\\b} [string trim $pattern] {\\y}]
1327
1328 # special case: TODO TEST INCOMPLETE
1329 if { [string trim $pattern] == "TEST INCOMPLETE" } {
1330 set todo_incomplete [llength $todos]
1331 }
1332
1333 lappend todos [list $pattern [llength $html_log] $line]
1334 lappend html_log [_html_highlight BAD $line]
1335 continue
1336 }
1337 if [regexp -nocase {^[ \s]*REQUIRED ([^:]*):[ \s]*(.*)$} $line res platforms pattern] {
1338 if { ! [regexp -nocase {\mAll\M} $platforms] &&
863f782a 1339 ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
6d368502 1340 lappend html_log [_html_highlight IGNORE $line]
1341 continue ;# REQUIRED statement is for another platform
1342 }
1343 lappend requs [list $pattern [llength $html_log] $line]
1344 lappend html_log [_html_highlight OK $line]
1345 continue
1346 }
1347
1348 # check for presence of required messages
1349 set ismarked 0
1350 for {set i 0} {$i < [llength $requs]} {incr i} {
1351 set pattern [lindex $requs $i 0]
1352 if { [regexp $pattern $line] } {
1353 incr required_count($i)
1354 lappend html_log [_html_highlight OK $line]
1355 set ismarked 1
1356 continue
1357 }
1358 }
1359 if { $ismarked } {
1360 continue
1361 }
1362
1363 # check for presence of messages indicating test result
1364 foreach bw $badwords {
1365 if { [regexp [lindex $bw 1] $line] } {
1366 # check if this is known bad case
1367 set is_known 0
1368 for {set i 0} {$i < [llength $todos]} {incr i} {
1369 set pattern [lindex $todos $i 0]
1370 if { [regexp $pattern $line] } {
1371 set is_known 1
1372 incr todo_count($i)
1373 lappend html_log [_html_highlight BAD $line]
1374 break
1375 }
1376 }
1377
1378 # if it is not in todo, define status
1379 if { ! $is_known } {
1380 set stat [lindex $bw 0 0]
1381 if {$errors} {
1382 lappend errors_log $line
1383 }
1384 lappend html_log [_html_highlight $stat $line]
1385 if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
1386 set status [lindex $bw 0]
1387 }
1388 }
1389 set ismarked 1
1390 break
1391 }
1392 }
1393 if { ! $ismarked } {
1394 lappend html_log $line
1395 }
1396 }
1397
1398 # check for presence of TEST COMPLETED statement
1399 if { $status == "" && ! [regexp {TEST COMPLETED} $log] } {
1400 # check whether absence of TEST COMPLETED is known problem
1401 if { $todo_incomplete >= 0 } {
1402 incr todo_count($todo_incomplete)
1403 } else {
1404 set status "FAILED (no final message is found)"
1405 }
1406 }
1407
1408 # report test as failed if it doesn't contain required pattern
1409 if { $status == "" } {
1410 for {set i 0} {$i < [llength $requs]} {incr i} {
1411 if { ! [info exists required_count($i)] } {
1412 set linenum [lindex $requs $i 1]
1413 set html_log [lreplace $html_log $linenum $linenum [_html_highlight FAILED [lindex $requs $i 2]]]
1414 set status "FAILED (REQUIRED statement no. [expr $i + 1] is not found)"
1415 }
1416 }
1417 }
1418
1419 # check declared bad cases and diagnose possible improvement
1420 # (bad case declared but not detected).
1421 # Note that absence of the problem marked by TODO with question mark
1422 # (unstable) is not reported as improvement.
1423 if { $status == "" } {
1424 for {set i 0} {$i < [llength $todos]} {incr i} {
1425 if { ! [info exists todos_unstable($i)] &&
1426 (! [info exists todo_count($i)] || $todo_count($i) <= 0) } {
1427 set linenum [lindex $todos $i 1]
1428 set html_log [lreplace $html_log $linenum $linenum [_html_highlight IMPROVEMENT [lindex $todos $i 2]]]
1429 set status "IMPROVEMENT (expected problem TODO no. [expr $i + 1] is not detected)"
1430 break;
1431 }
1432 }
1433 }
1434
1435 # report test as known bad if at least one of expected problems is found
1436 if { $status == "" && [llength [array names todo_count]] > 0 } {
1437 set status "BAD (known problem)"
1438 }
1439
1440 # report normal OK
1441 if { $status == "" } {set status "OK" }
1442
1443 } res] {
1444 set status "FAILED ($res)"
1445 }
40093367 1446
1447 # put final message
1448 _log_and_puts summary "CASE $group $gridname $casename: $status"
9753e6de 1449 set summary [join $summary "\n"]
5fd3308a 1450 if {$errors} {
6d368502 1451 foreach error $errors_log {
1452 _log_and_puts summary " $error"
1453 }
5fd3308a 1454 }
9753e6de 1455 set html_log "[_html_highlight [lindex $status 0] $summary]\n[join $html_log \n]"
40093367 1456}
1457
1458# Auxiliary procedure putting message to both cout and log variable (list)
1459proc _log_and_puts {logvar message} {
1460 if { $logvar != "" } {
6d368502 1461 upvar $logvar log
1462 lappend log $message
40093367 1463 }
1464 puts $message
1465}
1466
1467# Auxiliary procedure to log result on single test case
1468proc _log_test_case {output logdir dir group grid casename logvar} {
1469 upvar $logvar log
5fd3308a 1470 set show_errors 0
40093367 1471 # check result and make HTML log
5fd3308a 1472 _check_log $dir $group $grid $casename $show_errors $output summary html_log
9753e6de 1473 lappend log $summary
40093367 1474
1475 # save log to file
1476 if { $logdir != "" } {
6d368502 1477 _log_html $logdir/$group/$grid/$casename.html $html_log "Test $group $grid $casename"
1478 _log_save $logdir/$group/$grid/$casename.log "$output\n$summary" "Test $group $grid $casename"
40093367 1479 }
1480}
1481
1482# Auxiliary procedure to save log to file
1483proc _log_save {file log {title {}}} {
1484 # create missing directories as needed
1485 catch {file mkdir [file dirname $file]}
1486
1487 # try to open a file
1488 if [catch {set fd [open $file w]} res] {
6d368502 1489 error "Error saving log file $file: $res"
40093367 1490 }
1491
1492 # dump log and close
1493 puts $fd "$title\n"
1494 puts $fd $log
1495 close $fd
1496 return
1497}
1498
22db40eb 1499# Auxiliary procedure to make a (relative if possible) URL to a file for
1500# inclusion a reference in HTML log
1501proc _make_url {htmldir file} {
1502 set htmlpath [file split [file normalize $htmldir]]
1503 set filepath [file split [file normalize $file]]
1504 for {set i 0} {$i < [llength $htmlpath]} {incr i} {
1505 if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
1506 if { $i == 0 } { break }
1507 return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
1508 }
1509 }
1510
1511 # if relative path could not be made, return full file URL
1512 return "file://[file normalize $file]"
1513}
1514
40093367 1515# Auxiliary procedure to save log to file
1516proc _log_html {file log {title {}}} {
1517 # create missing directories as needed
1518 catch {file mkdir [file dirname $file]}
1519
1520 # try to open a file
1521 if [catch {set fd [open $file w]} res] {
6d368502 1522 error "Error saving log file $file: $res"
40093367 1523 }
1524
1525 # print header
22db40eb 1526 puts $fd "<html><head><title>$title</title></head><body><h1>$title</h1>"
40093367 1527
ffc26091 1528 # add images if present; these should have either PNG, GIF, or JPG extension,
1529 # and start with name of the test script, with optional suffix separated
1530 # by underscore or dash
40093367 1531 set imgbasename [file rootname [file tail $file]]
ffc26091 1532 foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails \
1533 ${imgbasename}.gif ${imgbasename}.png ${imgbasename}.jpg \
1534 ${imgbasename}_*.gif ${imgbasename}_*.png ${imgbasename}_*.jpg \
1535 ${imgbasename}-*.gif ${imgbasename}-*.png ${imgbasename}-*.jpg]] {
6d368502 1536 puts $fd "<p>[file tail $img]<br><img src=\"$img\"/><p>"
40093367 1537 }
1538
b725d7c5 1539 # print log body, trying to add HTML links to script files on lines like
1540 # "Executing <filename>..."
40093367 1541 puts $fd "<pre>"
b725d7c5 1542 foreach line [split $log "\n"] {
1543 if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
1544 [file exists $script] } {
22db40eb 1545 set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
b725d7c5 1546 }
1547 puts $fd $line
1548 }
40093367 1549 puts $fd "</pre></body></html>"
1550
1551 close $fd
1552 return
1553}
1554
1555# Auxiliary method to make text with HTML highlighting according to status
1556proc _html_color {status} {
1557 # choose a color for the cell according to result
1558 if { $status == "OK" } {
6d368502 1559 return lightgreen
40093367 1560 } elseif { [regexp -nocase {^FAIL} $status] } {
77887d30 1561 return ff8080
40093367 1562 } elseif { [regexp -nocase {^BAD} $status] } {
6d368502 1563 return yellow
40093367 1564 } elseif { [regexp -nocase {^IMP} $status] } {
6d368502 1565 return orange
40093367 1566 } elseif { [regexp -nocase {^SKIP} $status] } {
6d368502 1567 return gray
40093367 1568 } elseif { [regexp -nocase {^IGNOR} $status] } {
6d368502 1569 return gray
40093367 1570 } else {
6d368502 1571 puts "Warning: no color defined for status $status, using red as if FAILED"
1572 return red
40093367 1573 }
1574}
1575
1576# Format text line in HTML to be colored according to the status
1577proc _html_highlight {status line} {
1578 return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
1579}
1580
1581# Internal procedure to generate HTML page presenting log of the tests
1582# execution in tabular form, with links to reports on individual cases
4514dc74 1583proc _log_html_summary {logdir log totals regressions improvements skipped total_time} {
40093367 1584 global _test_case_regexp
1585
9753e6de 1586 # create missing directories as needed
1587 file mkdir $logdir
40093367 1588
1589 # try to open a file and start HTML
1590 if [catch {set fd [open $logdir/summary.html w]} res] {
6d368502 1591 error "Error creating log file: $res"
40093367 1592 }
1593
1594 # write HRML header, including command to refresh log if still in progress
1595 puts $fd "<html><head>"
1596 puts $fd "<title>Tests summary</title>"
1597 if { $total_time == "" } {
6d368502 1598 puts $fd "<meta http-equiv=\"refresh\" content=\"10\">"
40093367 1599 }
1600 puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
1601 puts $fd "</head><body>"
1602
1603 # put summary
1604 set legend(OK) "Test passed OK"
1605 set legend(FAILED) "Test failed (regression)"
1606 set legend(BAD) "Known problem"
1607 set legend(IMPROVEMENT) "Possible improvement (expected problem not detected)"
1608 set legend(SKIPPED) "Test skipped due to lack of data file"
1609 puts $fd "<h1>Summary</h1><table>"
1610 foreach nbstat $totals {
6d368502 1611 set status [lindex $nbstat 1]
1612 if { [info exists legend($status)] } {
1613 set comment $legend($status)
1614 } else {
1615 set comment "User-defined status"
1616 }
1617 puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
40093367 1618 }
1619 puts $fd "</table>"
1620
1621 # time stamp and elapsed time info
1622 if { $total_time != "" } {
6d368502 1623 puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname]\n<p>"
8a262fa1 1624 puts $fd [join [split $total_time "\n"] "<p>"]
40093367 1625 } else {
6d368502 1626 puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
40093367 1627 }
1628
1629 # print regressions and improvements
4514dc74 1630 foreach featured [list $regressions $improvements $skipped] {
6d368502 1631 if { [llength $featured] <= 1 } { continue }
1632 set status [string trim [lindex $featured 0] { :}]
1633 puts $fd "<h2>$status</h2>"
1634 puts $fd "<table>"
1635 set groupgrid ""
1636 foreach test [lrange $featured 1 end] {
1637 if { ! [regexp {^(.*)\s+([\w.]+)$} $test res gg name] } {
1638 set gg UNKNOWN
1639 set name "Error building short list; check details"
1640 }
1641 if { $gg != $groupgrid } {
1642 if { $groupgrid != "" } { puts $fd "</tr>" }
1643 set groupgrid $gg
1644 puts $fd "<tr><td>$gg</td>"
1645 }
1646 puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
1647 }
1648 if { $groupgrid != "" } { puts $fd "</tr>" }
1649 puts $fd "</table>"
40093367 1650 }
1651
9753e6de 1652 # put detailed log with TOC
1653 puts $fd "<hr><h1>Details</h1>"
1654 puts $fd "<div style=\"float:right; padding: 10px; border-style: solid; border-color: blue; border-width: 2px;\">"
40093367 1655
1656 # process log line-by-line
1657 set group {}
1658 set letter {}
9753e6de 1659 set body {}
1660 foreach line [lsort -dictionary $log] {
6d368502 1661 # check that the line is case report in the form "CASE group grid name: result (explanation)"
1662 if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1663 continue
1664 }
1665
1666 # start new group
1667 if { $grp != $group } {
1668 if { $letter != "" } { lappend body "</tr></table>" }
1669 set letter {}
1670 set group $grp
1671 set grid {}
1672 puts $fd "<a href=\"#$group\">$group</a><br>"
1673 lappend body "<h2><a name=\"$group\">Group $group</a></h2>"
1674 }
1675
1676 # start new grid
1677 if { $grd != $grid } {
1678 if { $letter != "" } { lappend body "</tr></table>" }
1679 set letter {}
1680 set grid $grd
1681 puts $fd "&nbsp;&nbsp;&nbsp;&nbsp;<a href=\"#$group-$grid\">$grid</a><br>"
1682 lappend body "<h2><a name=\"$group-$grid\">Grid $group $grid</a></h2>"
1683 }
1684
1685 # check if test case name is <letter><digit>;
1686 # if not, set alnum to period "." to recognize non-standard test name
1687 if { ! [regexp {\A([A-Za-z]{1,2})([0-9]{1,2})\Z} $casename res alnum number] &&
9753e6de 1688 ! [regexp {\A([A-Za-z0-9]+)_([0-9]+)\Z} $casename res alnum number] } {
6d368502 1689 set alnum $casename
1690 }
40093367 1691
6d368502 1692 # start new row when letter changes or for non-standard names
1693 if { $alnum != $letter || $alnum == "." } {
1694 if { $letter != "" } {
1695 lappend body "</tr><tr>"
1696 } else {
1697 lappend body "<table><tr>"
1698 }
1699 set letter $alnum
1700 }
40093367 1701
6d368502 1702 lappend body "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
40093367 1703 }
9753e6de 1704 puts $fd "</div>\n[join $body "\n"]</tr></table>"
40093367 1705
1706 # add remaining lines of log as plain text
1707 puts $fd "<h2>Plain text messages</h2>\n<pre>"
9753e6de 1708 foreach line $log {
6d368502 1709 if { ! [regexp $_test_case_regexp $line] } {
1710 puts $fd "$line"
1711 }
40093367 1712 }
1713 puts $fd "</pre>"
1714
1715 # close file and exit
1716 puts $fd "</body>"
1717 close $fd
1718 return
1719}
1720
1721# Procedure to dump summary logs of tests
1722proc _log_summarize {logdir log {total_time {}}} {
1723
1724 # sort log records alphabetically to have the same behavior on Linux and Windows
1725 # (also needed if tests are run in parallel)
9753e6de 1726 set loglist [lsort -dictionary $log]
40093367 1727
1728 # classify test cases by status
1729 foreach line $loglist {
6d368502 1730 if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
1731 lappend stat($status) $caseid
1732 }
40093367 1733 }
1734 set totals {}
1735 set improvements {Improvements:}
1736 set regressions {Failed:}
4514dc74 1737 set skipped {Skipped:}
40093367 1738 if { [info exists stat] } {
6d368502 1739 foreach status [lsort [array names stat]] {
1740 lappend totals [list [llength $stat($status)] $status]
1741
4514dc74 1742 # separately count improvements (status starting with IMP), skipped (status starting with SKIP) and regressions (all except IMP, OK, BAD, and SKIP)
6d368502 1743 if { [regexp -nocase {^IMP} $status] } {
1744 eval lappend improvements $stat($status)
4514dc74 1745 } elseif { [regexp -nocase {^SKIP} $status] } {
1746 eval lappend skipped $stat($status)
6d368502 1747 } elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
1748 eval lappend regressions $stat($status)
1749 }
1750 }
40093367 1751 }
1752
1753 # if time is specified, add totals
1754 if { $total_time != "" } {
6d368502 1755 if { [llength $improvements] > 1 } {
1756 _log_and_puts log [join $improvements "\n "]
1757 }
1758 if { [llength $regressions] > 1 } {
1759 _log_and_puts log [join $regressions "\n "]
1760 }
4514dc74 1761 if { [llength $skipped] > 1 } {
1762 _log_and_puts log [join $skipped "\n "]
1763 }
6d368502 1764 if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
1765 _log_and_puts log "No regressions"
1766 }
1767 _log_and_puts log "Total cases: [join $totals {, }]"
1768 _log_and_puts log $total_time
40093367 1769 }
1770
1771 # save log to files
1772 if { $logdir != "" } {
4514dc74 1773 _log_html_summary $logdir $log $totals $regressions $improvements $skipped $total_time
6d368502 1774 _log_save $logdir/tests.log [join $log "\n"] "Tests summary"
40093367 1775 }
1776
1777 return
1778}
1779
1780# Internal procedure to generate XML log in JUnit style, for further
1781# consumption by Jenkins or similar systems.
1782#
1783# The output is intended to conform to XML schema supported by Jenkins found at
1784# 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
1785#
1786# The mapping of the fields is inspired by annotated schema of Apache Ant JUnit XML format found at
1787# http://windyroad.org/dl/Open%20Source/JUnit.xsd
1788proc _log_xml_summary {logdir filename log include_cout} {
1789 global _test_case_regexp
1790
1791 catch {file mkdir [file dirname $filename]}
1792
1793 # try to open a file and start XML
1794 if [catch {set fd [open $filename w]} res] {
6d368502 1795 error "Error creating XML summary file $filename: $res"
40093367 1796 }
1797 puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1798 puts $fd "<testsuites>"
1799
1800 # prototype for command to generate test suite tag
1801 set time_and_host "timestamp=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\" hostname=\"[info hostname]\""
1802 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"}
1803
1804 # sort log and process it line-by-line
1805 set group {}
9753e6de 1806 foreach line [lsort -dictionary $log] {
6d368502 1807 # check that the line is case report in the form "CASE group grid name: result (explanation)"
1808 if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1809 continue
1810 }
1811 set message [string trim $message " \t\r\n()"]
1812
1813 # start new testsuite for each grid
1814 if { $grp != $group || $grd != $grid } {
1815
1816 # write previous test suite
1817 if [info exists testcases] { eval $cmd_testsuite }
1818
1819 set testcases {}
1820 set nbtests 0
1821 set nberr 0
1822 set nbfail 0
1823 set nbskip 0
1824 set time 0.
1825
1826 set group $grp
1827 set grid $grd
1828 }
1829
1830 incr nbtests
1831
1832 # parse test log and get its CPU time
1833 set testout {}
1834 set add_cpu {}
1835 if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } {
1836 puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1837 } else {
1838 while { [gets $fdlog logline] >= 0 } {
1839 if { $include_cout } {
1840 append testout "$logline\n"
1841 }
1842 if [regexp -nocase {TOTAL CPU TIME:\s*([\d.]+)\s*sec} $logline res cpu] {
1843 set add_cpu " time=\"$cpu\""
1844 set time [expr $time + $cpu]
1845 }
1846 }
1847 close $fdlog
1848 }
1849 if { ! $include_cout } {
40093367 1850 set testout "$line\n"
6d368502 1851 }
1852
1853 # record test case with its output and status
1854 # Mapping is: SKIPPED, BAD, and OK to OK, all other to failure
1855 append testcases "\n <testcase name=\"$casename\"$add_cpu status=\"$result\">\n"
1856 append testcases "\n <system-out>\n$testout </system-out>"
1857 if { $result != "OK" } {
1858 if { [regexp -nocase {^SKIP} $result] } {
1859 incr nberr
1860 append testcases "\n <error name=\"$result\" message=\"$message\"/>"
1861 } elseif { [regexp -nocase {^BAD} $result] } {
1862 incr nbskip
1863 append testcases "\n <skipped>$message</skipped>"
1864 } else {
1865 incr nbfail
1866 append testcases "\n <failure name=\"$result\" message=\"$message\"/>"
1867 }
1868 }
1869 append testcases "\n </testcase>"
40093367 1870 }
1871
1872 # write last test suite
1873 if [info exists testcases] { eval $cmd_testsuite }
1874
1875 # the end
1876 puts $fd "</testsuites>"
1877 close $fd
1878 return
1879}
1880
40093367 1881# Auxiliary procedure to split path specification (usually defined by
1882# environment variable) into list of directories or files
1883proc _split_path {pathspec} {
1884 global tcl_platform
1885
1886 # first replace all \ (which might occur on Windows) by /
1887 regsub -all "\\\\" $pathspec "/" pathspec
1888
1889 # split path by platform-specific separator
1890 return [split $pathspec [_path_separator]]
1891}
1892
1893# Auxiliary procedure to define platform-specific separator for directories in
1894# path specification
1895proc _path_separator {} {
1896 global tcl_platform
1897
1898 # split path by platform-specific separator
1899 if { $tcl_platform(platform) == "windows" } {
6d368502 1900 return ";"
40093367 1901 } else {
6d368502 1902 return ":"
40093367 1903 }
1904}
1905
cc6a292d 1906# Procedure to make a diff and common of two lists
1907proc _list_diff {list1 list2 _in1 _in2 _common} {
1908 upvar $_in1 in1
1909 upvar $_in2 in2
1910 upvar $_common common
1911
1912 set in1 {}
1913 set in2 {}
1914 set common {}
1915 foreach item $list1 {
6d368502 1916 if { [lsearch -exact $list2 $item] >= 0 } {
1917 lappend common $item
cc6a292d 1918 } else {
6d368502 1919 lappend in1 $item
1920 }
cc6a292d 1921 }
1922 foreach item $list2 {
6d368502 1923 if { [lsearch -exact $common $item] < 0 } {
1924 lappend in2 $item
1925 }
cc6a292d 1926 }
1927 return
1928}
1929
1930# procedure to load a file to Tcl string
1931proc _read_file {filename} {
1932 set fd [open $filename r]
1933 set result [read -nonewline $fd]
1934 close $fd
1935 return $result
1936}
1937
22db40eb 1938# procedure to construct name for the mage diff file
1939proc _diff_img_name {dir1 dir2 casepath imgfile} {
1940 return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
1941}
1942
936f43da 1943# auxiliary procedure to produce string comparing two values
1944proc _diff_show_ratio {value1 value2} {
6ae07908 1945 if {[expr double ($value2)] == 0.} {
1946 return "$value1 / $value2"
1947 } else {
1948 return "$value1 / $value2 \[[format "%+5.2f%%" [expr 100 * ($value1 - $value2) / double($value2)]]\]"
1949 }
936f43da 1950}
1951
44fae8b1 1952# procedure to check cpu user time
1953proc _check_time {regexp_msg} {
1954 upvar log log
1955 upvar log1 log1
1956 upvar log2 log2
1957 upvar log_cpu log_cpu
1958 upvar cpu cpu
1959 upvar basename basename
1960 upvar casename casename
1961 set time1_list [dict create]
1962 set time2_list [dict create]
1963 set cpu_find UNDEFINED
1964
1965 foreach line1 [split $log1 "\n"] {
1966 if { [regexp "${regexp_msg}" $line1 dump chronometer_name cpu_find] } {
1967 dict set time1_list "${chronometer_name}" "${cpu_find}"
1968 }
1969 }
1970
1971 foreach line2 [split $log2 "\n"] {
1972 if { [regexp "${regexp_msg}" $line2 dump chronometer_name cpu_find] } {
1973 dict set time2_list "${chronometer_name}" "${cpu_find}"
1974 }
1975 }
1976
1977 if { [llength [dict keys $time1_list]] != [llength [dict keys $time2_list]] } {
1978 puts "Error: number of dchrono/chrono COUNTER are different in the same test cases"
1979 } else {
1980 foreach key [dict keys $time1_list] {
1981 set time1 [dict get $time1_list $key]
1982 set time2 [dict get $time2_list $key]
1983
1984 # compare CPU user time with 10% precision (but not less 0.5 sec)
1985 if { [expr abs ($time1 - $time2) > 0.5 + 0.05 * abs ($time1 + $time2)] } {
1986 if {$cpu != false} {
1987 _log_and_puts log_cpu "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
1988 } else {
1989 _log_and_puts log "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
1990 }
1991 }
1992 }
1993 }
1994}
1995
cc6a292d 1996# Procedure to compare results of two runs of test cases
28cab376 1997proc _test_diff {dir1 dir2 basename image cpu memory status verbose _logvar _logimage _logcpu _logmemory {_statvar ""}} {
cc6a292d 1998 upvar $_logvar log
28cab376 1999 upvar $_logimage log_image
2000 upvar $_logcpu log_cpu
2001 upvar $_logmemory log_memory
cc6a292d 2002
22db40eb 2003 # make sure to load diffimage command
2004 uplevel pload VISUALIZATION
2005
cc6a292d 2006 # prepare variable (array) for collecting statistics
2007 if { "$_statvar" != "" } {
2008 upvar $_statvar stat
2009 } else {
2010 set stat(cpu1) 0
2011 set stat(cpu2) 0
22db40eb 2012 set stat(mem1) 0
2013 set stat(mem2) 0
cc6a292d 2014 set log {}
28cab376 2015 set log_image {}
2016 set log_cpu {}
2017 set log_memory {}
cc6a292d 2018 }
2019
2020 # first check subdirectories
2021 set path1 [file join $dir1 $basename]
2022 set path2 [file join $dir2 $basename]
2023 set list1 [glob -directory $path1 -types d -tails -nocomplain *]
2024 set list2 [glob -directory $path2 -types d -tails -nocomplain *]
2025 if { [llength $list1] >0 || [llength $list2] > 0 } {
2026 _list_diff $list1 $list2 in1 in2 common
2027 if { "$verbose" > 1 } {
2028 if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2029 if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2030 }
2031 foreach subdir $common {
2032 if { "$verbose" > 2 } {
6d368502 2033 _log_and_puts log "Checking [file join $basename $subdir]"
2034 }
28cab376 2035 _test_diff $dir1 $dir2 [file join $basename $subdir] $image $cpu $memory $status $verbose log log_image log_cpu log_memory stat
cc6a292d 2036 }
2037 } else {
2038 # check log files (only if directory has no subdirs)
2039 set list1 [glob -directory $path1 -types f -tails -nocomplain *.log]
2040 set list2 [glob -directory $path2 -types f -tails -nocomplain *.log]
2041 _list_diff $list1 $list2 in1 in2 common
2042 if { "$verbose" > 1 } {
2043 if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2044 if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2045 }
936f43da 2046 set gcpu1 0
2047 set gcpu2 0
2048 set gmem1 0
2049 set gmem2 0
cc6a292d 2050 foreach logfile $common {
2051 # load two logs
6d368502 2052 set log1 [_read_file [file join $dir1 $basename $logfile]]
2053 set log2 [_read_file [file join $dir2 $basename $logfile]]
22db40eb 2054 set casename [file rootname $logfile]
28cab376 2055
cc6a292d 2056 # check execution statuses
28cab376 2057 if {$image == false && $cpu == false && $memory == false} {
2058 set status1 UNDEFINED
2059 set status2 UNDEFINED
2060 if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
2061 ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
2062 "$status1" != "$status2" } {
2063 _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
2064 # if test statuses are different, further comparison makes
2065 # no sense unless explicitly requested
2066 if { "$status" != "all" } {
2067 continue
2068 }
2069 }
2070 if { "$status" == "ok" && "$status1" != "OK" } {
cc6a292d 2071 continue
6d368502 2072 }
2073 }
44fae8b1 2074
2075 if { ! $image } {
2076 # check CPU user time in test cases
2077 set checkCPURegexp "COUNTER (.+): (\[-0-9.+eE\]+)"
2078 if { [regexp "${checkCPURegexp}" $log1] &&
2079 [regexp "${checkCPURegexp}" $log2] } {
2080 _check_time "${checkCPURegexp}"
2081 }
2082 }
28cab376 2083
cc6a292d 2084 # check CPU times
28cab376 2085 if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2086 set cpu1 UNDEFINED
2087 set cpu2 UNDEFINED
2088 if { [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log1 res1 cpu1] &&
2089 [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log2 res1 cpu2] } {
2090 set stat(cpu1) [expr $stat(cpu1) + $cpu1]
2091 set stat(cpu2) [expr $stat(cpu2) + $cpu2]
2092 set gcpu1 [expr $gcpu1 + $cpu1]
2093 set gcpu2 [expr $gcpu2 + $cpu2]
2094
2095 # compare CPU times with 10% precision (but not less 0.5 sec)
2096 if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
2097 if {$cpu != false} {
2098 _log_and_puts log_cpu "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2099 } else {
2100 _log_and_puts log "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2101 }
2102 }
cc6a292d 2103 }
6d368502 2104 }
22db40eb 2105
2106 # check memory delta
28cab376 2107 if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2108 set mem1 UNDEFINED
2109 set mem2 UNDEFINED
2110 if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
2111 [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
2112 set stat(mem1) [expr $stat(mem1) + $mem1]
2113 set stat(mem2) [expr $stat(mem2) + $mem2]
2114 set gmem1 [expr $gmem1 + $mem1]
2115 set gmem2 [expr $gmem2 + $mem2]
2116
2117 # compare memory usage with 10% precision (but not less 16 KiB)
2118 if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
2119 if {$memory != false} {
2120 _log_and_puts log_memory "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2121 } else {
2122 _log_and_puts log "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2123 }
2124 }
22db40eb 2125 }
6d368502 2126 }
22db40eb 2127
2128 # check images
28cab376 2129 if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2130 set imglist1 [glob -directory $path1 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2131 set imglist2 [glob -directory $path2 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2132 _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
2133 if { "$verbose" > 1 } {
2134 if { [llength $imgin1] > 0 } {
2135 if {$image != false} {
2136 _log_and_puts log_image "Only in $path1: $imgin1"
2137 } else {
2138 _log_and_puts log "Only in $path1: $imgin1"
2139 }
2140 }
2141 if { [llength $imgin2] > 0 } {
2142 if {$image != false} {
2143 _log_and_puts log_image "Only in $path2: $imgin2"
2144 } else {
2145 _log_and_puts log "Only in $path2: $imgin2"
2146 }
2147 }
2148 }
2149 foreach imgfile $imgcommon {
2150 # if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
2151 set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
2152 if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2153 [file join $dir2 $basename $imgfile] \
2154 0 0 0 $diffile} diff] } {
2155 if {$image != false} {
2156 _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2157 } else {
2158 _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2159 }
2160 file delete -force $diffile ;# clean possible previous result of diffimage
2161 } elseif { $diff != 0 } {
2162 if {$image != false} {
2163 _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile differs"
2164 } else {
2165 _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs"
2166 }
2167 } else {
2168 file delete -force $diffile ;# clean useless artifact of diffimage
2169 }
22db40eb 2170 }
2171 }
6d368502 2172 }
936f43da 2173
2174 # report CPU and memory difference in group if it is greater than 10%
28cab376 2175 if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2176 if { [expr abs ($gcpu1 - $gcpu2) > 0.5 + 0.005 * abs ($gcpu1 + $gcpu2)] } {
2177 if {$cpu != false} {
2178 _log_and_puts log_cpu "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2179 } else {
2180 _log_and_puts log "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2181 }
2182 }
936f43da 2183 }
28cab376 2184 if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2185 if { [expr abs ($gmem1 - $gmem2) > 16 + 0.005 * abs ($gmem1 + $gmem2)] } {
2186 if {$memory != false} {
2187 _log_and_puts log_memory "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2188 } else {
2189 _log_and_puts log "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2190 }
2191 }
936f43da 2192 }
cc6a292d 2193 }
2194
2195 if { "$_statvar" == "" } {
28cab376 2196 if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2197 if {$memory != false} {
2198 _log_and_puts log_memory "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2199 } else {
2200 _log_and_puts log "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2201 }
2202 }
2203 if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2204 if {$cpu != false} {
2205 _log_and_puts log_cpu "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2206 } else {
2207 _log_and_puts log "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2208 }
2209 }
cc6a292d 2210 }
2211}
b725d7c5 2212
22db40eb 2213# Auxiliary procedure to save log of results comparison to file
d5f061b6 2214proc _log_html_diff {file log dir1 dir2 highlight_percent} {
22db40eb 2215 # create missing directories as needed
2216 catch {file mkdir [file dirname $file]}
2217
2218 # try to open a file
2219 if [catch {set fd [open $file w]} res] {
6d368502 2220 error "Error saving log file $file: $res"
22db40eb 2221 }
2222
2223 # print header
2224 puts $fd "<html><head><title>Diff $dir1 vs. $dir2</title></head><body>"
433673e0 2225 puts $fd "<h1>Comparison of test results:</h1>"
2226 puts $fd "<h2>Version A - $dir1</h2>"
2227 puts $fd "<h2>Version B - $dir2</h2>"
22db40eb 2228
c231f393 2229 # add script for switching between images on click
2230 puts $fd ""
2231 puts $fd "<script type=\"text/javascript\">"
2232 puts $fd " function diffimage_toggle(img,url1,url2)"
2233 puts $fd " {"
66d61d8a 2234 puts $fd " if (img.show2nd) { img.src = url1; img.show2nd = false; }"
2235 puts $fd " else { img.src = url2; img.show2nd = true; }"
c231f393 2236 puts $fd " }"
66d61d8a 2237 puts $fd " function diffimage_reset(img,url) { img.src = url; img.show2nd = true; }"
c231f393 2238 puts $fd "</script>"
2239 puts $fd ""
2240
2241 # print log body
22db40eb 2242 puts $fd "<pre>"
2243 set logpath [file split [file normalize $file]]
9753e6de 2244 foreach line $log {
d5f061b6 2245 # put a line; highlight considerable (> ${highlight_percent}%) deviations of CPU and memory
936f43da 2246 if { [regexp "\[\\\[](\[0-9.e+-]+)%\[\]]" $line res value] &&
d5f061b6 2247 [expr abs($value)] > ${highlight_percent} } {
77887d30 2248 puts $fd "<table><tr><td bgcolor=\"[expr $value > 0 ? \"ff8080\" : \"lightgreen\"]\">$line</td></tr></table>"
936f43da 2249 } else {
2250 puts $fd $line
2251 }
22db40eb 2252
936f43da 2253 # add images
22db40eb 2254 if { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
2255 if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
6d368502 2256 # note: special handler for the case if test grid directoried are compared directly
2257 set gridpath ""
22db40eb 2258 }
17b45a29 2259 set aCaseName [lindex $case end]
c231f393 2260 set img1url [_make_url $file [file join $dir1 $gridpath $img]]
2261 set img2url [_make_url $file [file join $dir2 $gridpath $img]]
2262 set img1 "<a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\"><img src=\"$img1url\"></a>"
2263 set img2 "<a href=\"[_make_url $file [file join $dir2 $gridpath $aCaseName.html]]\"><img src=\"$img2url\"></a>"
22db40eb 2264
2265 set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
c231f393 2266 set imgdurl [_make_url $file $difffile]
22db40eb 2267 if { [file exists $difffile] } {
c231f393 2268 set imgd "<img src=\"$imgdurl\" onmouseout=diffimage_reset(this,\"$imgdurl\") onclick=diffimage_toggle(this,\"$img1url\",\"$img2url\")>"
22db40eb 2269 } else {
2270 set imgd "N/A"
2271 }
2272
c231f393 2273 puts $fd "<table><tr><th><abbr title=\"$dir1\">Version A</abbr></th><th><abbr title=\"$dir2\">Version B</abbr></th><th>Diff (click to toggle)</th></tr>"
22db40eb 2274 puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
2275 }
2276 }
2277 puts $fd "</pre></body></html>"
2278
2279 close $fd
2280 return
2281}
2282
b725d7c5 2283# get number of CPUs on the system
2284proc _get_nb_cpus {} {
2285 global tcl_platform env
2286
2287 if { "$tcl_platform(platform)" == "windows" } {
2288 # on Windows, take the value of the environment variable
2289 if { [info exists env(NUMBER_OF_PROCESSORS)] &&
2290 ! [catch {expr $env(NUMBER_OF_PROCESSORS) > 0} res] && $res >= 0 } {
2291 return $env(NUMBER_OF_PROCESSORS)
2292 }
2293 } elseif { "$tcl_platform(os)" == "Linux" } {
2294 # on Linux, take number of logical processors listed in /proc/cpuinfo
2295 if { [catch {open "/proc/cpuinfo" r} fd] } {
2296 return 0 ;# should never happen, but...
2297 }
2298 set nb 0
6d368502 2299 while { [gets $fd line] >= 0 } {
2300 if { [regexp {^processor[ \t]*:} $line] } {
2301 incr nb
2302 }
2303 }
b725d7c5 2304 close $fd
2305 return $nb
2306 } elseif { "$tcl_platform(os)" == "Darwin" } {
2307 # on MacOS X, call sysctl command
2308 if { ! [catch {exec sysctl hw.ncpu} ret] &&
2309 [regexp {^hw[.]ncpu[ \t]*:[ \t]*([0-9]+)} $ret res nb] } {
2310 return $nb
2311 }
2312 }
2313
2314 # if cannot get good value, return 0 as default
2315 return 0
2316}
351bbcba 2317
2318# check two files for difference
2319proc _diff_files {file1 file2} {
2320 set fd1 [open $file1 "r"]
2321 set fd2 [open $file2 "r"]
2322
2323 set differ f
2324 while {! $differ} {
2325 set nb1 [gets $fd1 line1]
2326 set nb2 [gets $fd2 line2]
2327 if { $nb1 != $nb2 } { set differ t; break }
2328 if { $nb1 < 0 } { break }
2329 if { [string compare $line1 $line2] } {
2330 set differ t
2331 }
2332 }
2333
2334 close $fd1
2335 close $fd2
2336
2337 return $differ
2338}
2339
2340# Check if file is in DOS encoding.
2341# This check is done by presence of \r\n combination at the end of the first
2342# line (i.e. prior to any other \n symbol).
2343# Note that presence of non-ascii symbols typically used for recognition
2344# of binary files is not suitable since some IGES and STEP files contain
2345# non-ascii symbols.
2346# Special check is added for PNG files which contain \r\n in the beginning.
2347proc _check_dos_encoding {file} {
2348 set fd [open $file rb]
2349 set isdos f
2350 if { [gets $fd line] && [regexp {.*\r$} $line] &&
2351 ! [regexp {^.PNG} $line] } {
2352 set isdos t
2353 }
2354 close $fd
2355 return $isdos
2356}
2357
2358# procedure to recognize format of a data file by its first symbols (for OCCT
2359# BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
2360proc _check_file_format {file} {
2361 set fd [open $file rb]
2362 set line [read $fd 1024]
2363 close $fd
2364
2365 set warn f
2366 set ext [file extension $file]
2367 set format unknown
2368 if { [regexp {^DBRep_DrawableShape} $line] } {
2369 set format BREP
2370 if { "$ext" != ".brep" && "$ext" != ".rle" &&
2371 "$ext" != ".draw" && "$ext" != "" } {
2372 set warn t
2373 }
2374 } elseif { [regexp {^DrawTrSurf_} $line] } {
2375 set format DRAW
2376 if { "$ext" != ".rle" &&
2377 "$ext" != ".draw" && "$ext" != "" } {
2378 set warn t
2379 }
2380 } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
2381 set format STEP
2382 if { "$ext" != ".step" && "$ext" != ".stp" } {
2383 set warn t
2384 }
2385 } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
2386 set format IGES
2387 if { "$ext" != ".iges" && "$ext" != ".igs" } {
2388 set warn t
2389 }
2390 } elseif { "$ext" == ".igs" } {
2391 set format IGES
2392 } elseif { "$ext" == ".stp" } {
2393 set format STEP
2394 } else {
2395 set format [string toupper [string range $ext 1 end]]
2396 }
2397
2398 if { $warn } {
2399 puts "$file: Warning: extension ($ext) does not match format ($format)"
2400 }
2401
2402 return $format
2403}
2404
2405# procedure to load file knowing its format
2406proc load_data_file {file format shape} {
2407 switch $format {
6d368502 2408 BREP { uplevel restore $file $shape }
2409 DRAW { uplevel restore $file $shape }
2410 IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
2411 STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
4eb6e8f4 2412 STL { pload XSDRAW; uplevel readstl $shape $file triangulation }
6d368502 2413 default { error "Cannot read $format file $file" }
351bbcba 2414 }
2415}
60874ff8 2416
2417# procedure to get name of temporary directory,
2418# ensuring it is existing and writeable
2419proc _get_temp_dir {} {
723754e2 2420 global env tcl_platform
60874ff8 2421
2422 # check typical environment variables
2423 foreach var {TempDir Temp Tmp} {
2424 # check different case
2425 foreach name [list [string toupper $var] $var [string tolower $var]] {
2426 if { [info exists env($name)] && [file isdirectory $env($name)] &&
2427 [file writable $env($name)] } {
2428 return [regsub -all {\\} $env($name) /]
2429 }
2430 }
2431 }
2432
2433 # check platform-specific locations
2434 set fallback tmp
2435 if { "$tcl_platform(platform)" == "windows" } {
2436 set paths "c:/TEMP c:/TMP /TEMP /TMP"
2437 if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
338434c7 2438 set fallback [regsub -all {\\} "$env(HOMEDRIVE)$env(HOMEPATH)/tmp" /]
60874ff8 2439 }
2440 } else {
2441 set paths "/tmp /var/tmp /usr/tmp"
2442 if { [info exists env(HOME)] } {
2443 set fallback "$env(HOME)/tmp"
2444 }
2445 }
2446 foreach dir $paths {
723754e2 2447 if { [file isdirectory $dir] && [file writable $dir] } {
60874ff8 2448 return $dir
2449 }
2450 }
2451
2452 # fallback case: use subdir /tmp of home or current dir
2453 file mkdir $fallback
2454 return $fallback
2455}
9753e6de 2456
2457# extract of code from testgrid command used to process jobs running in
2458# parallel until number of jobs in the queue becomes equal or less than
2459# specified value
2460proc _testgrid_process_jobs {worker {nb_ok 0}} {
2461 # bind local vars to variables of the caller procedure
2462 upvar log log
2463 upvar logdir logdir
2464 upvar job_def job_def
2465 upvar nbpooled nbpooled
2466 upvar userbreak userbreak
2467 upvar refresh refresh
2468 upvar refresh_timer refresh_timer
2469
2470 catch {tpool::resume $worker}
2471 while { ! $userbreak && $nbpooled > $nb_ok } {
2472 foreach job [tpool::wait $worker [array names job_def]] {
2473 eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
2474 unset job_def($job)
2475 incr nbpooled -1
2476 }
2477
2478 # check for user break
2479 if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
2480 set userbreak 1
2481 }
2482
2483 # update summary log with requested period
2484 if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
6d368502 2485 _log_summarize $logdir $log
2486 set refresh_timer [clock seconds]
9753e6de 2487 }
2488 }
2489 catch {tpool::suspend $worker}
2490}
ccadc126 2491
2492help checkcolor {
2493 Check pixel color.
2494 Use: checkcolor x y red green blue
2495 x y - pixel coordinates
2496 red green blue - expected pixel color (values from 0 to 1)
2497 Function check color with tolerance (5x5 area)
2498}
2499# Procedure to check color using command vreadpixel with tolerance
2500proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
2501 puts "Coordinate x = $coord_x"
2502 puts "Coordinate y = $coord_y"
2503 puts "RED color of RGB is $rd_get"
2504 puts "GREEN color of RGB is $gr_get"
2505 puts "BLUE color of RGB is $bl_get"
2506
2507 if { $coord_x <= 1 || $coord_y <= 1 } {
6d368502 2508 puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
2509 return -1
ccadc126 2510 }
2511
2512 set color ""
2513 catch { [set color "[vreadpixel ${coord_x} ${coord_y} rgb]"] }
2514 if {"$color" == ""} {
6d368502 2515 puts "Error : Pixel coordinates (${position_x}; ${position_y}) are out of view"
ccadc126 2516 }
2517 set rd [lindex $color 0]
2518 set gr [lindex $color 1]
2519 set bl [lindex $color 2]
2520 set rd_int [expr int($rd * 1.e+05)]
2521 set gr_int [expr int($gr * 1.e+05)]
2522 set bl_int [expr int($bl * 1.e+05)]
2523 set rd_ch [expr int($rd_get * 1.e+05)]
2524 set gr_ch [expr int($gr_get * 1.e+05)]
2525 set bl_ch [expr int($bl_get * 1.e+05)]
2526
2527 if { $rd_ch != 0 } {
6d368502 2528 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
ccadc126 2529 } else {
6d368502 2530 set tol_rd $rd_int
ccadc126 2531 }
2532 if { $gr_ch != 0 } {
6d368502 2533 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
ccadc126 2534 } else {
6d368502 2535 set tol_gr $gr_int
ccadc126 2536 }
2537 if { $bl_ch != 0 } {
6d368502 2538 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
ccadc126 2539 } else {
6d368502 2540 set tol_bl $bl_int
ccadc126 2541 }
2542
2543 set status 0
2544 if { $tol_rd > 0.2 } {
6d368502 2545 puts "Warning : RED light of additive color model RGB is invalid"
2546 set status 1
ccadc126 2547 }
2548 if { $tol_gr > 0.2 } {
6d368502 2549 puts "Warning : GREEN light of additive color model RGB is invalid"
2550 set status 1
ccadc126 2551 }
2552 if { $tol_bl > 0.2 } {
6d368502 2553 puts "Warning : BLUE light of additive color model RGB is invalid"
2554 set status 1
ccadc126 2555 }
2556
2557 if { $status != 0 } {
6d368502 2558 puts "Warning : Colors of default coordinate are not equal"
ccadc126 2559 }
2560
2561 global stat
2562 if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
6d368502 2563 set info [_checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
2564 set stat [lindex $info end]
2565 if { ${stat} != 1 } {
2566 puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
2567 return $stat
2568 } else {
2569 puts "Point with valid color was found"
2570 return $stat
2571 }
ccadc126 2572 } else {
6d368502 2573 set stat 1
ccadc126 2574 }
2575}
2576
2577# Procedure to check color in the point near default coordinate
2578proc _checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
2579 set x_start [expr ${coord_x} - 2]
2580 set y_start [expr ${coord_y} - 2]
2581 set mistake 0
2582 set i 0
2583 while { $mistake != 1 && $i <= 5 } {
6d368502 2584 set j 0
2585 while { $mistake != 1 && $j <= 5 } {
2586 set position_x [expr ${x_start} + $j]
2587 set position_y [expr ${y_start} + $i]
2588 puts $position_x
2589 puts $position_y
2590
2591 set color ""
2592 catch { [set color "[vreadpixel ${position_x} ${position_y} rgb]"] }
2593 if {"$color" == ""} {
2594 puts "Warning : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2595 incr j
2596 continue
2597 }
2598 set rd [lindex $color 0]
2599 set gr [lindex $color 1]
2600 set bl [lindex $color 2]
2601 set rd_int [expr int($rd * 1.e+05)]
2602 set gr_int [expr int($gr * 1.e+05)]
2603 set bl_int [expr int($bl * 1.e+05)]
2604
2605 if { $rd_ch != 0 } {
2606 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2607 } else {
2608 set tol_rd $rd_int
2609 }
2610 if { $gr_ch != 0 } {
2611 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2612 } else {
2613 set tol_gr $gr_int
2614 }
2615 if { $bl_ch != 0 } {
2616 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2617 } else {
2618 set tol_bl $bl_int
2619 }
2620
2621 if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2622 puts "Warning : Point with true color was not found near default coordinates"
2623 set mistake 0
2624 } else {
2625 set mistake 1
2626 }
ccadc126 2627 incr j
6d368502 2628 }
2629 incr i
ccadc126 2630 }
2631 return $mistake
2632}
a2f76b15 2633
2634# Procedure to check if sequence of values in listval follows linear trend
2635# adding the same delta on each step.
2636#
2637# The function does statistical estimation of the mean variation of the
2638# values of the sequence, and dispersion, and returns true only if both
2639# dispersion and deviation of the mean from expected delta are within
2640# specified tolerance.
2641#
2642# If mean variation differs from expected delta on more than two dispersions,
2643# the check fails and procedure raises error with specified message.
2644#
2645# Otherwise the procedure returns false meaning that more iterations are needed.
2646# Note that false is returned in any case if length of listval is less than 3.
2647#
2648# See example of use to check memory leaks in bugs/caf/bug23489
2649#
2650proc checktrend {listval delta tolerance message} {
2651 set nbval [llength $listval]
2652 if { $nbval < 3} {
2653 return 0
2654 }
2655
2656 # calculate mean value
2657 set mean 0.
2658 set prev [lindex $listval 0]
2659 foreach val [lrange $listval 1 end] {
2660 set mean [expr $mean + ($val - $prev)]
2661 set prev $val
2662 }
2663 set mean [expr $mean / ($nbval - 1)]
2664
2665 # calculate dispersion
2666 set sigma 0.
2667 set prev [lindex $listval 0]
2668 foreach val [lrange $listval 1 end] {
2669 set d [expr ($val - $prev) - $mean]
2670 set sigma [expr $sigma + $d * $d]
2671 set prev $val
2672 }
2673 set sigma [expr sqrt ($sigma / ($nbval - 2))]
2674
2675 puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
2676
2677 # check if deviation is definitely too big
2678 if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
2679 puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
2680 error "$message"
2681 }
2682
2683 # check if deviation is clearly within a range
2684 return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
2685}