0031171: Draw - support Unicode input / output in console on Windows
[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 # procedure to check cpu user time
2100 proc _check_time {regexp_msg} {
2101     upvar log log
2102     upvar log1 log1
2103     upvar log2 log2
2104     upvar log_cpu log_cpu
2105     upvar cpu cpu
2106     upvar basename basename
2107     upvar casename casename
2108     set time1_list [dict create]
2109     set time2_list [dict create]
2110     set cpu_find UNDEFINED
2111
2112     foreach line1 [split $log1 "\n"] {
2113         if { [regexp "${regexp_msg}" $line1 dump chronometer_name cpu_find] } {
2114             dict set time1_list "${chronometer_name}" "${cpu_find}"
2115         }
2116     }
2117
2118     foreach line2 [split $log2 "\n"] {
2119         if { [regexp "${regexp_msg}" $line2 dump chronometer_name cpu_find] } {
2120             dict set time2_list "${chronometer_name}" "${cpu_find}"
2121         }
2122     }
2123
2124     if { [llength [dict keys $time1_list]] != [llength [dict keys $time2_list]] } {
2125         puts "Error: number of dchrono/chrono COUNTER are different in the same test cases"
2126     } else {
2127         foreach key [dict keys $time1_list] {
2128             set time1 [dict get $time1_list $key]
2129             set time2 [dict get $time2_list $key]
2130
2131             # compare CPU user time with 10% precision (but not less 0.5 sec)
2132             if { [expr abs ($time1 - $time2) > 0.5 + 0.05 * abs ($time1 + $time2)] } {
2133                 if {$cpu != false} {
2134                     _log_and_puts log_cpu "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2135                 } else {
2136                     _log_and_puts log "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2137                 }
2138             }
2139         }
2140     }
2141 }
2142
2143 # Procedure to compare results of two runs of test cases
2144 proc _test_diff {dir1 dir2 basename image cpu memory status verbose _logvar _logimage _logcpu _logmemory {_statvar ""}} {
2145     upvar $_logvar log
2146     upvar $_logimage log_image
2147     upvar $_logcpu log_cpu
2148     upvar $_logmemory log_memory
2149
2150     # make sure to load diffimage command
2151     uplevel pload VISUALIZATION
2152
2153     # prepare variable (array) for collecting statistics
2154     if { "$_statvar" != "" } {
2155         upvar $_statvar stat
2156     } else {
2157         set stat(cpu1) 0
2158         set stat(cpu2) 0
2159         set stat(mem1) 0
2160         set stat(mem2) 0
2161         set log {}
2162         set log_image {}
2163         set log_cpu {}
2164         set log_memory {}
2165     }
2166
2167     # first check subdirectories
2168     set path1 [file join $dir1 $basename]
2169     set path2 [file join $dir2 $basename]
2170     set list1 [glob -directory $path1 -types d -tails -nocomplain *]
2171     set list2 [glob -directory $path2 -types d -tails -nocomplain *]
2172     if { [llength $list1] >0 || [llength $list2] > 0 } {
2173         _list_diff $list1 $list2 in1 in2 common
2174         if { "$verbose" > 1 } {
2175             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2176             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2177         }
2178         foreach subdir $common {
2179             if { "$verbose" > 2 } {
2180                 _log_and_puts log "Checking [file join $basename $subdir]"
2181             }
2182             _test_diff $dir1 $dir2 [file join $basename $subdir] $image $cpu $memory $status $verbose log log_image log_cpu log_memory stat
2183         }
2184     } else {
2185         # check log files (only if directory has no subdirs)
2186         set list1 [glob -directory $path1 -types f -tails -nocomplain *.log]
2187         set list2 [glob -directory $path2 -types f -tails -nocomplain *.log]
2188         _list_diff $list1 $list2 in1 in2 common
2189         if { "$verbose" > 1 } {
2190             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2191             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2192         }
2193         set gcpu1 0
2194         set gcpu2 0
2195         set gmem1 0
2196         set gmem2 0
2197         foreach logfile $common {
2198             # load two logs
2199             set log1 [_read_file [file join $dir1 $basename $logfile]]
2200             set log2 [_read_file [file join $dir2 $basename $logfile]]
2201             set casename [file rootname $logfile]
2202             
2203             # check execution statuses
2204             if {$image == false && $cpu == false && $memory == false} {
2205                 set status1 UNDEFINED
2206                 set status2 UNDEFINED
2207                 if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
2208                     ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
2209                     "$status1" != "$status2" } {
2210                     _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
2211                     # if test statuses are different, further comparison makes 
2212                     # no sense unless explicitly requested
2213                     if { "$status" != "all" } {
2214                         continue
2215                     }
2216                 }
2217                 if { "$status" == "ok" && "$status1" != "OK" } { 
2218                     continue
2219                 }
2220             }
2221
2222             if { ! $image } {
2223                 # check CPU user time in test cases
2224                 set checkCPURegexp "COUNTER (.+): (\[-0-9.+eE\]+)"
2225                 if { [regexp "${checkCPURegexp}" $log1] &&
2226                      [regexp "${checkCPURegexp}" $log2] } {
2227                   _check_time "${checkCPURegexp}"
2228                 }
2229             }
2230             
2231             # check CPU times
2232             if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2233                 set cpu1 UNDEFINED
2234                 set cpu2 UNDEFINED
2235                 if { [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log1 res1 cpu1] &&
2236                      [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log2 res1 cpu2] } {
2237                     set stat(cpu1) [expr $stat(cpu1) + $cpu1]
2238                     set stat(cpu2) [expr $stat(cpu2) + $cpu2]
2239                     set gcpu1 [expr $gcpu1 + $cpu1]
2240                     set gcpu2 [expr $gcpu2 + $cpu2]
2241
2242                     # compare CPU times with 10% precision (but not less 0.5 sec)
2243                     if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
2244                         if {$cpu != false} {
2245                             _log_and_puts log_cpu "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2246                         } else {
2247                             _log_and_puts log "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2248                         }
2249                     }
2250                 }
2251             }
2252
2253             # check memory delta
2254             if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2255                 set mem1 UNDEFINED
2256                 set mem2 UNDEFINED
2257                 if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
2258                      [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
2259                     set stat(mem1) [expr $stat(mem1) + $mem1]
2260                     set stat(mem2) [expr $stat(mem2) + $mem2]
2261                     set gmem1 [expr $gmem1 + $mem1]
2262                     set gmem2 [expr $gmem2 + $mem2]
2263
2264                     # compare memory usage with 10% precision (but not less 16 KiB)
2265                     if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
2266                         if {$memory != false} {
2267                             _log_and_puts log_memory "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2268                         } else {
2269                             _log_and_puts log "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2270                         }
2271                     }
2272                 }
2273             }
2274
2275             # check images
2276             if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2277                 set aCaseDiffColorTol 0
2278                 if { [regexp {IMAGE_COLOR_TOLERANCE:\s*([\d.]+)} $log1 res1 imgtol1] } { set aCaseDiffColorTol $imgtol1 }
2279                 set imglist1 [glob -directory $path1 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2280                 set imglist2 [glob -directory $path2 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2281                 _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
2282                 if { "$verbose" > 1 } {
2283                     if { [llength $imgin1] > 0 } {
2284                         if {$image != false} {
2285                             _log_and_puts log_image "Only in $path1: $imgin1"
2286                         } else {
2287                             _log_and_puts log "Only in $path1: $imgin1"
2288                         }
2289                     }
2290                     if { [llength $imgin2] > 0 } {
2291                         if {$image != false} {
2292                             _log_and_puts log_image "Only in $path2: $imgin2"
2293                         } else {
2294                             _log_and_puts log "Only in $path2: $imgin2"
2295                         }
2296                     }
2297                 }
2298                 foreach imgfile $imgcommon {
2299                     # if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
2300                     set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
2301                     if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2302                                            [file join $dir2 $basename $imgfile] \
2303                                            -toleranceOfColor 0.0 -blackWhite off -borderFilter off $diffile} diff] } {
2304                         if {$image != false} {
2305                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2306                         } else {
2307                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2308                         }
2309                         file delete -force $diffile ;# clean possible previous result of diffimage
2310                     } elseif { $diff != 0 } {
2311                         set diff [string trimright $diff \n]
2312                         if {$aCaseDiffColorTol != 0} {
2313                             # retry with color tolerance
2314                             if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2315                                                    [file join $dir2 $basename $imgfile] \
2316                                                    -toleranceOfColor $aCaseDiffColorTol -blackWhite off -borderFilter off $diffile} diff2] } {
2317                                 if {$image != false} {
2318                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2319                                 } else {
2320                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2321                                 }
2322                                 continue
2323                             } elseif { $diff2 == 0 } {
2324                                 # exclude image diff within tolerance but still keep info in the log
2325                                 set toLogImageCase false
2326                                 file delete -force $diffile
2327                                 if {$image != false} {
2328                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2329                                 } else {
2330                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2331                                 }
2332                                 continue
2333                             }
2334                         }
2335
2336                         if {$image != false} {
2337                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2338                         } else {
2339                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2340                         }
2341                     } else {
2342                         file delete -force $diffile ;# clean useless artifact of diffimage
2343                     }
2344                 }
2345             }
2346         }
2347         
2348         # report CPU and memory difference in group if it is greater than 10%
2349         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2350             if { [expr abs ($gcpu1 - $gcpu2) > 0.5 + 0.005 * abs ($gcpu1 + $gcpu2)] } {
2351                 if {$cpu != false} {
2352                     _log_and_puts log_cpu "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2353                 } else {
2354                     _log_and_puts log "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2355                 }
2356             }
2357         }
2358         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2359             if { [expr abs ($gmem1 - $gmem2) > 16 + 0.005 * abs ($gmem1 + $gmem2)] } {
2360                 if {$memory != false} {
2361                     _log_and_puts log_memory "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2362                 } else {
2363                     _log_and_puts log "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2364                 }
2365             }
2366         }
2367     }
2368
2369     if { "$_statvar" == "" } {
2370         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2371             if {$memory != false} {
2372                 _log_and_puts log_memory "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2373             } else {
2374                 _log_and_puts log "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2375             }
2376         }
2377         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2378             if {$cpu != false} {
2379                 _log_and_puts log_cpu "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2380             } else {
2381                 _log_and_puts log "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2382             }
2383         }
2384     }
2385 }
2386
2387 # Auxiliary procedure to save log of results comparison to file
2388 proc _log_html_diff {file log dir1 dir2 highlight_percent} {
2389     # create missing directories as needed
2390     catch {file mkdir [file dirname $file]}
2391
2392     # try to open a file
2393     if [catch {set fd [open $file w]} res] {
2394         error "Error saving log file $file: $res"
2395     }
2396     
2397     # print header
2398     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
2399     puts $fd "<title>Diff $dir1 vs. $dir2</title></head><body>"
2400     puts $fd "<h1>Comparison of test results:</h1>"
2401     puts $fd "<h2>Version A \[NEW\] - $dir1</h2>"
2402     puts $fd "<h2>Version B \[REF\] - $dir2</h2>"
2403
2404     # add script for switching between images on click
2405     puts $fd ""
2406     puts $fd "<script type=\"text/javascript\">"
2407     puts $fd "  function diffimage_toggle(img,url1,url2)"
2408     puts $fd "  {"
2409     puts $fd "    if (img.show2nd) { img.src = url1; img.show2nd = false; }"
2410     puts $fd "    else { img.src = url2; img.show2nd = true; }"
2411     puts $fd "  }"
2412     puts $fd "  function diffimage_reset(img,url) { img.src = url; img.show2nd = true; }"
2413     puts $fd "</script>"
2414     puts $fd ""
2415
2416     # print log body
2417     puts $fd "<pre>"
2418     set logpath [file split [file normalize $file]]
2419     foreach line $log {
2420         # put a line; highlight considerable (> ${highlight_percent}%) deviations of CPU and memory
2421         if { [regexp "\[\\\[](\[0-9.e+-]+)%\[\]]" $line res value] && 
2422              [expr abs($value)] > ${highlight_percent} } {
2423             puts $fd "<table><tr><td bgcolor=\"[expr $value > 0 ? \"ff8080\" : \"lightgreen\"]\">$line</td></tr></table>"
2424         } elseif { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+) is similar} $line res case img] } {
2425             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2426                 # note: special handler for the case if test grid directoried are compared directly
2427                 set gridpath ""
2428             }
2429             set aCaseName [lindex $case end]
2430             puts $fd "<table><tr><td bgcolor=\"orange\"><a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\">$line</a></td></tr></table>"
2431         } elseif { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
2432             # add images
2433             puts $fd $line
2434             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2435                 # note: special handler for the case if test grid directoried are compared directly
2436                 set gridpath ""
2437             }
2438             set aCaseName [lindex $case end]
2439             set img1url [_make_url $file [file join $dir1 $gridpath $img]]
2440             set img2url [_make_url $file [file join $dir2 $gridpath $img]]
2441             set img1 "<a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\"><img src=\"$img1url\"></a>"
2442             set img2 "<a href=\"[_make_url $file [file join $dir2 $gridpath $aCaseName.html]]\"><img src=\"$img2url\"></a>"
2443
2444             set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
2445             set imgdurl [_make_url $file $difffile]
2446             if { [file exists $difffile] } {
2447                 set imgd "<img src=\"$imgdurl\" onmouseout=diffimage_reset(this,\"$imgdurl\") onclick=diffimage_toggle(this,\"$img1url\",\"$img2url\")>"
2448             } else {
2449                 set imgd "N/A"
2450             }
2451
2452             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>"
2453             puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
2454         } else {
2455             puts $fd $line
2456         }
2457     }
2458     puts $fd "</pre></body></html>"
2459
2460     close $fd
2461     return
2462 }
2463
2464 # get number of CPUs on the system
2465 proc _get_nb_cpus {} {
2466     global tcl_platform env
2467
2468     if { "$tcl_platform(platform)" == "windows" } {
2469         # on Windows, take the value of the environment variable 
2470         if { [info exists env(NUMBER_OF_PROCESSORS)] &&
2471              ! [catch {expr $env(NUMBER_OF_PROCESSORS) > 0} res] && $res >= 0 } {
2472             return $env(NUMBER_OF_PROCESSORS)
2473         }
2474     } elseif { "$tcl_platform(os)" == "Linux" } {
2475         # on Linux, take number of logical processors listed in /proc/cpuinfo
2476         if { [catch {open "/proc/cpuinfo" r} fd] } { 
2477             return 0 ;# should never happen, but...
2478         }
2479         set nb 0
2480         while { [gets $fd line] >= 0 } {
2481             if { [regexp {^processor[ \t]*:} $line] } {
2482                 incr nb
2483             }
2484         }
2485         close $fd
2486         return $nb
2487     } elseif { "$tcl_platform(os)" == "Darwin" } {
2488         # on MacOS X, call sysctl command
2489         if { ! [catch {exec sysctl hw.ncpu} ret] && 
2490              [regexp {^hw[.]ncpu[ \t]*:[ \t]*([0-9]+)} $ret res nb] } {
2491             return $nb
2492         }
2493     }
2494
2495     # if cannot get good value, return 0 as default
2496     return 0
2497 }
2498
2499 # check two files for difference
2500 proc _diff_files {file1 file2} {
2501     set fd1 [open $file1 "r"]
2502     set fd2 [open $file2 "r"]
2503
2504     set differ f
2505     while {! $differ} {
2506         set nb1 [gets $fd1 line1]
2507         set nb2 [gets $fd2 line2]
2508         if { $nb1 != $nb2 } { set differ t; break }
2509         if { $nb1 < 0 } { break }
2510         if { [string compare $line1 $line2] } {
2511             set differ t
2512         }
2513     }
2514
2515     close $fd1
2516     close $fd2
2517
2518     return $differ
2519 }
2520
2521 # Check if file is in DOS encoding.
2522 # This check is done by presence of \r\n combination at the end of the first 
2523 # line (i.e. prior to any other \n symbol).
2524 # Note that presence of non-ascii symbols typically used for recognition
2525 # of binary files is not suitable since some IGES and STEP files contain
2526 # non-ascii symbols.
2527 # Special check is added for PNG files which contain \r\n in the beginning.
2528 proc _check_dos_encoding {file} {
2529     set fd [open $file rb]
2530     set isdos f
2531     if { [gets $fd line] && [regexp {.*\r$} $line] && 
2532          ! [regexp {^.PNG} $line] } {
2533         set isdos t
2534     }
2535     close $fd
2536     return $isdos
2537 }
2538
2539 # procedure to recognize format of a data file by its first symbols (for OCCT 
2540 # BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
2541 proc _check_file_format {file} {
2542     set fd [open $file rb]
2543     set line [read $fd 1024]
2544     close $fd
2545
2546     set warn f
2547     set ext [file extension $file]
2548     set format unknown
2549     if { [regexp {^DBRep_DrawableShape} $line] } {
2550         set format BREP
2551         if { "$ext" != ".brep" && "$ext" != ".rle" && 
2552              "$ext" != ".draw" && "$ext" != "" } {
2553             set warn t
2554         }
2555     } elseif { [regexp {^DrawTrSurf_} $line] } {
2556         set format DRAW
2557         if { "$ext" != ".rle" && 
2558              "$ext" != ".draw" && "$ext" != "" } {
2559             set warn t
2560         }
2561     } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
2562         set format STEP
2563         if { "$ext" != ".step" && "$ext" != ".stp" } {
2564             set warn t
2565         }
2566     } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
2567         set format IGES
2568         if { "$ext" != ".iges" && "$ext" != ".igs" } {
2569             set warn t
2570         }
2571     } elseif { "$ext" == ".igs" } {
2572         set format IGES
2573     } elseif { "$ext" == ".stp" } {
2574         set format STEP
2575     } else {
2576         set format [string toupper [string range $ext 1 end]]
2577     }
2578     
2579     if { $warn } {
2580         puts "$file: Warning: extension ($ext) does not match format ($format)"
2581     }
2582
2583     return $format
2584 }
2585
2586 # procedure to load file knowing its format
2587 proc load_data_file {file format shape} {
2588     switch $format {
2589         BREP { uplevel restore $file $shape }
2590         DRAW { uplevel restore $file $shape }
2591         IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
2592         STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
2593         STL  { pload XSDRAW; uplevel readstl $shape $file triangulation }
2594         default { error "Cannot read $format file $file" }
2595     }
2596 }
2597
2598 # procedure to get name of temporary directory,
2599 # ensuring it is existing and writeable 
2600 proc _get_temp_dir {} {
2601     global env tcl_platform
2602
2603     # check typical environment variables 
2604     foreach var {TempDir Temp Tmp} {
2605         # check different case
2606         foreach name [list [string toupper $var] $var [string tolower $var]] {
2607             if { [info exists env($name)] && [file isdirectory $env($name)] &&
2608                  [file writable $env($name)] } {
2609                 return [regsub -all {\\} $env($name) /]
2610             }
2611         }
2612     }
2613
2614     # check platform-specific locations
2615     set fallback tmp
2616     if { "$tcl_platform(platform)" == "windows" } {
2617         set paths "c:/TEMP c:/TMP /TEMP /TMP"
2618         if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
2619             set fallback [regsub -all {\\} "$env(HOMEDRIVE)$env(HOMEPATH)/tmp" /]
2620         }
2621     } else {
2622         set paths "/tmp /var/tmp /usr/tmp"
2623         if { [info exists env(HOME)] } {
2624             set fallback "$env(HOME)/tmp"
2625         }
2626     }
2627     foreach dir $paths {
2628         if { [file isdirectory $dir] && [file writable $dir] } {
2629             return $dir
2630         }
2631     }
2632
2633     # fallback case: use subdir /tmp of home or current dir
2634     file mkdir $fallback
2635     return $fallback
2636 }
2637
2638 # extract of code from testgrid command used to process jobs running in 
2639 # parallel until number of jobs in the queue becomes equal or less than 
2640 # specified value
2641 proc _testgrid_process_jobs {worker {nb_ok 0}} {
2642     # bind local vars to variables of the caller procedure
2643     upvar log log
2644     upvar logdir logdir
2645     upvar job_def job_def
2646     upvar nbpooled nbpooled
2647     upvar userbreak userbreak
2648     upvar refresh refresh
2649     upvar refresh_timer refresh_timer
2650
2651     catch {tpool::resume $worker}
2652     while { ! $userbreak && $nbpooled > $nb_ok } {
2653         foreach job [tpool::wait $worker [array names job_def]] {
2654             eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
2655             unset job_def($job)
2656             incr nbpooled -1
2657         }
2658
2659         # check for user break
2660         if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
2661             set userbreak 1
2662         }
2663
2664         # update summary log with requested period
2665         if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
2666             _log_summarize $logdir $log
2667             set refresh_timer [clock seconds]
2668         }
2669     }
2670     catch {tpool::suspend $worker}
2671 }
2672
2673 help checkcolor {
2674   Check pixel color.
2675   Use: checkcolor x y red green blue
2676   x y - pixel coordinates
2677   red green blue - expected pixel color (values from 0 to 1)
2678   Function check color with tolerance (5x5 area)
2679 }
2680 # Procedure to check color using command vreadpixel with tolerance
2681 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
2682     puts "Coordinate x = $coord_x"
2683     puts "Coordinate y = $coord_y"
2684     puts "RED color of RGB is $rd_get"
2685     puts "GREEN color of RGB is $gr_get"
2686     puts "BLUE color of RGB is $bl_get"
2687
2688     if { $coord_x <= 1 || $coord_y <= 1 } {
2689         puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
2690         return -1
2691     }
2692
2693     set color ""
2694     catch { [set color "[vreadpixel ${coord_x} ${coord_y} rgb]"] }
2695     if {"$color" == ""} {
2696         puts "Error : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2697     }
2698     set rd [lindex $color 0]
2699     set gr [lindex $color 1]
2700     set bl [lindex $color 2]
2701     set rd_int [expr int($rd * 1.e+05)]
2702     set gr_int [expr int($gr * 1.e+05)]
2703     set bl_int [expr int($bl * 1.e+05)]
2704     set rd_ch [expr int($rd_get * 1.e+05)]
2705     set gr_ch [expr int($gr_get * 1.e+05)]
2706     set bl_ch [expr int($bl_get * 1.e+05)]
2707
2708     if { $rd_ch != 0 } {
2709         set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2710     } else {
2711         set tol_rd $rd_int
2712     }
2713     if { $gr_ch != 0 } {
2714         set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2715     } else {
2716         set tol_gr $gr_int
2717     }
2718     if { $bl_ch != 0 } {
2719         set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2720     } else {
2721         set tol_bl $bl_int
2722     }
2723
2724     set status 0
2725     if { $tol_rd > 0.2 } {
2726         puts "Warning : RED light of additive color model RGB is invalid"
2727         set status 1
2728     }
2729     if { $tol_gr > 0.2 } {
2730         puts "Warning : GREEN light of additive color model RGB is invalid"
2731         set status 1
2732     }
2733     if { $tol_bl > 0.2 } {
2734         puts "Warning : BLUE light of additive color model RGB is invalid"
2735         set status 1
2736     }
2737
2738     if { $status != 0 } {
2739         puts "Warning : Colors of default coordinate are not equal"
2740     }
2741
2742     global stat
2743     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2744         set info [_checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
2745         set stat [lindex $info end]
2746         if { ${stat} != 1 } {
2747             puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
2748             return $stat
2749         } else {
2750             puts "Point with valid color was found"
2751             return $stat
2752         }
2753     } else {
2754         set stat 1
2755     }
2756 }
2757
2758 # Procedure to check color in the point near default coordinate
2759 proc _checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
2760     set x_start [expr ${coord_x} - 2]
2761     set y_start [expr ${coord_y} - 2]
2762     set mistake 0
2763     set i 0
2764     while { $mistake != 1 && $i <= 5 } {
2765         set j 0
2766         while { $mistake != 1 && $j <= 5 } {
2767             set position_x [expr ${x_start} + $j]
2768             set position_y [expr ${y_start} + $i]
2769             puts $position_x
2770             puts $position_y
2771
2772             set color ""
2773             catch { [set color "[vreadpixel ${position_x} ${position_y} rgb]"] }
2774             if {"$color" == ""} {
2775                 puts "Warning : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2776                 incr j
2777                 continue
2778             }
2779             set rd [lindex $color 0]
2780             set gr [lindex $color 1]
2781             set bl [lindex $color 2]
2782             set rd_int [expr int($rd * 1.e+05)]
2783             set gr_int [expr int($gr * 1.e+05)]
2784             set bl_int [expr int($bl * 1.e+05)]
2785
2786             if { $rd_ch != 0 } {
2787                 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2788             } else {
2789                 set tol_rd $rd_int
2790             }
2791             if { $gr_ch != 0 } {
2792                 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2793             } else {
2794                 set tol_gr $gr_int
2795             }
2796             if { $bl_ch != 0 } {
2797                 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2798             } else {
2799                 set tol_bl $bl_int
2800             }
2801
2802             if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2803                 puts "Warning : Point with true color was not found near default coordinates"
2804                 set mistake 0
2805             } else {
2806                 set mistake 1
2807             }
2808             incr j
2809         }
2810         incr i
2811     }
2812     return $mistake
2813 }
2814
2815 # Procedure to check if sequence of values in listval follows linear trend
2816 # adding the same delta on each step.
2817 #
2818 # The function does statistical estimation of the mean variation of the
2819 # values of the sequence, and dispersion, and returns true only if both 
2820 # dispersion and deviation of the mean from expected delta are within 
2821 # specified tolerance.
2822 #
2823 # If mean variation differs from expected delta on more than two dispersions,
2824 # the check fails and procedure raises error with specified message.
2825 #
2826 # Otherwise the procedure returns false meaning that more iterations are needed.
2827 # Note that false is returned in any case if length of listval is less than 3.
2828 #
2829 # See example of use to check memory leaks in bugs/caf/bug23489
2830 #
2831 proc checktrend {listval delta tolerance message} {
2832     set nbval [llength $listval]
2833     if { $nbval < 3} {
2834         return 0
2835     }
2836
2837     # calculate mean value
2838     set mean 0.
2839     set prev [lindex $listval 0]
2840     foreach val [lrange $listval 1 end] {
2841         set mean [expr $mean + ($val - $prev)]
2842         set prev $val
2843     }
2844     set mean [expr $mean / ($nbval - 1)]
2845
2846     # calculate dispersion
2847     set sigma 0.
2848     set prev [lindex $listval 0]
2849     foreach val [lrange $listval 1 end] {
2850         set d [expr ($val - $prev) - $mean]
2851         set sigma [expr $sigma + $d * $d]
2852         set prev $val
2853     }
2854     set sigma [expr sqrt ($sigma / ($nbval - 2))]
2855
2856     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
2857
2858     # check if deviation is definitely too big
2859     if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
2860         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
2861         error "$message"
2862     }
2863
2864     # check if deviation is clearly within a range
2865     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
2866 }