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