0023550: Variable imagedir is not defined in interactive run of tests
[occt.git] / src / DrawResources / TestCommands.tcl
1 # Copyright (c) 2012 OPEN CASCADE SAS
2 #
3 # The content of this file is subject to the Open CASCADE Technology Public
4 # License Version 6.5 (the "License"). You may not use the content of this file
5 # except in compliance with the License. Please obtain a copy of the License
6 # at http://www.opencascade.org and read it completely before using this file.
7 #
8 # The Initial Developer of the Original Code is Open CASCADE S.A.S., having its
9 # main offices at: 1, place des Freres Montgolfier, 78280 Guyancourt, France.
10 #
11 # The Original Code and all software distributed under the License is
12 # distributed on an "AS IS" basis, without warranty of any kind, and the
13 # Initial Developer hereby disclaims all such warranties, including without
14 # limitation, any warranties of merchantability, fitness for a particular
15 # purpose or non-infringement. Please see the License for the specific terms
16 # and conditions governing the rights and limitations under the License.
17
18 ############################################################################
19 # This file defines scripts for execution of OCCT tests.
20 # It should be loaded automatically when DRAW is started, and provides
21 # top-level commands starting with 'test'. Type 'help test' to get their
22 # synopsys.
23 # See OCCT Tests User Guide for description of the test system.
24 #
25 # Note: procedures with names starting with underscore are for internal use 
26 # inside the test system.
27 ############################################################################
28
29 # Default verbose level for command _run_test
30 set _tests_verbose 0
31
32 # regexp for parsing test case results in summary log
33 set _test_case_regexp {^CASE\s+([\w.-]+)\s+([\w.-]+)\s+([\w.-]+)\s*:\s*([\w]+)(.*)}
34
35 # Basic command to run indicated test case in DRAW
36 help test {
37   Run specified test case
38   Use: test group grid casename [echo=0]
39   - If echo is set to 0 (default), log is stored in memory and only summary
40     is output (the log can be obtained with command "dlog get")
41   - If echo is set to 1 or "-echo", all commands and results are echoed 
42     immediately, but log is not saved and summary is not produced
43 }
44 proc test {group grid casename {echo 0}} {
45     # get test case paths (will raise error if input is invalid)
46     _get_test $group $grid $casename dir gridname casefile
47
48     # if echo specified as "-echo", convert it to bool
49     if { "$echo" == "-echo" } { set echo t }
50
51     # run test
52     uplevel _run_test $dir $group $gridname $casefile $echo
53
54     # check log
55     if { ! $echo } {
56         _check_log $dir $group $gridname $casename [dlog get]
57     }
58
59     return
60 }
61
62 # Basic command to run indicated test case in DRAW
63 help testgrid {
64   Run all tests, or specified group, or one grid
65   Use: testgrid [group [grid]] [options...]
66   Allowed options are:
67   -parallel N: run N parallel processes (default is number of CPUs, 0 to disable)
68   -refresh N: save summary logs every N seconds (default 60, minimal 1, 0 to disable)
69   -outdir dirname: set log directory (should be empty or non-existing)
70   -overwrite: force writing logs in existing non-empty directory
71   -xml filename: write XML report for Jenkins (in JUnit-like format)
72 }
73 proc testgrid {args} {
74     global env tcl_platform _tests_verbose
75
76     ######################################################
77     # check arguments
78     ######################################################
79
80     # check that environment variable defining paths to test scripts is defined
81     if { ! [info exists env(CSF_TestScriptsPath)] || 
82          [llength $env(CSF_TestScriptsPath)] <= 0 } {
83         error "Error: Environment variable CSF_TestScriptsPath is not defined"
84     }
85
86     # treat options
87     set parallel [_get_nb_cpus]
88     set refresh 60
89     set logdir ""
90     set overwrite 0
91     set xmlfile ""
92     for {set narg 0} {$narg < [llength $args]} {incr narg} {
93         set arg [lindex $args $narg]
94
95         # parallel execution
96         if { $arg == "-parallel" } {
97             incr narg
98             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
99                 set parallel [expr [lindex $args $narg]]
100             } else {
101                 error "Option -parallel requires argument"
102             }
103             continue
104         }
105
106         # refresh logs time
107         if { $arg == "-refresh" } {
108             incr narg
109             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
110                 set refresh [expr [lindex $args $narg]]
111             } else {
112                 error "Option -refresh requires argument"
113             }
114             continue
115         }
116
117         # output directory
118         if { $arg == "-outdir" } {
119             incr narg
120             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
121                 set logdir [lindex $args $narg]
122             } else {
123                 error "Option -outdir requires argument"
124             }
125             continue
126         }
127
128         # allow overwrite logs 
129         if { $arg == "-overwrite" } {
130             set overwrite 1
131             continue
132         }
133
134         # refresh logs time
135         if { $arg == "-xml" } {
136             incr narg
137             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
138                 set xmlfile [lindex $args $narg]
139             }
140             if { $xmlfile == "" } {
141                 set xmlfile TESTS-summary.xml
142             }
143             continue
144         }
145
146         # unsupported option
147         if { [regexp {^-} $arg] } {
148             error "Error: unsupported option \"$arg\""
149         }
150
151         # treat arguments not recognized as options as group and grid names
152         if { ! [info exists groupname] } {
153             set groupname $arg
154         } elseif { ! [info exists gridname] } {
155             set gridname $arg
156         } else {
157             error "Error: cannot interpret argument $narg ($arg): both group and grid names are already defined by previous args!"
158         }
159     }
160
161     # check that target log directory is empty or does not exist
162     set logdir [file normalize [string trim $logdir]]
163     if { $logdir == "" } {
164         # if specified logdir is empty string, generate unique name like 
165         # results_<branch>_<timestamp>
166         set prefix "results"
167         if { ! [catch {exec git branch} gitout] &&
168              [regexp {[*] ([\w]+)} $gitout res branch] } {
169             set prefix "${prefix}_$branch"
170         }
171         set logdir "${prefix}_[clock format [clock seconds] -format {%Y-%m-%dT%H%M}]"
172         set logdir [file normalize $logdir]
173     }
174     if { [file isdirectory $logdir] && ! $overwrite && ! [catch {glob -directory $logdir *}] } {
175         error "Error: Specified log directory \"$logdir\" is not empty; please clean it before running tests"
176     } 
177     if { [catch {file mkdir $logdir}] || ! [file writable $logdir] } {
178         error "Error: Cannot create directory \"$logdir\", or it is not writable"
179     }
180
181     ######################################################
182     # prepare list of tests to be performed
183     ######################################################
184
185     # list of tests, each defined by a list of:
186     # test scripts directory
187     # group (subfolder) name
188     # grid (subfolder) name
189     # test case name
190     # path to test case file
191     set tests_list {}
192
193     # iterate by all script paths
194     foreach dir [_split_path $env(CSF_TestScriptsPath)] {
195         # protection against empty paths
196         set dir [string trim $dir]
197         if { $dir == "" } { continue }
198
199         if { $_tests_verbose > 0 } { _log_and_puts log "Examining tests directory $dir" }
200
201         # check that directory exists
202         if { ! [file isdirectory $dir] } {
203             _log_and_puts log "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
204             continue
205         }
206
207         # if test group is specified, check that directory with given name exists in this dir
208         # if not, continue to the next test dir
209         if { [info exists groupname] && $groupname != "" } {
210             if { [file isdirectory $dir/$groupname] } { 
211                 set groups $groupname
212             } else {
213                 continue 
214             }
215         } else {
216             # else search all directories in the current dir
217             if [catch {glob -directory $dir -tail -types d *} groups] { continue }
218         }
219
220         # iterate by groups
221         if { $_tests_verbose > 0 } { _log_and_puts log "Groups to be executed: $groups" }
222         foreach group [lsort -dictionary $groups] {
223             if { $_tests_verbose > 0 } { _log_and_puts log "Examining group directory $group" }
224
225             # file grids.list must exist: it defines sequence of grids in the group
226             if { ! [file exists $dir/$group/grids.list] } {
227                 _log_and_puts log "Warning: directory $dir/$group does not contain file grids.list, skipped"
228                 continue
229             }
230
231             # read grids.list file and make a list of grids to be executed
232             set gridlist {}
233             set fd [open $dir/$group/grids.list]
234             set nline 0
235             while { [gets $fd line] >= 0 } {
236                 incr nline
237
238                 # skip comments and empty lines
239                 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
240                 if { [string trim $line] == "" } { continue }
241
242                 # get grid id and name
243                 if { ! [regexp "^\(\[0-9\]+\)\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridid grid] } {
244                     _log_and_puts log "Warning: cannot recognize line $nline in file $dir/$group/grids.list as \"gridid gridname\"; ignored"
245                     continue
246                 }
247                 
248                 # if specific grid is requested, check that it is present; otherwise make complete list
249                 if { ! [info exists gridname] || $gridname == "" || $gridname == $gridid || $gridname == $grid } {
250                     lappend gridlist $grid
251                 }
252             }
253             close $fd
254             
255             # iterate by all grids
256             foreach grid $gridlist {
257
258                 # check if this grid is aliased to another one
259                 set griddir $dir/$group/$grid
260                 if { [file exists $griddir/cases.list] } {
261                     set fd [open $griddir/cases.list]
262                     if { [gets $fd line] >= 0 } {
263                         set griddir [file normalize $dir/$group/$grid/[string trim $line]]
264                     }
265                     close $fd
266                 }
267
268                 # check if grid directory actually exists
269                 if { ! [file isdirectory $griddir] } { 
270                     _log_and_puts log "Error: tests directory for grid $grid ($griddir) is missing; skipped"
271                     continue 
272                 }
273
274                 # create directory for logging test results
275                 if { $logdir != "" } { file mkdir $logdir/$group/$grid }
276
277                 # iterate by all tests in the grid directory
278                 if { [catch {glob -directory $griddir -type f *} testfiles] } { continue }
279                 foreach casefile [lsort -dictionary $testfiles] {
280                     # filter out begin and end files
281                     set casename [file tail $casefile]
282                     if { $casename == "begin" || $casename == "end" } { continue }
283
284                     lappend tests_list [list $dir $group $grid $casename $casefile]
285                 }
286             }
287         }
288     }
289     if { [llength $tests_list] < 1 } {
290         error "Error: no tests are found, check you input arguments and variable CSF_TestScriptsPath!"
291     }
292
293     ######################################################
294     # run tests
295     ######################################################
296     
297     # log command arguments and environment
298     set log "Command: testgrid $args\nHost: [info hostname]\nStarted on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]\n"
299     set log "$log\nEnvironment:\n"
300     foreach envar [array names env] {
301         set log "$log$envar=\"$env($envar)\"\n"
302     }
303     set log "$log\n"
304
305     set refresh_timer [clock seconds]
306     uplevel dchrono _timer reset
307     uplevel dchrono _timer start
308
309     # if parallel execution is requested, allocate thread pool
310     if { $parallel > 0 } {
311         if { ! [info exists tcl_platform(threaded)] || [catch {package require Thread}] } {
312             _log_and_puts log "Warning: Tcl package Thread is not available, running in sequential mode"
313             set parallel 0
314         } else {
315             set worker [tpool::create -minworkers $parallel -maxworkers $parallel]
316             # suspend the pool until all jobs are posted, to prevent blocking of the process
317             # of starting / processing jobs by running threads
318             catch {tpool::suspend $worker}
319             if { $_tests_verbose > 0 } { _log_and_puts log "Executing tests in (up to) $parallel threads" }
320         }
321     }
322
323     # start test cases
324     foreach test_def $tests_list {
325         set dir       [lindex $test_def 0]
326         set group     [lindex $test_def 1]
327         set grid      [lindex $test_def 2]
328         set casename  [lindex $test_def 3]
329         set casefile  [lindex $test_def 4]
330
331         # command to set tests for generation of image in results directory
332         set imgdir_cmd ""
333         if { $logdir != "" } { set imgdir_cmd "set imagedir $logdir/$group/$grid" }
334
335         # prepare command file for running test case in separate instance of DRAW
336         set fd_cmd [open $logdir/$group/$grid/${casename}.tcl w]
337         puts $fd_cmd "$imgdir_cmd"
338         puts $fd_cmd "set test_image $casename"
339         puts $fd_cmd "_run_test $dir $group $grid $casefile t"
340
341         # use dlog command to obtain complete output of the test when it is absent (i.e. since OCCT 6.6.0)
342         # note: this is not needed if echo is set to 1 in call to _run_test above
343         if { ! [catch {dlog get}] } {
344             puts $fd_cmd "puts \[dlog get\]"
345         } else {
346             # else try to use old-style QA_ variables to get more output...
347             set env(QA_DUMP) 1
348             set env(QA_DUP) 1
349             set env(QA_print_command) 1
350         }
351
352         # final 'exit' is needed when running on Linux under VirtualGl
353         puts $fd_cmd "exit"
354         close $fd_cmd
355
356         # commant to run DRAW with a command file;
357         # note that empty string is passed as standard input to avoid possible 
358         # hang-ups due to waiting for stdin of the launching process
359         set command "exec <<{} DRAWEXE -f $logdir/$group/$grid/${casename}.tcl"
360
361         # alternative method to run without temporary file; disabled as it needs too many backslashes
362 #       else {
363 #           set command "exec <<\"\" DRAWEXE -c $imgdir_cmd\\\; set test_image $casename\\\; \
364 #                        _run_test $dir $group $grid $casefile\\\; \
365 #                        puts \\\[dlog get\\\]\\\; exit"
366 #       }
367
368         # run test case, either in parallel or sequentially
369         if { $parallel > 0 } {
370             # parallel execution
371             set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
372             set job_def($job) [list $logdir $dir $group $grid $casename]
373         } else {
374             # sequential execution
375             catch {eval $command} output
376             _log_test_case $output $logdir $dir $group $grid $casename log
377
378             # update summary log with requested period
379             if { $logdir != "" && $refresh > 0 && [expr [clock seconds] - $refresh_timer > $refresh] } {
380                 # update and dump summary
381                 _log_summarize $logdir $log
382                 set refresh_timer [clock seconds]
383             }
384         }
385     }
386
387     # get results of started threads
388     if { $parallel > 0 } {
389         catch {tpool::resume $worker}
390         while { [llength [array names job_def]] > 0 } {
391             foreach job [tpool::wait $worker [array names job_def]] {
392                 eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
393                 unset job_def($job)
394             }
395
396             # update summary log with requested period
397             if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
398                 _log_summarize $logdir $log
399                 set refresh_timer [clock seconds]
400             }
401         }
402         # release thread pool
403         tpool::release $worker
404     }
405
406     uplevel dchrono _timer stop
407     set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
408
409     ######################################################
410     # output summary logs and exit
411     ######################################################
412
413     _log_summarize $logdir $log $time
414     if { $logdir != "" } {
415         puts "Detailed logs are saved in $logdir"
416     }
417     if { $logdir != "" && $xmlfile != "" } {
418         # XML output file is assumed relative to log dir unless it is absolute
419         if { [ file pathtype $xmlfile] == "relative" } {
420             set xmlfile [file normalize $logdir/$xmlfile]
421         }
422         _log_xml_summary $logdir $xmlfile $log 0
423         puts "XML summary is saved to $xmlfile"
424     }
425
426     return
427 }
428
429 # Procedure to regenerate summary log from logs of test cases
430 help testsummarize {
431   Regenerate summary log in the test directory from logs of test cases.
432   This can be necessary if test grids are executed separately (e.g. on
433   different stations) or some grids have been re-executed.
434   Use: testsummarize dir
435 }
436 proc testsummarize {dir} {
437     global _test_case_regexp
438
439     if { ! [file isdirectory $dir] } {
440         error "Error: \"$dir\" is not a directory"
441     }
442
443     # get summary statements from all test cases in one log
444     set log ""
445
446     # to avoid huge listing of logs, first find all subdirectories and iterate
447     # by them, parsing log files in each subdirectory independently 
448     foreach grid [glob -directory $dir -types d -tails */*] {
449         foreach caselog [glob -nocomplain -directory [file join $dir $grid] -types f -tails *.log] {
450             set file [file join $dir $grid $caselog]
451             set nbfound 0
452             set fd [open $file r]
453             while { [gets $fd line] >= 0 } {
454                 if { [regexp $_test_case_regexp $line res grp grd cas status message] } {
455                     if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } { 
456                         puts "Error: $file contains status line for another test case ($line)"
457                     }
458                     set log "$log$line\n"
459                     incr nbfound
460                 }
461             }
462             close $fd
463
464             if { $nbfound != 1 } { 
465                 puts "Error: $file contains $nbfound status lines, expected 1"
466             }
467         }
468     }
469
470     _log_summarize $dir $log "Summary regenerated from logs at [clock format [clock seconds]]"
471     return
472 }
473
474 # Procedure to compare results of two runs of test cases
475 help testdiff {
476   Compare results of two executions of tests (CPU times, ...)
477   Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
478   Where dir1 and dir2 are directories containing logs of two test runs.
479   Allowed options are:
480   -save filename: save resulting log in specified file (default name is
481                   <dir1>/diff-<dir2>.log); HTML log is saved with same name
482                   and extension .html
483   -status {same|ok|all}: filter cases for comparing by their status:
484           same - only cases with same status are compared (default)
485           ok   - only cases with OK status in both logs are compared
486           all  - results are compared regardless of status
487   -verbose level: 
488           1 - output only differences 
489           2 - output also list of logs and directories present in one of dirs only
490           3 - (default) output also progress messages 
491 }
492 proc testdiff {dir1 dir2 args} {
493     if { "$dir1" == "$dir2" } {
494         error "Input directories are the same"
495     }
496
497     ######################################################
498     # check arguments
499     ######################################################
500
501     # treat options
502     set logfile [file join $dir1 "diff-[file tail $dir2].log"]
503     set basename ""
504     set status "same"
505     set verbose 3
506     for {set narg 0} {$narg < [llength $args]} {incr narg} {
507         set arg [lindex $args $narg]
508
509         # log file name
510         if { $arg == "-save" } {
511             incr narg
512             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
513                 set logfile [lindex $args $narg]
514             } else {
515                 error "Error: Option -save must be followed by log file name"
516             } 
517             continue
518         }
519
520         # status filter
521         if { $arg == "-status" } {
522             incr narg
523             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
524                 set status [lindex $args $narg]
525             } else { set status "" }
526             if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
527                 error "Error: Option -status must be followed by one of \"same\", \"all\", or \"ok\""
528             }
529             continue
530         }
531
532         # verbose level
533         if { $arg == "-verbose" } {
534             incr narg
535             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
536                 set verbose [expr [lindex $args $narg]]
537             } else {
538                 error "Error: Option -verbose must be followed by integer verbose level"
539             }
540             continue
541         }
542
543         if { [regexp {^-} $arg] } {
544             error "Error: unsupported option \"$arg\""
545         }
546
547         # non-option arguments form a subdirectory path
548         set basename [file join $basename $arg]
549     }
550
551     # run diff procedure (recursive)
552     _test_diff $dir1 $dir2 $basename $status $verbose log
553
554     # save result to log file
555     if { "$logfile" != "" } {
556         _log_save $logfile $log
557         _log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2
558         puts "Log is saved to $logfile (and .html)"
559     }
560
561     return
562 }
563
564 # Procedure to check data file before adding it to repository
565 help testfile {
566   Check data file and prepare it for putting to test data files repository.
567   Use: testfile [filelist]
568
569   Will report if:
570   - data file (non-binary) is in DOS encoding (CR/LF)
571   - same data file (with same or another name) already exists in the repository
572   - another file with the same name already exists 
573   Note that names are assumed to be case-insensitive (for Windows).
574
575   Unless the file is already in the repository, tries to load it, reports
576   the recognized file format, file size, number of faces and edges in the 
577   loaded shape (if any), and makes snapshot (in the temporary directory).
578   Finally it advises whether the file should be put to public section of the 
579   repository.
580 }
581 proc testfile {filelist} {
582     global env
583
584     # check that CSF_TestDataPath is defined
585     if { ! [info exists env(CSF_TestDataPath)] } {
586         error "Environment variable CSF_TestDataPath must be defined!"
587     }
588
589     # build registry of existing data files (name -> path) and (size -> path)
590     puts "Checking available test data files..."
591     foreach dir [_split_path $env(CSF_TestDataPath)] {
592         while {[llength $dir] != 0} {
593             set curr [lindex $dir 0]
594             set dir [lrange $dir 1 end]
595             eval lappend dir [glob -nocomplain -directory $curr -type d *]
596             foreach file [glob -nocomplain -directory $curr -type f *] {
597                 set name [file tail $file]
598                 set name_lower [string tolower $name]
599
600                 # check that the file is not in DOS encoding
601                 if { [_check_dos_encoding $file] } {
602                     puts "Warning: file $file is in DOS encoding; was this intended?"
603                 }
604                 _check_file_format $file
605
606                 # check if file with the same name is present twice or more
607                 if { [info exists names($name_lower)] } {
608                     puts "Error: more than one file with name $name is present in the repository:"
609                     if { [_diff_files $file $names($name_lower)] } {
610                         puts "(files are different by content)"
611                     } else {
612                         puts "(files are same by content)"
613                     }
614                     puts "--> $file"
615                     puts "--> $names($name_lower)"
616                     continue
617                 } 
618                 
619                 # check if file with the same content exists
620                 set size [file size $file]
621                 if { [info exists sizes($size)] } {
622                     foreach other $sizes($size) {
623                         if { ! [_diff_files $file $other] } {
624                             puts "Warning: two files with the same content found:"
625                             puts "--> $file"
626                             puts "--> $other"
627                         }
628                     }
629                 }
630
631                 # add the file to the registry
632                 set names($name_lower) $file
633                 lappend sizes($size) $file
634             }
635         }
636     }
637     if { [llength $filelist] <= 0 } { return }
638
639     # check the new files
640     set has_images f
641     puts "Checking new file(s)..."
642     foreach file $filelist {
643         # check for DOS encoding
644         if { [_check_dos_encoding $file] } {
645             puts "$file: Warning: DOS encoding detected"
646         }
647
648         set name [file tail $file]
649         set name_lower [string tolower $name]
650
651         # check for presence of the file with same name
652         if { [info exists names($name_lower)] } {
653             if { [_diff_files $file $names($name_lower)] } {
654                 puts "$file: Error: name is already used by existing file\n--> $names($name_lower)"
655             } else {
656                 puts "$file: OK: already in the repository \n--> $names($name_lower)"
657                 continue
658             }
659         }
660                 
661         # check if file with the same content exists
662         set size [file size $file]
663         if { [info exists sizes($size)] } {
664             set found f
665             foreach other $sizes($size) {
666                 if { ! [_diff_files $file $other] } {
667                      puts "$file: OK: the same file is already present under name [file tail $other]\n--> $other"
668                      set found t
669                      break
670                 }
671             }
672             if { $found } { continue }
673         }
674
675         # try to read the file
676         set format [_check_file_format $file]
677         if { [catch {uplevel load_data_file $file $format a}] } {
678             puts "$file: Error: Cannot read as $format file"
679             continue
680         }
681
682         # get number of faces and edges
683         set edges 0
684         set faces 0
685         set nbs [uplevel nbshapes a]
686         regexp {EDGE[ \t:]*([0-9]+)} $nbs res edges
687         regexp {FACE[ \t:]*([0-9]+)} $nbs res faces
688
689         # classify; first check file size and number of faces and edges
690         if { $size < 95000 && $faces < 20 && $edges < 100 } {
691             set dir public
692         } else {
693             set dir private
694             # check if one of names of that file corresponds to typical name for 
695             # MDTV bugs or has extension .rle, this should be old model
696             if { [regexp -nocase {.*(cts|ats|pro|buc|ger|fra|usa|uki)[0-9]+.*} $name] ||
697                  [regexp -nocase {[.]rle\y} $name] } {
698                 set dir old
699             }
700         }
701
702         # add stats
703         puts "$file: $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
704
705         set tmpdir [_get_temp_dir]
706         file mkdir $tmpdir/$dir
707
708         # make snapshot
709         pload AISV
710         uplevel vdisplay a
711         uplevel vfit
712         uplevel vzfit
713         uplevel vdump $tmpdir/$dir/[file rootname [file tail $file]].png
714         set has_images t
715     }
716     if { $has_images } {
717         puts "Snapshots are saved in subdirectory [_get_temp_dir]"
718     }
719 }
720
721 # Procedure to locate data file for test given its name.
722 # The search is performed assuming that the function is called
723 # from the test case script; the search order is:
724 # - subdirectory "data" of the test script (grid) folder
725 # - subdirectories in environment variable CSF_TestDataPath
726 # - subdirectory set by datadir command
727 # If file is not found, raises Tcl error.
728 proc locate_data_file {filename} {
729     global env groupname gridname casename
730
731     # check if the file is located in the subdirectory data of the script dir
732     set scriptfile [info script]
733     if { $scriptfile != "" } {
734         set path [file join [file dirname $scriptfile] data $filename]
735         if { [file exists $path] } {
736             return [file normalize $path]
737         }
738     }
739
740     # check sub-directories in paths indicated by CSF_TestDataPath
741     if { [info exists env(CSF_TestDataPath)] } {
742         foreach dir [_split_path $env(CSF_TestDataPath)] {
743             while {[llength $dir] != 0} { 
744                 set name [lindex $dir 0]
745                 set dir [lrange $dir 1 end]
746                 eval lappend dir [glob -nocomplain -directory $name -type d *]
747                 if { [file exists $name/$filename] } {
748                     return [file normalize $name/$filename]
749                 }
750             }
751         }
752     }
753
754     # check current datadir
755     if { [file exists [uplevel datadir]/$filename] } {
756         return [file normalize [uplevel datadir]/$filename]
757     }
758
759     # raise error
760     error [join [list "Error: file $filename could not be found" \
761                       "(should be in paths indicated by CSF_TestDataPath environment variable, " \
762                       "or in subfolder data in the script directory)"] "\n"]
763 }
764
765 # Internal procedure to find test case indicated by group, grid, and test case names;
766 # returns:
767 # - dir: path to the base directory of the tests group
768 # - gridname: actual name of the grid
769 # - casefile: path to the test case script 
770 # if no such test is found, raises error with appropriate message
771 proc _get_test {group grid casename _dir _gridname _casefile} {
772     upvar $_dir dir
773     upvar $_gridname gridname
774     upvar $_casefile casefile
775
776     global env
777  
778     # check that environment variable defining paths to test scripts is defined
779     if { ! [info exists env(CSF_TestScriptsPath)] || 
780          [llength $env(CSF_TestScriptsPath)] <= 0 } {
781         error "Error: Environment variable CSF_TestScriptsPath is not defined"
782     }
783
784     # iterate by all script paths
785     foreach dir [_split_path $env(CSF_TestScriptsPath)] {
786         # protection against empty paths
787         set dir [string trim $dir]
788         if { $dir == "" } { continue }
789
790         # check that directory exists
791         if { ! [file isdirectory $dir] } {
792             puts "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
793             continue
794         }
795
796         # check if test group with given name exists in this dir
797         # if not, continue to the next test dir
798         if { ! [file isdirectory $dir/$group] } { continue }
799
800         # check that grid with given name (possibly alias) exists; stop otherwise
801         set gridname $grid
802         if { ! [file isdirectory $dir/$group/$gridname] } {
803             # check if grid is named by alias rather than by actual name
804             if { [file exists $dir/$group/grids.list] } {
805                 set fd [open $dir/$group/grids.list]
806                 while { [gets $fd line] >= 0 } {
807                     if { [regexp "\[ \t\]*\#.*" $line] } { continue }
808                     if { [regexp "^$grid\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridname] } {
809                         break
810                     }
811                 }
812                 close $fd
813             }
814         }
815         if { ! [file isdirectory $dir/$group/$gridname] } { continue }
816
817         # get actual file name of the script; stop if it cannot be found
818         set casefile $dir/$group/$gridname/$casename
819         if { ! [file exists $casefile] } {
820             # check if this grid is aliased to another one
821             if { [file exists $dir/$group/$gridname/cases.list] } {
822                 set fd [open $dir/$group/$gridname/cases.list]
823                 if { [gets $fd line] >= 0 } {
824                     set casefile [file normalize $dir/$group/$gridname/[string trim $line]/$casename]
825                 }
826                 close $fd
827             }
828         }
829         if { [file exists $casefile] } { 
830             # normal return
831             return 
832         }
833     }
834
835     # coming here means specified test is not found; report error
836     error [join [list "Error: test case $group / $grid / $casename is not found in paths listed in variable" \
837                      "CSF_TestScriptsPath (current value is \"$env(CSF_TestScriptsPath)\")"] "\n"]
838 }
839
840 # Internal procedure to run test case indicated by base directory, 
841 # grid and grid names, and test case file path.
842 # The log can be obtained by command "dlog get".
843 proc _run_test {scriptsdir group gridname casefile echo} {
844     global env
845
846     # start timer
847     uplevel dchrono _timer reset
848     uplevel dchrono _timer start
849     catch {uplevel meminfo w} membase
850
851     # enable commands logging; switch to old-style mode if dlog command is not present
852     set dlog_exists 1
853     if { [catch {dlog reset}] } {
854         set dlog_exists 0
855     } elseif { $echo } {
856         decho on
857     } else {
858         dlog reset
859         dlog on
860         rename puts puts-saved
861         proc puts args { 
862             global _tests_verbose
863
864             # log only output to stdout and stderr, not to file!
865             if {[llength $args] > 1} {
866                 set optarg [lindex $args end-1]
867                 if { $optarg == "stdout" || $optarg == "stderr" || $optarg == "-newline" } {
868                     dlog add [lindex $args end]
869                 }
870             } else {
871                 dlog add [lindex $args end]
872             }
873
874             # reproduce original puts
875             if { $_tests_verbose } {
876                 eval puts-saved $args
877             }
878         }
879     }
880
881     # evaluate test case 
882     if [catch {
883         # set variables identifying test case
884         uplevel set casename [file tail $casefile]
885         uplevel set groupname $group
886         uplevel set gridname $gridname
887
888         # set variables for saving of images if not yet set
889         if { ! [uplevel info exists imagedir] } {
890             uplevel set imagedir [_get_temp_dir]
891             uplevel set test_image \$casename
892         }
893
894         # execute test scripts 
895         if { [file exists $scriptsdir/$group/begin] } {
896             puts "Executing $scriptsdir/$group/begin..."; flush stdout
897             uplevel source $scriptsdir/$group/begin
898         }
899         if { [file exists $scriptsdir/$group/$gridname/begin] } {
900             puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
901             uplevel source $scriptsdir/$group/$gridname/begin
902         }
903         
904         puts "Executing $casefile..."; flush stdout
905         uplevel source $casefile
906         
907         if { [file exists $scriptsdir/$group/$gridname/end] } {
908             puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
909             uplevel source $scriptsdir/$group/$gridname/end
910         }
911         if { [file exists $scriptsdir/$group/end] } {
912             puts "Executing $scriptsdir/$group/end..."; flush stdout
913             uplevel source $scriptsdir/$group/end
914         }
915     } res] {
916         puts "Tcl Exception: $res"
917     }
918
919     # stop logging
920     if { $dlog_exists } {
921         if { $echo } {
922             decho off
923         } else {
924             rename puts {}
925             rename puts-saved puts
926             dlog off
927         }
928     }
929
930     # stop cpulimit killer if armed by the test
931     cpulimit
932
933     # add memory and timing info
934     set stats ""
935     if { ! [catch {uplevel meminfo w} memuse] } {
936         set stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
937     }
938     uplevel dchrono _timer stop
939     set time [uplevel dchrono _timer show]
940     if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
941         set stats "${stats}TOTAL CPU TIME: $cpu sec\n"
942     }
943     if { $dlog_exists && ! $echo } {
944         dlog add $stats
945     } else {
946         puts $stats
947     }
948 }
949
950 # Internal procedure to check log of test execution and decide if it passed or failed
951 proc _check_log {dir group gridname casename log {_summary {}} {_html_log {}}} {
952     global env
953     if { $_summary != "" } { upvar $_summary summary }
954     if { $_html_log != "" } { upvar $_html_log html_log }
955     set summary ""
956     set html_log ""
957
958 if [catch {
959
960     # load definition of 'bad words' indicating test failure
961     # note that rules are loaded in the order of decreasing priority (grid - group - common),
962     # thus grid rules will override group ones
963     set badwords {}
964     foreach rulesfile [list $dir/$group/$gridname/parse.rules $dir/$group/parse.rules $dir/parse.rules] {
965         if [catch {set fd [open $rulesfile r]}] { continue }
966         while { [gets $fd line] >= 0 } {
967             # skip comments and empty lines
968             if { [regexp "\[ \t\]*\#.*" $line] } { continue }
969             if { [string trim $line] == "" } { continue }
970             # extract regexp
971             if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } { 
972                 puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
973                 continue 
974             }
975             set status [string trim $status]
976             if { $comment != "" } { set status "$status ([string trim $comment])" }
977             set rexp [regsub -all {\\b} $rexp {\\y}] ;# convert regexp from Perl to Tcl style
978             lappend badwords [list $status $rexp]
979         }
980         close $fd
981     }
982     if { [llength $badwords] <= 0 } { 
983         puts "Warning: no definition of error indicators found (check files parse.rules)" 
984     }
985
986     # analyse log line-by-line
987     set todos {}
988     set status ""
989     foreach line [split $log "\n"] {
990         # check if line defines specific treatment of some messages
991         if [regexp -nocase {^[ \t]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
992             if { ! [regexp -nocase {\mAll\M} $platforms] && 
993                  ! [regexp -nocase "\\m$env(os_type)\\M" $platforms] } {
994                 set html_log "$html_log\n$line"
995                 continue ;# TODO statement is for another platform
996             }
997
998             # record TODOs that mark unstable cases
999             if { [regexp {[\?]} $platforms] } {
1000                 set todos_unstable([llength $todos]) 1
1001             }
1002
1003             lappend todos [regsub -all {\\b} [string trim $pattern] {\\y}] ;# convert regexp from Perl to Tcl style
1004             set html_log "$html_log\n[_html_highlight BAD $line]"
1005             continue
1006         }
1007
1008         # check for presence of messages indicating test result
1009         set ismarked 0
1010         foreach bw $badwords {
1011             if { [regexp [lindex $bw 1] $line] } { 
1012                 # check if this is known bad case
1013                 set is_known 0
1014                 for {set i 0} {$i < [llength $todos]} {incr i} {
1015                     if { [regexp [lindex $todos $i] $line] } {
1016                         set is_known 1
1017                         incr todo_count($i)
1018                         set html_log "$html_log\n[_html_highlight BAD $line]"
1019                         break
1020                     }
1021                 }
1022
1023                 # if it is not in todo, define status
1024                 if { ! $is_known } {
1025                     set stat [lindex $bw 0 0]
1026                     set html_log "$html_log\n[_html_highlight $stat $line]"
1027                     if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
1028                         set status [lindex $bw 0]
1029                     }
1030                 }
1031                 set ismarked 1
1032                 break
1033             }
1034         }
1035         if { ! $ismarked } { 
1036             set html_log "$html_log\n$line"
1037         }
1038     }
1039
1040     # check for presence of TEST COMPLETED statement
1041     if { $status == "" && ! [regexp {TEST COMPLETED} $log] } {
1042         # check whether absence of TEST COMPLETED is known problem
1043         set i [lsearch $todos "TEST INCOMPLETE"]
1044         if { $i >= 0 } {
1045             incr todo_count($i)
1046         } else {
1047             set status "FAILED (no final message is found)"
1048         }
1049     }
1050
1051     # check declared bad cases and diagnose possible improvement 
1052     # (bad case declared but not detected).
1053     # Note that absence of the problem marked by TODO with question mark
1054     # (unstable) is not reported as improvement.
1055     if { $status == "" } {
1056         for {set i 0} {$i < [llength $todos]} {incr i} {
1057             if { ! [info exists todos_unstable($i)] &&
1058                  (! [info exists todo_count($i)] || $todo_count($i) <= 0) } {
1059                 set status "IMPROVEMENT (expected problem TODO no. [expr $i + 1] is not detected)"
1060                 break;
1061             }
1062         }
1063     }
1064
1065     # report test as known bad if at least one of expected problems is found
1066     if { $status == "" && [llength [array names todo_count]] > 0 } {
1067         set status "BAD (known problem)"
1068     }
1069
1070     # report normal OK
1071     if { $status == "" } {set status "OK" }
1072
1073 } res] {
1074     set status "FAILED ($res)"
1075 }
1076
1077     # put final message
1078     _log_and_puts summary "CASE $group $gridname $casename: $status"
1079     set html_log "[_html_highlight [lindex $status 0] $summary]\n$html_log"
1080 }
1081
1082 # Auxiliary procedure putting message to both cout and log variable (list)
1083 proc _log_and_puts {logvar message} {
1084     if { $logvar != "" } { 
1085         upvar $logvar log
1086         if [info exists log] { 
1087             set log "$log$message\n"
1088         } else {
1089             set log "$message\n"
1090         }
1091     }
1092     puts $message
1093 }
1094
1095 # Auxiliary procedure to log result on single test case
1096 proc _log_test_case {output logdir dir group grid casename logvar} {
1097     upvar $logvar log
1098
1099     # check result and make HTML log
1100     _check_log $dir $group $grid $casename $output summary html_log
1101     set log "$log$summary"
1102
1103     # save log to file
1104     if { $logdir != "" } {
1105         _log_html $logdir/$group/$grid/$casename.html $html_log "Test $group $grid $casename"
1106         _log_save $logdir/$group/$grid/$casename.log "$output\n$summary" "Test $group $grid $casename"
1107     }
1108 }
1109
1110 # Auxiliary procedure to save log to file
1111 proc _log_save {file log {title {}}} {
1112     # create missing directories as needed
1113     catch {file mkdir [file dirname $file]}
1114
1115     # try to open a file
1116     if [catch {set fd [open $file w]} res] {
1117         error "Error saving log file $file: $res"
1118     }
1119     
1120     # dump log and close
1121     puts $fd "$title\n"
1122     puts $fd $log
1123     close $fd
1124     return
1125 }
1126
1127 # Auxiliary procedure to make a (relative if possible) URL to a file for 
1128 # inclusion a reference in HTML log
1129 proc _make_url {htmldir file} {
1130     set htmlpath [file split [file normalize $htmldir]]
1131     set filepath [file split [file normalize $file]]
1132     for {set i 0} {$i < [llength $htmlpath]} {incr i} {
1133         if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
1134             if { $i == 0 } { break }
1135             return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
1136         }
1137     }
1138
1139     # if relative path could not be made, return full file URL
1140     return "file://[file normalize $file]"
1141 }
1142
1143 # Auxiliary procedure to save log to file
1144 proc _log_html {file log {title {}}} {
1145     # create missing directories as needed
1146     catch {file mkdir [file dirname $file]}
1147
1148     # try to open a file
1149     if [catch {set fd [open $file w]} res] {
1150         error "Error saving log file $file: $res"
1151     }
1152     
1153     # print header
1154     puts $fd "<html><head><title>$title</title></head><body><h1>$title</h1>"
1155
1156     # add images if present
1157     set imgbasename [file rootname [file tail $file]]
1158     foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails ${imgbasename}*.gif ${imgbasename}*.png ${imgbasename}*.jpg]] {
1159         puts $fd "<p><img src=\"$img\"/><p>"
1160     }
1161
1162     # print log body, trying to add HTML links to script files on lines like
1163     # "Executing <filename>..."
1164     puts $fd "<pre>"
1165     foreach line [split $log "\n"] {
1166         if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
1167              [file exists $script] } {
1168             set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
1169         }
1170         puts $fd $line
1171     }
1172     puts $fd "</pre></body></html>"
1173
1174     close $fd
1175     return
1176 }
1177
1178 # Auxiliary method to make text with HTML highlighting according to status
1179 proc _html_color {status} {
1180     # choose a color for the cell according to result
1181     if { $status == "OK" } { 
1182         return lightgreen
1183     } elseif { [regexp -nocase {^FAIL} $status] } { 
1184         return red
1185     } elseif { [regexp -nocase {^BAD} $status] } { 
1186         return yellow
1187     } elseif { [regexp -nocase {^IMP} $status] } { 
1188         return orange
1189     } elseif { [regexp -nocase {^SKIP} $status] } { 
1190         return gray
1191     } elseif { [regexp -nocase {^IGNOR} $status] } { 
1192         return gray
1193     } else {
1194         puts "Warning: no color defined for status $status, using red as if FAILED"
1195         return red
1196     }
1197 }
1198
1199 # Format text line in HTML to be colored according to the status
1200 proc _html_highlight {status line} {
1201     return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
1202 }
1203
1204 # Internal procedure to generate HTML page presenting log of the tests
1205 # execution in tabular form, with links to reports on individual cases
1206 proc _log_html_summary {logdir log totals regressions improvements total_time} {
1207     global _test_case_regexp
1208
1209      # create missing directories as needed
1210     catch {file mkdir $logdir}
1211
1212     # try to open a file and start HTML
1213     if [catch {set fd [open $logdir/summary.html w]} res] {
1214         error "Error creating log file: $res"
1215     }
1216
1217     # write HRML header, including command to refresh log if still in progress
1218     puts $fd "<html><head>"
1219     puts $fd "<title>Tests summary</title>"
1220     if { $total_time == "" } {
1221         puts $fd "<meta http-equiv=\"refresh\" content=\"10\">"
1222     }
1223     puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
1224     puts $fd "</head><body>"
1225
1226     # put summary
1227     set legend(OK)          "Test passed OK"
1228     set legend(FAILED)      "Test failed (regression)"
1229     set legend(BAD)         "Known problem"
1230     set legend(IMPROVEMENT) "Possible improvement (expected problem not detected)"
1231     set legend(SKIPPED)     "Test skipped due to lack of data file"
1232     puts $fd "<h1>Summary</h1><table>"
1233     foreach nbstat $totals {
1234         set status [lindex $nbstat 1]
1235         if { [info exists legend($status)] } { 
1236             set comment $legend($status) 
1237         } else {
1238             set comment "User-defined status"
1239         }
1240         puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
1241     }
1242     puts $fd "</table>"
1243
1244     # time stamp and elapsed time info
1245     if { $total_time != "" } { 
1246         puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname] <p> $total_time" 
1247     } else {
1248         puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
1249     }
1250    
1251     # print regressions and improvements
1252     foreach featured [list $regressions $improvements] {
1253         if { [llength $featured] <= 1 } { continue }
1254         set status [string trim [lindex $featured 0] { :}]
1255         puts $fd "<h2>$status</h2>"
1256         puts $fd "<table>"
1257         set groupgrid ""
1258         foreach test [lrange $featured 1 end] {
1259             if { ! [regexp {^(.*)\s+([\w.]+)$} $test res gg name] } {
1260                 set gg UNKNOWN
1261                 set name "Error building short list; check details"
1262             }
1263             if { $gg != $groupgrid } {
1264                 if { $groupgrid != "" } { puts $fd "</tr>" }
1265                 set groupgrid $gg
1266                 puts $fd "<tr><td>$gg</td>"
1267             }
1268             puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
1269         }
1270         if { $groupgrid != "" } { puts $fd "</tr>" }
1271         puts $fd "</table>"
1272     }
1273
1274     # put detailed log
1275     puts $fd "<h1>Details</h1>"
1276
1277     # process log line-by-line
1278     set group {}
1279     set letter {}
1280     foreach line [lsort -dictionary [split $log "\n"]] {
1281         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1282         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1283             continue
1284         }
1285
1286         # start new group
1287         if { $grp != $group } {
1288             if { $letter != "" } { puts $fd "</tr></table>" }
1289             set letter {}
1290             set group $grp
1291             set grid {}
1292             puts $fd "<h2>Group $group</h2>"
1293         }
1294
1295         # start new grid
1296         if { $grd != $grid } {
1297             if { $letter != "" } { puts $fd "</tr></table>" }
1298             set letter {}
1299             set grid $grd
1300             puts $fd "<h3>Grid $grid</h3>"
1301         }
1302
1303         # check if test case name is <letter><digit>; 
1304         # if not, set alnum to period "." to recognize non-standard test name
1305         if { ! [regexp {([A-Za-z]+)([0-9]+)} $casename res alnum number] } {
1306             set alnum .
1307         }
1308
1309         # start new row when letter changes or for non-standard names
1310         if { $alnum != $letter || $alnum == "." } {
1311             if { $letter != "" } { 
1312                 puts $fd "</tr><tr>" 
1313             } else {
1314                 puts $fd "<table><tr>"
1315             }
1316             set letter $alnum
1317         }           
1318
1319         puts $fd "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
1320     }
1321     puts $fd "</tr></table>"
1322
1323     # add remaining lines of log as plain text
1324     puts $fd "<h2>Plain text messages</h2>\n<pre>"
1325     foreach line [split $log "\n"] {
1326         if { ! [regexp $_test_case_regexp $line] } {
1327             puts $fd "$line"
1328         }
1329     }
1330     puts $fd "</pre>"
1331
1332     # close file and exit
1333     puts $fd "</body>"
1334     close $fd
1335     return
1336 }
1337
1338 # Procedure to dump summary logs of tests
1339 proc _log_summarize {logdir log {total_time {}}} {
1340
1341     # sort log records alphabetically to have the same behavior on Linux and Windows 
1342     # (also needed if tests are run in parallel)
1343     set loglist [lsort -dictionary [split $log "\n"]]
1344
1345     # classify test cases by status
1346     foreach line $loglist {
1347         if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
1348             lappend stat($status) $caseid
1349         }
1350     }
1351     set totals {}
1352     set improvements {Improvements:}
1353     set regressions {Failed:}
1354     if { [info exists stat] } {
1355         foreach status [lsort [array names stat]] {
1356             lappend totals [list [llength $stat($status)] $status]
1357
1358             # separately count improvements (status starting with IMP) and regressions (all except IMP, OK, BAD, and SKIP)
1359             if { [regexp -nocase {^IMP} $status] } {
1360                 eval lappend improvements $stat($status)
1361             } elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
1362                 eval lappend regressions $stat($status)
1363             }
1364         }
1365     }
1366
1367     # if time is specified, add totals
1368     if { $total_time != "" } {
1369         if { [llength $improvements] > 1 } {
1370             _log_and_puts log [join $improvements "\n  "]
1371         }
1372         if { [llength $regressions] > 1 } {
1373             _log_and_puts log [join $regressions "\n  "]
1374         }
1375         if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
1376             _log_and_puts log "No regressions"
1377         }
1378         _log_and_puts log "Total cases: [join $totals {, }]"
1379         _log_and_puts log $total_time
1380     }
1381
1382     # save log to files
1383     if { $logdir != "" } {
1384         _log_html_summary $logdir $log $totals $regressions $improvements $total_time
1385         _log_save $logdir/tests.log $log "Tests summary"
1386     }
1387
1388     return
1389 }
1390
1391 # Internal procedure to generate XML log in JUnit style, for further
1392 # consumption by Jenkins or similar systems.
1393 #
1394 # The output is intended to conform to XML schema supported by Jenkins found at
1395 # 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
1396 #
1397 # The mapping of the fields is inspired by annotated schema of Apache Ant JUnit XML format found at
1398 # http://windyroad.org/dl/Open%20Source/JUnit.xsd
1399 proc _log_xml_summary {logdir filename log include_cout} {
1400     global _test_case_regexp
1401
1402     catch {file mkdir [file dirname $filename]}
1403
1404     # try to open a file and start XML
1405     if [catch {set fd [open $filename w]} res] {
1406         error "Error creating XML summary file $filename: $res"
1407     }
1408     puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1409     puts $fd "<testsuites>"
1410
1411     # prototype for command to generate test suite tag
1412     set time_and_host "timestamp=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\" hostname=\"[info hostname]\""
1413     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"}
1414
1415     # sort log and process it line-by-line
1416     set group {}
1417     foreach line [lsort -dictionary [split $log "\n"]] {
1418         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1419         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1420             continue
1421         }
1422         set message [string trim $message " \t\r\n()"]
1423
1424         # start new testsuite for each grid
1425         if { $grp != $group || $grd != $grid } {
1426
1427             # write previous test suite
1428             if [info exists testcases] { eval $cmd_testsuite }
1429
1430             set testcases {}
1431             set nbtests 0
1432             set nberr 0
1433             set nbfail 0
1434             set nbskip 0
1435             set time 0.
1436
1437             set group $grp
1438             set grid $grd
1439         }
1440
1441         incr nbtests
1442          
1443         # parse test log and get its CPU time
1444         set testout {}
1445         set add_cpu {}
1446         if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } { 
1447             puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1448         } else {
1449             while { [gets $fdlog logline] >= 0 } {
1450                 if { $include_cout } {
1451                     set testout "$testout$logline\n"
1452                 }
1453                 if [regexp -nocase {TOTAL CPU TIME:\s*([\d.]+)\s*sec} $logline res cpu] {
1454                     set add_cpu " time=\"$cpu\""
1455                     set time [expr $time + $cpu]
1456                 }
1457             }
1458             close $fdlog
1459         }
1460         if { ! $include_cout } {
1461             set testout "$line\n"
1462         }
1463
1464         # record test case with its output and status
1465         # Mapping is: SKIPPED, BAD, and OK to OK, all other to failure
1466         set testcases "$testcases\n  <testcase name=\"$casename\"$add_cpu status=\"$result\">\n"
1467         set testcases "$testcases\n    <system-out>\n$testout    </system-out>"
1468         if { $result != "OK" } {
1469             if { [regexp -nocase {^SKIP} $result] } {
1470                 incr nberr
1471                 set testcases "$testcases\n    <error name=\"$result\" message=\"$message\"/>"
1472             } elseif { [regexp -nocase {^BAD} $result] } {
1473                 incr nbskip
1474                 set testcases "$testcases\n    <skipped>$message</skipped>"
1475             } else {
1476                 incr nbfail
1477                 set testcases "$testcases\n    <failure name=\"$result\" message=\"$message\"/>"
1478             }
1479         }
1480         set testcases "$testcases\n  </testcase>"
1481     }
1482
1483     # write last test suite
1484     if [info exists testcases] { eval $cmd_testsuite }
1485
1486     # the end
1487     puts $fd "</testsuites>"
1488     close $fd
1489     return
1490 }
1491
1492 # define custom platform name 
1493 proc _tests_platform_def {} {
1494     global env tcl_platform
1495
1496     if [info exists env(os_type)] { return }
1497
1498     set env(os_type) $tcl_platform(platform)
1499
1500     # use detailed mapping for various versions of Lunix
1501     # (note that mapping is rather non-uniform, for historical reasons)
1502     if { $env(os_type) == "unix" && ! [catch {exec cat /etc/issue} issue] } {
1503         if { [regexp {Mandriva[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1504             set env(os_type) Mandriva$num
1505         } elseif { [regexp {Red Hat[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1506             set env(os_type) RedHat$num
1507         } elseif { [regexp {Debian[ \tA-Za-z/]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1508             set env(os_type) Debian$num$subnum
1509         } elseif { [regexp {CentOS[ \tA-Za-z]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1510             set env(os_type) CentOS$num$subnum
1511         } elseif { [regexp {Scientific[ \tA-Za-z]+([0-9]+)[.]([0-9]+)} $issue res num subnum] } {
1512             set env(os_type) SL$num$subnum
1513         } elseif { [regexp {Fedora Core[ \tA-Za-z]+([0-9]+)} $issue res num] } {
1514             set env(os_type) FedoraCore$num
1515         }
1516         if { [exec uname -m] == "x86_64" } {
1517             set env(os_type) "$env(os_type)-64"
1518         }
1519     }
1520 }
1521 _tests_platform_def
1522
1523 # Auxiliary procedure to split path specification (usually defined by
1524 # environment variable) into list of directories or files
1525 proc _split_path {pathspec} {
1526     global tcl_platform
1527
1528     # first replace all \ (which might occur on Windows) by /  
1529     regsub -all "\\\\" $pathspec "/" pathspec
1530
1531     # split path by platform-specific separator
1532     return [split $pathspec [_path_separator]]
1533 }
1534
1535 # Auxiliary procedure to define platform-specific separator for directories in
1536 # path specification
1537 proc _path_separator {} {
1538     global tcl_platform
1539
1540     # split path by platform-specific separator
1541     if { $tcl_platform(platform) == "windows" } {
1542         return ";"
1543     } else {
1544         return ":"
1545     }
1546 }
1547
1548 # Procedure to make a diff and common of two lists
1549 proc _list_diff {list1 list2 _in1 _in2 _common} {
1550     upvar $_in1 in1
1551     upvar $_in2 in2
1552     upvar $_common common
1553
1554     set in1 {}
1555     set in2 {}
1556     set common {}
1557     foreach item $list1 {
1558         if { [lsearch -exact $list2 $item] >= 0 } {
1559             lappend common $item
1560         } else {
1561             lappend in1 $item
1562         }
1563     }
1564     foreach item $list2 {
1565         if { [lsearch -exact $common $item] < 0 } {
1566             lappend in2 $item
1567         }
1568     }
1569     return
1570 }
1571
1572 # procedure to load a file to Tcl string
1573 proc _read_file {filename} {
1574     set fd [open $filename r]
1575     set result [read -nonewline $fd]
1576     close $fd
1577     return $result
1578 }
1579
1580 # procedure to construct name for the mage diff file
1581 proc _diff_img_name {dir1 dir2 casepath imgfile} {
1582     return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
1583 }
1584
1585 # Procedure to compare results of two runs of test cases
1586 proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
1587     upvar $_logvar log
1588
1589     # make sure to load diffimage command
1590     uplevel pload VISUALIZATION
1591
1592     # prepare variable (array) for collecting statistics
1593     if { "$_statvar" != "" } {
1594         upvar $_statvar stat
1595     } else {
1596         set stat(cpu1) 0
1597         set stat(cpu2) 0
1598         set stat(mem1) 0
1599         set stat(mem2) 0
1600         set log {}
1601     }
1602
1603     # first check subdirectories
1604     set path1 [file join $dir1 $basename]
1605     set path2 [file join $dir2 $basename]
1606     set list1 [glob -directory $path1 -types d -tails -nocomplain *]
1607     set list2 [glob -directory $path2 -types d -tails -nocomplain *]
1608     if { [llength $list1] >0 || [llength $list2] > 0 } {
1609         _list_diff $list1 $list2 in1 in2 common
1610         if { "$verbose" > 1 } {
1611             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
1612             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
1613         }
1614         foreach subdir $common {
1615             if { "$verbose" > 2 } {
1616                 _log_and_puts log "Checking [file join $basename $subdir]"
1617             }
1618             _test_diff $dir1 $dir2 [file join $basename $subdir] $status $verbose log stat
1619         }
1620     } else {
1621         # check log files (only if directory has no subdirs)
1622         set list1 [glob -directory $path1 -types f -tails -nocomplain *.log]
1623         set list2 [glob -directory $path2 -types f -tails -nocomplain *.log]
1624         _list_diff $list1 $list2 in1 in2 common
1625         if { "$verbose" > 1 } {
1626             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
1627             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
1628         }
1629         foreach logfile $common {
1630             # load two logs
1631             set log1 [_read_file [file join $dir1 $basename $logfile]]
1632             set log2 [_read_file [file join $dir2 $basename $logfile]]
1633             set casename [file rootname $logfile]
1634
1635             # check execution statuses
1636             set status1 UNDEFINED
1637             set status2 UNDEFINED
1638             if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
1639                  ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
1640                  "$status1" != "$status2" } {
1641                 _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
1642
1643                 # if test statuses are different, further comparison makes 
1644                 # no sense unless explicitly requested
1645                 if { "$status" != "all" } {
1646                     continue
1647                 }
1648             }
1649             if { "$status" == "ok" && "$status1" != "OK" } { 
1650                 continue
1651             }
1652
1653             # check CPU times
1654             set cpu1 UNDEFINED
1655             set cpu2 UNDEFINED
1656             if { [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log1 res1 cpu1] &&
1657                  [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log2 res1 cpu2] } {
1658                 set stat(cpu1) [expr $stat(cpu1) + $cpu1]
1659                 set stat(cpu2) [expr $stat(cpu2) + $cpu2]
1660
1661                 # compare CPU times with 10% precision (but not less 0.5 sec)
1662                 if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
1663                     _log_and_puts log "CPU [split $basename /] $casename: $cpu1 / $cpu2"
1664                 }
1665             }
1666
1667             # check memory delta
1668             set mem1 UNDEFINED
1669             set mem2 UNDEFINED
1670             if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
1671                  [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
1672                 set stat(mem1) [expr $stat(mem1) + $mem1]
1673                 set stat(mem2) [expr $stat(mem2) + $mem2]
1674
1675                 # compare memory usage with 10% precision (but not less 16 KiB)
1676                 if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
1677                     _log_and_puts log "MEMORY [split $basename /] $casename: $mem1 / $mem2"
1678                 }
1679             }
1680
1681             # check images
1682             set imglist1 [glob -directory $path1 -types f -tails -nocomplain $casename*.{png,gif}]
1683             set imglist2 [glob -directory $path2 -types f -tails -nocomplain $casename*.{png,gif}]
1684             _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
1685             if { "$verbose" > 1 } {
1686                 if { [llength $imgin1] > 0 } { _log_and_puts log "Only in $path1: $imgin1" }
1687                 if { [llength $imgin2] > 0 } { _log_and_puts log "Only in $path2: $imgin2" }
1688             }
1689             foreach imgfile $imgcommon {
1690 #                if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
1691                 set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
1692                 if { [catch {diffimage [file join $dir1 $basename $imgfile] \
1693                                        [file join $dir2 $basename $imgfile] \
1694                                        0 0 0 $diffile} diff] } {
1695                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
1696                     file delete -force $diffile ;# clean possible previous result of diffimage
1697                 } elseif { $diff != 0 } {
1698                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs"
1699                 } else {
1700                     file delete -force $diffile ;# clean useless artifact of diffimage
1701                 }
1702             }
1703         }
1704     }
1705
1706     if { "$_statvar" == "" } {
1707         _log_and_puts log "Total MEMORY difference: $stat(mem1) / $stat(mem2)"
1708         _log_and_puts log "Total CPU difference: $stat(cpu1) / $stat(cpu2)"
1709     }
1710 }
1711
1712 # Auxiliary procedure to save log of results comparison to file
1713 proc _log_html_diff {file log dir1 dir2} {
1714     # create missing directories as needed
1715     catch {file mkdir [file dirname $file]}
1716
1717     # try to open a file
1718     if [catch {set fd [open $file w]} res] {
1719         error "Error saving log file $file: $res"
1720     }
1721     
1722     # print header
1723     puts $fd "<html><head><title>Diff $dir1 vs. $dir2</title></head><body>"
1724     puts $fd "<h1>Comparison of test results: $dir1 vs. $dir2</h1>"
1725
1726     # print log body, trying to add HTML links to script files on lines like
1727     # "Executing <filename>..."
1728     puts $fd "<pre>"
1729     set logpath [file split [file normalize $file]]
1730     foreach line [split $log "\n"] {
1731         puts $fd $line
1732
1733         if { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
1734             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
1735                # note: special handler for the case if test grid directoried are compared directly
1736                set gridpath ""
1737             }
1738             set img1 "<img src=\"[_make_url $file [file join $dir1 $gridpath $img]]\">"
1739             set img2 "<img src=\"[_make_url $file [file join $dir2 $gridpath $img]]\">"
1740
1741             set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
1742             if { [file exists $difffile] } {
1743                 set imgd "<img src=\"[_make_url $file $difffile]\">"
1744             } else {
1745                 set imgd "N/A"
1746             }
1747
1748             puts $fd "<table><tr><th>[file tail $dir1]</th><th>[file tail $dir2]</th><th>Different pixels</th></tr>"
1749             puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
1750         }
1751     }
1752     puts $fd "</pre></body></html>"
1753
1754     close $fd
1755     return
1756 }
1757
1758 # get number of CPUs on the system
1759 proc _get_nb_cpus {} {
1760     global tcl_platform env
1761
1762     if { "$tcl_platform(platform)" == "windows" } {
1763         # on Windows, take the value of the environment variable 
1764         if { [info exists env(NUMBER_OF_PROCESSORS)] &&
1765              ! [catch {expr $env(NUMBER_OF_PROCESSORS) > 0} res] && $res >= 0 } {
1766             return $env(NUMBER_OF_PROCESSORS)
1767         }
1768     } elseif { "$tcl_platform(os)" == "Linux" } {
1769         # on Linux, take number of logical processors listed in /proc/cpuinfo
1770         if { [catch {open "/proc/cpuinfo" r} fd] } { 
1771             return 0 ;# should never happen, but...
1772         }
1773         set nb 0
1774         while { [gets $fd line] >= 0 } {
1775             if { [regexp {^processor[ \t]*:} $line] } {
1776                 incr nb
1777             }
1778         }
1779         close $fd
1780         return $nb
1781     } elseif { "$tcl_platform(os)" == "Darwin" } {
1782         # on MacOS X, call sysctl command
1783         if { ! [catch {exec sysctl hw.ncpu} ret] && 
1784              [regexp {^hw[.]ncpu[ \t]*:[ \t]*([0-9]+)} $ret res nb] } {
1785             return $nb
1786         }
1787     }
1788
1789     # if cannot get good value, return 0 as default
1790     return 0
1791 }
1792
1793 # check two files for difference
1794 proc _diff_files {file1 file2} {
1795     set fd1 [open $file1 "r"]
1796     set fd2 [open $file2 "r"]
1797
1798     set differ f
1799     while {! $differ} {
1800         set nb1 [gets $fd1 line1]
1801         set nb2 [gets $fd2 line2]
1802         if { $nb1 != $nb2 } { set differ t; break }
1803         if { $nb1 < 0 } { break }
1804         if { [string compare $line1 $line2] } {
1805             set differ t
1806         }
1807     }
1808
1809     close $fd1
1810     close $fd2
1811
1812     return $differ
1813 }
1814
1815 # Check if file is in DOS encoding.
1816 # This check is done by presence of \r\n combination at the end of the first 
1817 # line (i.e. prior to any other \n symbol).
1818 # Note that presence of non-ascii symbols typically used for recognition
1819 # of binary files is not suitable since some IGES and STEP files contain
1820 # non-ascii symbols.
1821 # Special check is added for PNG files which contain \r\n in the beginning.
1822 proc _check_dos_encoding {file} {
1823     set fd [open $file rb]
1824     set isdos f
1825     if { [gets $fd line] && [regexp {.*\r$} $line] && 
1826          ! [regexp {^.PNG} $line] } {
1827         set isdos t
1828     }
1829     close $fd
1830     return $isdos
1831 }
1832
1833 # procedure to recognize format of a data file by its first symbols (for OCCT 
1834 # BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
1835 proc _check_file_format {file} {
1836     set fd [open $file rb]
1837     set line [read $fd 1024]
1838     close $fd
1839
1840     set warn f
1841     set ext [file extension $file]
1842     set format unknown
1843     if { [regexp {^DBRep_DrawableShape} $line] } {
1844         set format BREP
1845         if { "$ext" != ".brep" && "$ext" != ".rle" && 
1846              "$ext" != ".draw" && "$ext" != "" } {
1847             set warn t
1848         }
1849     } elseif { [regexp {^DrawTrSurf_} $line] } {
1850         set format DRAW
1851         if { "$ext" != ".rle" && 
1852              "$ext" != ".draw" && "$ext" != "" } {
1853             set warn t
1854         }
1855     } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
1856         set format STEP
1857         if { "$ext" != ".step" && "$ext" != ".stp" } {
1858             set warn t
1859         }
1860     } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
1861         set format IGES
1862         if { "$ext" != ".iges" && "$ext" != ".igs" } {
1863             set warn t
1864         }
1865     } elseif { "$ext" == ".igs" } {
1866         set format IGES
1867     } elseif { "$ext" == ".stp" } {
1868         set format STEP
1869     } else {
1870         set format [string toupper [string range $ext 1 end]]
1871     }
1872     
1873     if { $warn } {
1874         puts "$file: Warning: extension ($ext) does not match format ($format)"
1875     }
1876
1877     return $format
1878 }
1879
1880 # procedure to load file knowing its format
1881 proc load_data_file {file format shape} {
1882     switch $format {
1883     BREP { uplevel restore $file $shape }
1884     DRAW { uplevel restore $file $shape }
1885     IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
1886     STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
1887     STL  { pload XSDRAW; uplevel readstl $shape $file }
1888     default { error "Cannot read $format file $file" }
1889     }
1890 }
1891
1892 # procedure to get name of temporary directory,
1893 # ensuring it is existing and writeable 
1894 proc _get_temp_dir {} {
1895     global env
1896
1897     # check typical environment variables 
1898     foreach var {TempDir Temp Tmp} {
1899         # check different case
1900         foreach name [list [string toupper $var] $var [string tolower $var]] {
1901             if { [info exists env($name)] && [file isdirectory $env($name)] &&
1902                  [file writable $env($name)] } {
1903                 return [regsub -all {\\} $env($name) /]
1904             }
1905         }
1906     }
1907
1908     # check platform-specific locations
1909     set fallback tmp
1910     if { "$tcl_platform(platform)" == "windows" } {
1911         set paths "c:/TEMP c:/TMP /TEMP /TMP"
1912         if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
1913             set fallback [regsub -all {\\} "$env(HOMEDRIVE)$(HOMEPATH)/tmp" /]
1914         }
1915     } else {
1916         set paths "/tmp /var/tmp /usr/tmp"
1917         if { [info exists env(HOME)] } {
1918             set fallback "$env(HOME)/tmp"
1919         }
1920     }
1921     foreach dir $paths {
1922         if { [file isdirectory $dir] && [file iswritable $dir] } {
1923             return $dir
1924         }
1925     }
1926
1927     # fallback case: use subdir /tmp of home or current dir
1928     file mkdir $fallback
1929     return $fallback
1930 }