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