0023970: Ignore dot-paths when searching for data files
[occt.git] / src / DrawResources / TestCommands.tcl
index b4a37f6..29a64e4 100644 (file)
@@ -18,7 +18,8 @@
 ############################################################################
 # This file defines scripts for execution of OCCT tests.
 # It should be loaded automatically when DRAW is started, and provides
-# three top-level commands: 'test', 'testgrid', and 'testdiff'.
+# top-level commands starting with 'test'. Type 'help test' to get their
+# synopsys.
 # See OCCT Tests User Guide for description of the test system.
 #
 # Note: procedures with names starting with underscore are for internal use 
@@ -48,7 +49,7 @@ proc test {group grid casename {echo 0}} {
     if { "$echo" == "-echo" } { set echo t }
 
     # run test
-    uplevel _run_test $dir $group $gridname $casefile $echo
+    uplevel _run_test $dir $group $gridname $casefile $echo 
 
     # check log
     if { ! $echo } {
@@ -64,7 +65,7 @@ help testgrid {
   Use: testgrid [group [grid]] [options...]
   Allowed options are:
   -parallel N: run N parallel processes (default is number of CPUs, 0 to disable)
-  -refresh N: save summary logs every N seconds (default 60, minimal 1, 0 to disable)
+  -refresh N: save summary logs every N seconds (default 600, minimal 1, 0 to disable)
   -outdir dirname: set log directory (should be empty or non-existing)
   -overwrite: force writing logs in existing non-empty directory
   -xml filename: write XML report for Jenkins (in JUnit-like format)
@@ -294,12 +295,15 @@ proc testgrid {args} {
     ######################################################
     
     # log command arguments and environment
-    set log "Command: testgrid $args\nHost: [info hostname]\nStarted on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]\n"
-    set log "$log\nEnvironment:\n"
-    foreach envar [array names env] {
-       set log "$log$envar=\"$env($envar)\"\n"
+    lappend log "Command: testgrid $args"
+    lappend log "Host: [info hostname]"
+    lappend log "Started on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]"
+    catch {lappend log "DRAW build:\n[dversion]" }
+    lappend log "Environment:"
+    foreach envar [lsort [array names env]] {
+       lappend log "$envar=\"$env($envar)\""
     }
-    set log "$log\n"
+    lappend log ""
 
     set refresh_timer [clock seconds]
     uplevel dchrono _timer reset
@@ -316,11 +320,23 @@ proc testgrid {args} {
            # of starting / processing jobs by running threads
            catch {tpool::suspend $worker}
            if { $_tests_verbose > 0 } { _log_and_puts log "Executing tests in (up to) $parallel threads" }
+            # limit number of jobs in the queue by reasonable value
+            # to prevent slowdown due to unnecessary queue processing
+            set nbpooled 0
+            set nbpooled_max [expr 10 * $parallel]
+            set nbpooled_ok  [expr  5 * $parallel]
        }
     }
 
     # start test cases
+    set userbreak 0
     foreach test_def $tests_list {
+        # check for user break
+        if { $userbreak || "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
+            set userbreak 1
+            break
+        }
+
        set dir       [lindex $test_def 0]
        set group     [lindex $test_def 1]
        set grid      [lindex $test_def 2]
@@ -369,6 +385,10 @@ proc testgrid {args} {
            # parallel execution
            set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
            set job_def($job) [list $logdir $dir $group $grid $casename]
+            incr nbpooled
+            if { $nbpooled > $nbpooled_max } {
+                _testgrid_process_jobs $worker $nbpooled_ok
+            }
        } else {
            # sequential execution
            catch {eval $command} output
@@ -385,26 +405,23 @@ proc testgrid {args} {
 
     # get results of started threads
     if { $parallel > 0 } {
-       catch {tpool::resume $worker}
-       while { [llength [array names job_def]] > 0 } {
-           foreach job [tpool::wait $worker [array names job_def]] {
-               eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
-               unset job_def($job)
-           }
-
-           # update summary log with requested period
-           if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
-               _log_summarize $logdir $log
-               set refresh_timer [clock seconds]
-           }
-       }
+        _testgrid_process_jobs $worker
        # release thread pool
+        if { $nbpooled > 0 } {
+           tpool::cancel $worker [array names job_def]
+        }
+        catch {tpool::resume $worker}
        tpool::release $worker
     }
 
     uplevel dchrono _timer stop
     set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
 
+    if { $userbreak } {
+        _log_and_puts log "*********** Stopped by user break ***********"
+        set time "${time} \nNote: the process is not finished, stopped by user break!"
+    }
+
     ######################################################
     # output summary logs and exit
     ######################################################
@@ -425,22 +442,68 @@ proc testgrid {args} {
     return
 }
 
+# Procedure to regenerate summary log from logs of test cases
+help testsummarize {
+  Regenerate summary log in the test directory from logs of test cases.
+  This can be necessary if test grids are executed separately (e.g. on
+  different stations) or some grids have been re-executed.
+  Use: testsummarize dir
+}
+proc testsummarize {dir} {
+    global _test_case_regexp
+
+    if { ! [file isdirectory $dir] } {
+       error "Error: \"$dir\" is not a directory"
+    }
+
+    # get summary statements from all test cases in one log
+    set log {}
+
+    # to avoid huge listing of logs, first find all subdirectories and iterate
+    # by them, parsing log files in each subdirectory independently 
+    foreach grid [glob -directory $dir -types d -tails */*] {
+        foreach caselog [glob -nocomplain -directory [file join $dir $grid] -types f -tails *.log] {
+            set file [file join $dir $grid $caselog]
+            set nbfound 0
+            set fd [open $file r]
+           while { [gets $fd line] >= 0 } {
+               if { [regexp $_test_case_regexp $line res grp grd cas status message] } {
+                    if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } { 
+                        puts "Error: $file contains status line for another test case ($line)"
+                    }
+                   lappend log $line
+                   incr nbfound
+               }
+           }
+            close $fd
+
+            if { $nbfound != 1 } { 
+                puts "Error: $file contains $nbfound status lines, expected 1"
+            }
+        }
+    }
+
+    _log_summarize $dir $log "Summary regenerated from logs at [clock format [clock seconds]]"
+    return
+}
+
 # Procedure to compare results of two runs of test cases
 help testdiff {
   Compare results of two executions of tests (CPU times, ...)
-  Use: testdiff dir1 dir2 [options...]
+  Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
   Where dir1 and dir2 are directories containing logs of two test runs.
   Allowed options are:
-  -save filename: save resulting log in specified file
-  -subdir name: compare only specified subdirectory (can be nested)
+  -save filename: save resulting log in specified file (default name is
+                  <dir1>/diff-<dir2>.log); HTML log is saved with same name
+                  and extension .html
   -status {same|ok|all}: filter cases for comparing by their status:
           same - only cases with same status are compared (default)
           ok   - only cases with OK status in both logs are compared
           all  - results are compared regardless of status
   -verbose level: 
           1 - output only differences 
-          2 - output list of logs and directories present in one of dirs only
-          3 - (default) output progress messages 
+          2 - output also list of logs and directories present in one of dirs only
+          3 - (default) output also progress messages 
 }
 proc testdiff {dir1 dir2 args} {
     if { "$dir1" == "$dir2" } {
@@ -452,7 +515,7 @@ proc testdiff {dir1 dir2 args} {
     ######################################################
 
     # treat options
-    set logfile ""
+    set logfile [file join $dir1 "diff-[file tail $dir2].log"]
     set basename ""
     set status "same"
     set verbose 3
@@ -462,7 +525,7 @@ proc testdiff {dir1 dir2 args} {
        # log file name
        if { $arg == "-save" } {
            incr narg
-           if { $narg < [llength $args] } { 
+           if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
                set logfile [lindex $args $narg]
            } else {
                error "Error: Option -save must be followed by log file name"
@@ -470,21 +533,10 @@ proc testdiff {dir1 dir2 args} {
            continue
        }
 
-       # subdirectory to compare
-       if { $arg == "-subdir" } {
-           incr narg
-           if { $narg < [llength $args] } { 
-               set basename [lindex $args $narg]
-           } else {
-               error "Error: Option -subdir must be followed by subdirectory path"
-           }
-           continue
-       }
-
        # status filter
        if { $arg == "-status" } {
            incr narg
-           if { $narg < [llength $args] } { 
+           if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
                set status [lindex $args $narg]
             } else { set status "" }
            if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
@@ -496,15 +548,20 @@ proc testdiff {dir1 dir2 args} {
        # verbose level
        if { $arg == "-verbose" } {
            incr narg
-           if { $narg < [llength $args] } { 
+           if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { 
                set verbose [expr [lindex $args $narg]]
+           } else {
+               error "Error: Option -verbose must be followed by integer verbose level"
            }
            continue
        }
 
-#      if { [regexp {^-} $arg] } {
+       if { [regexp {^-} $arg] } {
            error "Error: unsupported option \"$arg\""
-#      }
+       }
+
+        # non-option arguments form a subdirectory path
+       set basename [file join $basename $arg]
     }
 
     # run diff procedure (recursive)
@@ -512,12 +569,217 @@ proc testdiff {dir1 dir2 args} {
 
     # save result to log file
     if { "$logfile" != "" } {
-        _log_save $logfile $log
+        _log_save $logfile [join $log "\n"]
+        _log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2
+        puts "Log is saved to $logfile (and .html)"
     }
 
     return
 }
 
+# Procedure to check data file before adding it to repository
+help testfile {
+  Check data file and prepare it for putting to test data files repository.
+  Use: testfile [filelist]
+
+  Will report if:
+  - data file (non-binary) is in DOS encoding (CR/LF)
+  - same data file (with same or another name) already exists in the repository
+  - another file with the same name already exists 
+  Note that names are assumed to be case-insensitive (for Windows).
+
+  Unless the file is already in the repository, tries to load it, reports
+  the recognized file format, file size, number of faces and edges in the 
+  loaded shape (if any), and makes snapshot (in the temporary directory).
+  Finally it advises whether the file should be put to public section of the 
+  repository.
+}
+proc testfile {filelist} {
+    global env
+
+    # check that CSF_TestDataPath is defined
+    if { ! [info exists env(CSF_TestDataPath)] } {
+        error "Environment variable CSF_TestDataPath must be defined!"
+    }
+
+    # build registry of existing data files (name -> path) and (size -> path)
+    puts "Checking available test data files..."
+    foreach dir [_split_path $env(CSF_TestDataPath)] {
+        while {[llength $dir] != 0} {
+            set curr [lindex $dir 0]
+            set dir [lrange $dir 1 end]
+            eval lappend dir [glob -nocomplain -directory $curr -type d *]
+            foreach file [glob -nocomplain -directory $curr -type f *] {
+                set name [file tail $file]
+                set name_lower [string tolower $name]
+
+                # check that the file is not in DOS encoding
+                if { [_check_dos_encoding $file] } {
+                    puts "Warning: file $file is in DOS encoding; was this intended?"
+                }
+                _check_file_format $file
+
+                # check if file with the same name is present twice or more
+                if { [info exists names($name_lower)] } {
+                    puts "Error: more than one file with name $name is present in the repository:"
+                    if { [_diff_files $file $names($name_lower)] } {
+                        puts "(files are different by content)"
+                    } else {
+                        puts "(files are same by content)"
+                    }
+                    puts "--> $file"
+                    puts "--> $names($name_lower)"
+                    continue
+                } 
+                
+                # check if file with the same content exists
+                set size [file size $file]
+                if { [info exists sizes($size)] } {
+                    foreach other $sizes($size) {
+                        if { ! [_diff_files $file $other] } {
+                            puts "Warning: two files with the same content found:"
+                            puts "--> $file"
+                            puts "--> $other"
+                        }
+                    }
+                }
+
+                # add the file to the registry
+                set names($name_lower) $file
+                lappend sizes($size) $file
+           }
+       }
+    }
+    if { [llength $filelist] <= 0 } { return }
+
+    # check the new files
+    set has_images f
+    puts "Checking new file(s)..."
+    foreach file $filelist {
+        # check for DOS encoding
+        if { [_check_dos_encoding $file] } {
+            puts "$file: Warning: DOS encoding detected"
+        }
+
+        set name [file tail $file]
+        set name_lower [string tolower $name]
+
+        # check for presence of the file with same name
+        if { [info exists names($name_lower)] } {
+            if { [_diff_files $file $names($name_lower)] } {
+                puts "$file: Error: name is already used by existing file\n--> $names($name_lower)"
+            } else {
+                puts "$file: OK: already in the repository \n--> $names($name_lower)"
+                continue
+            }
+        }
+                
+        # check if file with the same content exists
+        set size [file size $file]
+        if { [info exists sizes($size)] } {
+            set found f
+            foreach other $sizes($size) {
+                if { ! [_diff_files $file $other] } {
+                     puts "$file: OK: the same file is already present under name [file tail $other]\n--> $other"
+                     set found t
+                     break
+                }
+            }
+            if { $found } { continue }
+        }
+
+        # try to read the file
+        set format [_check_file_format $file]
+        if { [catch {uplevel load_data_file $file $format a}] } {
+            puts "$file: Error: Cannot read as $format file"
+            continue
+        }
+
+        # get number of faces and edges
+        set edges 0
+        set faces 0
+        set nbs [uplevel nbshapes a]
+        regexp {EDGE[ \t:]*([0-9]+)} $nbs res edges
+        regexp {FACE[ \t:]*([0-9]+)} $nbs res faces
+
+        # classify; first check file size and number of faces and edges
+        if { $size < 95000 && $faces < 20 && $edges < 100 } {
+            set dir public
+        } else {
+            set dir private
+            # check if one of names of that file corresponds to typical name for 
+            # MDTV bugs or has extension .rle, this should be old model
+            if { [regexp -nocase {.*(cts|ats|pro|buc|ger|fra|usa|uki)[0-9]+.*} $name] ||
+                 [regexp -nocase {[.]rle\y} $name] } {
+                set dir old
+            }
+        }
+
+        # add stats
+        puts "$file: $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
+
+        set tmpdir [_get_temp_dir]
+        file mkdir $tmpdir/$dir
+
+        # make snapshot
+        pload AISV
+        uplevel vdisplay a
+        uplevel vfit
+        uplevel vzfit
+        uplevel vdump $tmpdir/$dir/[file rootname [file tail $file]].png
+        set has_images t
+    }
+    if { $has_images } {
+        puts "Snapshots are saved in subdirectory [_get_temp_dir]"
+    }
+}
+
+# Procedure to locate data file for test given its name.
+# The search is performed assuming that the function is called
+# from the test case script; the search order is:
+# - subdirectory "data" of the test script (grid) folder
+# - subdirectories in environment variable CSF_TestDataPath
+# - subdirectory set by datadir command
+# If file is not found, raises Tcl error.
+proc locate_data_file {filename} {
+    global env groupname gridname casename
+
+    # check if the file is located in the subdirectory data of the script dir
+    set scriptfile [info script]
+    if { $scriptfile != "" } {
+        set path [file join [file dirname $scriptfile] data $filename]
+       if { [file exists $path] } {
+           return [file normalize $path]
+       }
+    }
+
+    # check sub-directories in paths indicated by CSF_TestDataPath
+    if { [info exists env(CSF_TestDataPath)] } {
+       foreach dir [_split_path $env(CSF_TestDataPath)] {
+           while {[llength $dir] != 0} { 
+               set name [lindex $dir 0]
+               set dir [lrange $dir 1 end]
+                # skip directories starting with dot
+                if { [regexp {^[.]} $name] } { continue }
+               if { [file exists $name/$filename] } {
+                   return [file normalize $name/$filename]
+               }
+               eval lappend dir [glob -nocomplain -directory $name -type d *]
+           }
+       }
+    }
+
+    # check current datadir
+    if { [file exists [uplevel datadir]/$filename] } {
+       return [file normalize [uplevel datadir]/$filename]
+    }
+
+    # raise error
+    error [join [list "File $filename could not be found" \
+                     "(should be in paths indicated by CSF_TestDataPath environment variable, " \
+                      "or in subfolder data in the script directory)"] "\n"]
+}
+
 # Internal procedure to find test case indicated by group, grid, and test case names;
 # returns:
 # - dir: path to the base directory of the tests group
@@ -602,6 +864,7 @@ proc _run_test {scriptsdir group gridname casefile echo} {
     # start timer
     uplevel dchrono _timer reset
     uplevel dchrono _timer start
+    catch {uplevel meminfo w} membase
 
     # enable commands logging; switch to old-style mode if dlog command is not present
     set dlog_exists 1
@@ -621,24 +884,30 @@ proc _run_test {scriptsdir group gridname casefile echo} {
                set optarg [lindex $args end-1]
                if { $optarg == "stdout" || $optarg == "stderr" || $optarg == "-newline" } {
                    dlog add [lindex $args end]
+               } else {
+                   eval puts-saved $args
                }
            } else {
                dlog add [lindex $args end]
            }
-
-           # reproduce original puts
-           if { $_tests_verbose } {
-               eval puts-saved $args
-           }
        }
     }
 
     # evaluate test case 
     if [catch {
+        # set variables identifying test case
        uplevel set casename [file tail $casefile]
        uplevel set groupname $group
        uplevel set gridname $gridname
+       uplevel set dirname  $scriptsdir
+
+       # set variables for saving of images if not yet set
+       if { ! [uplevel info exists imagedir] } {
+           uplevel set imagedir [_get_temp_dir]
+           uplevel set test_image \$casename
+       }
 
+       # execute test scripts 
         if { [file exists $scriptsdir/$group/begin] } {
            puts "Executing $scriptsdir/$group/begin..."; flush stdout
            uplevel source $scriptsdir/$group/begin
@@ -677,15 +946,20 @@ proc _run_test {scriptsdir group gridname casefile echo} {
     # stop cpulimit killer if armed by the test
     cpulimit
 
-    # add timing info
+    # add memory and timing info
+    set stats ""
+    if { ! [catch {uplevel meminfo w} memuse] } {
+        set stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
+    }
     uplevel dchrono _timer stop
     set time [uplevel dchrono _timer show]
     if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
-       if { $dlog_exists && ! $echo } {
-           dlog add "TOTAL CPU TIME: $cpu sec"
-       } else {
-           puts "TOTAL CPU TIME: $cpu sec"
-       }
+       set stats "${stats}TOTAL CPU TIME: $cpu sec\n"
+    }
+    if { $dlog_exists && ! $echo } {
+       dlog add $stats
+    } else {
+       puts $stats
     }
 }
 
@@ -694,8 +968,8 @@ proc _check_log {dir group gridname casename log {_summary {}} {_html_log {}}} {
     global env
     if { $_summary != "" } { upvar $_summary summary }
     if { $_html_log != "" } { upvar $_html_log html_log }
-    set summary ""
-    set html_log ""
+    set summary {}
+    set html_log {}
 
 if [catch {
 
@@ -733,7 +1007,7 @@ if [catch {
        if [regexp -nocase {^[ \t]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
            if { ! [regexp -nocase {\mAll\M} $platforms] && 
                  ! [regexp -nocase "\\m$env(os_type)\\M" $platforms] } {
-               set html_log "$html_log\n$line"
+               lappend html_log $line
                continue ;# TODO statement is for another platform
            }
 
@@ -743,7 +1017,7 @@ if [catch {
             }
 
            lappend todos [regsub -all {\\b} [string trim $pattern] {\\y}] ;# convert regexp from Perl to Tcl style
-           set html_log "$html_log\n[_html_highlight BAD $line]"
+           lappend html_log [_html_highlight BAD $line]
            continue
        }
 
@@ -757,7 +1031,7 @@ if [catch {
                    if { [regexp [lindex $todos $i] $line] } {
                        set is_known 1
                        incr todo_count($i)
-                       set html_log "$html_log\n[_html_highlight BAD $line]"
+                       lappend html_log [_html_highlight BAD $line]
                        break
                    }
                }
@@ -765,7 +1039,7 @@ if [catch {
                # if it is not in todo, define status
                if { ! $is_known } {
                    set stat [lindex $bw 0 0]
-                   set html_log "$html_log\n[_html_highlight $stat $line]"
+                   lappend html_log [_html_highlight $stat $line]
                    if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
                        set status [lindex $bw 0]
                    }
@@ -775,7 +1049,7 @@ if [catch {
            }
        }
        if { ! $ismarked } { 
-           set html_log "$html_log\n$line"
+           lappend html_log $line
        }
     }
 
@@ -818,18 +1092,15 @@ if [catch {
 
     # put final message
     _log_and_puts summary "CASE $group $gridname $casename: $status"
-    set html_log "[_html_highlight [lindex $status 0] $summary]\n$html_log"
+    set summary [join $summary "\n"]
+    set html_log "[_html_highlight [lindex $status 0] $summary]\n[join $html_log \n]"
 }
 
 # Auxiliary procedure putting message to both cout and log variable (list)
 proc _log_and_puts {logvar message} {
     if { $logvar != "" } { 
        upvar $logvar log
-       if [info exists log] { 
-           set log "$log$message\n"
-       } else {
-           set log "$message\n"
-       }
+       lappend log $message
     }
     puts $message
 }
@@ -840,7 +1111,7 @@ proc _log_test_case {output logdir dir group grid casename logvar} {
 
     # check result and make HTML log
     _check_log $dir $group $grid $casename $output summary html_log
-    set log "$log$summary"
+    lappend log $summary
 
     # save log to file
     if { $logdir != "" } {
@@ -866,6 +1137,22 @@ proc _log_save {file log {title {}}} {
     return
 }
 
+# Auxiliary procedure to make a (relative if possible) URL to a file for 
+# inclusion a reference in HTML log
+proc _make_url {htmldir file} {
+    set htmlpath [file split [file normalize $htmldir]]
+    set filepath [file split [file normalize $file]]
+    for {set i 0} {$i < [llength $htmlpath]} {incr i} {
+        if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
+            if { $i == 0 } { break }
+            return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
+        }
+    }
+
+    # if relative path could not be made, return full file URL
+    return "file://[file normalize $file]"
+}
+
 # Auxiliary procedure to save log to file
 proc _log_html {file log {title {}}} {
     # create missing directories as needed
@@ -877,34 +1164,21 @@ proc _log_html {file log {title {}}} {
     }
     
     # print header
-    puts $fd "<html><head><title>$title</title><head><body><h1>$title</h1>"
+    puts $fd "<html><head><title>$title</title></head><body><h1>$title</h1>"
 
     # add images if present
     set imgbasename [file rootname [file tail $file]]
     foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails ${imgbasename}*.gif ${imgbasename}*.png ${imgbasename}*.jpg]] {
-       puts $fd "<p><img src=\"$img\"/><p>"
+       puts $fd "<p>[file tail $img]<br><img src=\"$img\"/><p>"
     }
 
     # print log body, trying to add HTML links to script files on lines like
     # "Executing <filename>..."
     puts $fd "<pre>"
-    set logpath [file split [file normalize $file]]
     foreach line [split $log "\n"] {
         if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
              [file exists $script] } {
-
-            # generate relative path to the script file 
-            set url "file://[file normalize $script]"
-            set scriptpath [file split [file normalize $script]]
-           for {set i 0} {$i < [llength $logpath]} {incr i} {
-                if { "[lindex $logpath $i]" != "[lindex $scriptpath $i]]" } {
-                    if { $i == 0 } { break }
-                    set url "[string repeat "../" [expr [llength $logpath] - $i - 1]]/[file join [lrange $scriptpath $i end]]"
-                    break
-                }
-            }
-
-            set line [regsub $script $line "<a href=\"$url\">$script</a>"]
+            set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
         }
         puts $fd $line
     }
@@ -945,8 +1219,8 @@ proc _html_highlight {status line} {
 proc _log_html_summary {logdir log totals regressions improvements total_time} {
     global _test_case_regexp
 
-     # create missing directories as needed
-    catch {file mkdir $logdir}
+    # create missing directories as needed
+    file mkdir $logdir
 
     # try to open a file and start HTML
     if [catch {set fd [open $logdir/summary.html w]} res] {
@@ -982,7 +1256,8 @@ proc _log_html_summary {logdir log totals regressions improvements total_time} {
 
     # time stamp and elapsed time info
     if { $total_time != "" } { 
-       puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname] <p> $total_time" 
+       puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname]\n<p>"
+        puts $fd [join [split $total_time "\n"] "<p>"]
     } else {
        puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
     }
@@ -1010,13 +1285,15 @@ proc _log_html_summary {logdir log totals regressions improvements total_time} {
        puts $fd "</table>"
     }
 
-    # put detailed log
-    puts $fd "<h1>Details</h1>"
+    # put detailed log with TOC
+    puts $fd "<hr><h1>Details</h1>"
+    puts $fd "<div style=\"float:right; padding: 10px; border-style: solid; border-color: blue; border-width: 2px;\">"
 
     # process log line-by-line
     set group {}
     set letter {}
-    foreach line [lsort -dictionary [split $log "\n"]] {
+    set body {}
+    foreach line [lsort -dictionary $log] {
        # check that the line is case report in the form "CASE group grid name: result (explanation)"
        if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
            continue
@@ -1024,44 +1301,47 @@ proc _log_html_summary {logdir log totals regressions improvements total_time} {
 
        # start new group
        if { $grp != $group } {
-           if { $letter != "" } { puts $fd "</tr></table>" }
+           if { $letter != "" } { lappend body "</tr></table>" }
            set letter {}
            set group $grp
            set grid {}
-           puts $fd "<h2>Group $group</h2>"
+           puts $fd "<a href=\"#$group\">$group</a><br>"
+           lappend body "<h2><a name=\"$group\">Group $group</a></h2>"
        }
 
        # start new grid
        if { $grd != $grid } {
-           if { $letter != "" } { puts $fd "</tr></table>" }
+           if { $letter != "" } { lappend body "</tr></table>" }
            set letter {}
            set grid $grd
-           puts $fd "<h3>Grid $grid</h3>"
+           puts $fd "&nbsp;&nbsp;&nbsp;&nbsp;<a href=\"#$group-$grid\">$grid</a><br>"
+           lappend body "<h2><a name=\"$group-$grid\">Grid $group $grid</a></h2>"
        }
 
        # check if test case name is <letter><digit>; 
        # if not, set alnum to period "." to recognize non-standard test name
-       if { ! [regexp {([A-Za-z]+)([0-9]+)} $casename res alnum number] } {
-           set alnum .
+       if { ! [regexp {\A([A-Za-z]{1,2})([0-9]{1,2})\Z} $casename res alnum number] &&
+             ! [regexp {\A([A-Za-z0-9]+)_([0-9]+)\Z} $casename res alnum number] } {
+           set alnum $casename
        }
 
        # start new row when letter changes or for non-standard names
        if { $alnum != $letter || $alnum == "." } {
            if { $letter != "" } { 
-               puts $fd "</tr><tr>" 
+               lappend body "</tr><tr>" 
            } else {
-               puts $fd "<table><tr>"
+               lappend body "<table><tr>"
            }
            set letter $alnum
        }           
 
-       puts $fd "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
+       lappend body "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
     }
-    puts $fd "</tr></table>"
+    puts $fd "</div>\n[join $body "\n"]</tr></table>"
 
     # add remaining lines of log as plain text
     puts $fd "<h2>Plain text messages</h2>\n<pre>"
-    foreach line [split $log "\n"] {
+    foreach line $log {
        if { ! [regexp $_test_case_regexp $line] } {
            puts $fd "$line"
        }
@@ -1079,7 +1359,7 @@ proc _log_summarize {logdir log {total_time {}}} {
 
     # sort log records alphabetically to have the same behavior on Linux and Windows 
     # (also needed if tests are run in parallel)
-    set loglist [lsort -dictionary [split $log "\n"]]
+    set loglist [lsort -dictionary $log]
 
     # classify test cases by status
     foreach line $loglist {
@@ -1121,7 +1401,7 @@ proc _log_summarize {logdir log {total_time {}}} {
     # save log to files
     if { $logdir != "" } {
        _log_html_summary $logdir $log $totals $regressions $improvements $total_time
-       _log_save $logdir/tests.log $log "Tests summary"
+       _log_save $logdir/tests.log [join $log "\n"] "Tests summary"
     }
 
     return
@@ -1153,7 +1433,7 @@ proc _log_xml_summary {logdir filename log include_cout} {
 
     # sort log and process it line-by-line
     set group {}
-    foreach line [lsort -dictionary [split $log "\n"]] {
+    foreach line [lsort -dictionary $log] {
        # check that the line is case report in the form "CASE group grid name: result (explanation)"
        if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
            continue
@@ -1238,7 +1518,7 @@ proc _tests_platform_def {} {
 
     # use detailed mapping for various versions of Lunix
     # (note that mapping is rather non-uniform, for historical reasons)
-    if { $env(os_type) == "unix" && ! [catch {exec cat /etc/issue} issue] } {
+    if { $tcl_platform(os) == "Linux" && ! [catch {exec cat /etc/issue} issue] } {
        if { [regexp {Mandriva[ \tA-Za-z]+([0-9]+)} $issue res num] } {
            set env(os_type) Mandriva$num
        } elseif { [regexp {Red Hat[ \tA-Za-z]+([0-9]+)} $issue res num] } {
@@ -1255,6 +1535,8 @@ proc _tests_platform_def {} {
        if { [exec uname -m] == "x86_64" } {
            set env(os_type) "$env(os_type)-64"
        }
+    } elseif { $tcl_platform(os) == "Darwin" } {
+        set env(os_type) MacOS
     }
 }
 _tests_platform_def
@@ -1284,48 +1566,6 @@ proc _path_separator {} {
     }
 }
 
-# Procedure to locate data file for test given its name.
-# The search is performed assuming that the function is called 
-# from the test case script; the search order is:
-# - subdirectories in environment variable CSF_TestDataPath  
-# If file is not found, raises Tcl error.
-proc locate_data_file {filename} {
-    global env groupname gridname casename
-
-    # check if the file is located in the subdirectory data of the script dir
-    set scriptfile [info script]
-    if { $scriptfile != "" } {
-        set path [file join [file dirname $scriptfile] data $filename]
-       if { [file exists $path] } {
-           return [file normalize $path]
-       }
-    }
-
-    # check sub-directories in paths indicated by CSF_TestDataPath
-    if { [info exists env(CSF_TestDataPath)] } {
-       foreach dir [_split_path $env(CSF_TestDataPath)] {
-           while {[llength $dir] != 0} { 
-               set name [lindex $dir 0]
-               set dir [lrange $dir 1 end]
-               eval lappend dir [glob -nocomplain -directory $name -type d *]
-               if { [file exists $name/$filename] } {
-                   return [file normalize $name/$filename]
-               }
-           }
-       }
-    }
-
-    # check current datadir
-    if { [file exists [uplevel datadir]/$filename] } {
-       return [file normalize [uplevel datadir]/$filename]
-    }
-
-    # raise error
-    error [join [list "Error: file $filename could not be found" \
-                     "(should be in paths indicated by CSF_TestDataPath environment variable, " \
-                      "or in subfolder data in the script directory)"] "\n"]
-}
-
 # Procedure to make a diff and common of two lists
 proc _list_diff {list1 list2 _in1 _in2 _common} {
     upvar $_in1 in1
@@ -1358,16 +1598,26 @@ proc _read_file {filename} {
     return $result
 }
 
+# procedure to construct name for the mage diff file
+proc _diff_img_name {dir1 dir2 casepath imgfile} {
+    return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
+}
+
 # Procedure to compare results of two runs of test cases
 proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
     upvar $_logvar log
 
+    # make sure to load diffimage command
+    uplevel pload VISUALIZATION
+
     # prepare variable (array) for collecting statistics
     if { "$_statvar" != "" } {
         upvar $_statvar stat
     } else {
         set stat(cpu1) 0
         set stat(cpu2) 0
+        set stat(mem1) 0
+        set stat(mem2) 0
         set log {}
     }
 
@@ -1401,6 +1651,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
             # load two logs
            set log1 [_read_file [file join $dir1 $basename $logfile]]
            set log2 [_read_file [file join $dir2 $basename $logfile]]
+            set casename [file rootname $logfile]
 
             # check execution statuses
             set status1 UNDEFINED
@@ -1408,7 +1659,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
            if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
                 ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
                 "$status1" != "$status2" } {
-               _log_and_puts log "STATUS [split $basename /] [file rootname $logfile]: $status1 / $status2"
+               _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
 
                 # if test statuses are different, further comparison makes 
                # no sense unless explicitly requested
@@ -1430,17 +1681,101 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
 
                 # compare CPU times with 10% precision (but not less 0.5 sec)
                if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
-                   _log_and_puts log "CPU [split $basename /] [file rootname $logfile]: $cpu1 / $cpu2"
+                   _log_and_puts log "CPU [split $basename /] $casename: $cpu1 / $cpu2"
                 }
            }
+
+            # check memory delta
+            set mem1 UNDEFINED
+            set mem2 UNDEFINED
+           if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
+                [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
+                set stat(mem1) [expr $stat(mem1) + $mem1]
+                set stat(mem2) [expr $stat(mem2) + $mem2]
+
+                # compare memory usage with 10% precision (but not less 16 KiB)
+               if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
+                   _log_and_puts log "MEMORY [split $basename /] $casename: $mem1 / $mem2"
+                }
+           }
+
+            # check images
+            set imglist1 [glob -directory $path1 -types f -tails -nocomplain $casename*.{png,gif}]
+            set imglist2 [glob -directory $path2 -types f -tails -nocomplain $casename*.{png,gif}]
+            _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
+            if { "$verbose" > 1 } {
+                if { [llength $imgin1] > 0 } { _log_and_puts log "Only in $path1: $imgin1" }
+                if { [llength $imgin2] > 0 } { _log_and_puts log "Only in $path2: $imgin2" }
+            }
+            foreach imgfile $imgcommon {
+#                if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
+                set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
+                if { [catch {diffimage [file join $dir1 $basename $imgfile] \
+                                       [file join $dir2 $basename $imgfile] \
+                                       0 0 0 $diffile} diff] } {
+                    _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
+                    file delete -force $diffile ;# clean possible previous result of diffimage
+                } elseif { $diff != 0 } {
+                    _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs"
+                } else {
+                    file delete -force $diffile ;# clean useless artifact of diffimage
+                }
+            }
        }
     }
 
     if { "$_statvar" == "" } {
+        _log_and_puts log "Total MEMORY difference: $stat(mem1) / $stat(mem2)"
         _log_and_puts log "Total CPU difference: $stat(cpu1) / $stat(cpu2)"
     }
 }
 
+# Auxiliary procedure to save log of results comparison to file
+proc _log_html_diff {file log dir1 dir2} {
+    # create missing directories as needed
+    catch {file mkdir [file dirname $file]}
+
+    # try to open a file
+    if [catch {set fd [open $file w]} res] {
+       error "Error saving log file $file: $res"
+    }
+    
+    # print header
+    puts $fd "<html><head><title>Diff $dir1 vs. $dir2</title></head><body>"
+    puts $fd "<h1>Comparison of test results: $dir1 vs. $dir2</h1>"
+
+    # print log body, trying to add HTML links to script files on lines like
+    # "Executing <filename>..."
+    puts $fd "<pre>"
+    set logpath [file split [file normalize $file]]
+    foreach line $log {
+        puts $fd $line
+
+        if { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
+            if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
+               # note: special handler for the case if test grid directoried are compared directly
+               set gridpath ""
+            }
+            set img1 "<img src=\"[_make_url $file [file join $dir1 $gridpath $img]]\">"
+            set img2 "<img src=\"[_make_url $file [file join $dir2 $gridpath $img]]\">"
+
+            set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
+            if { [file exists $difffile] } {
+                set imgd "<img src=\"[_make_url $file $difffile]\">"
+            } else {
+                set imgd "N/A"
+            }
+
+            puts $fd "<table><tr><th>[file tail $dir1]</th><th>[file tail $dir2]</th><th>Different pixels</th></tr>"
+            puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
+        }
+    }
+    puts $fd "</pre></body></html>"
+
+    close $fd
+    return
+}
+
 # get number of CPUs on the system
 proc _get_nb_cpus {} {
     global tcl_platform env
@@ -1475,3 +1810,177 @@ proc _get_nb_cpus {} {
     # if cannot get good value, return 0 as default
     return 0
 }
+
+# check two files for difference
+proc _diff_files {file1 file2} {
+    set fd1 [open $file1 "r"]
+    set fd2 [open $file2 "r"]
+
+    set differ f
+    while {! $differ} {
+        set nb1 [gets $fd1 line1]
+        set nb2 [gets $fd2 line2]
+        if { $nb1 != $nb2 } { set differ t; break }
+        if { $nb1 < 0 } { break }
+        if { [string compare $line1 $line2] } {
+            set differ t
+        }
+    }
+
+    close $fd1
+    close $fd2
+
+    return $differ
+}
+
+# Check if file is in DOS encoding.
+# This check is done by presence of \r\n combination at the end of the first 
+# line (i.e. prior to any other \n symbol).
+# Note that presence of non-ascii symbols typically used for recognition
+# of binary files is not suitable since some IGES and STEP files contain
+# non-ascii symbols.
+# Special check is added for PNG files which contain \r\n in the beginning.
+proc _check_dos_encoding {file} {
+    set fd [open $file rb]
+    set isdos f
+    if { [gets $fd line] && [regexp {.*\r$} $line] && 
+         ! [regexp {^.PNG} $line] } {
+        set isdos t
+    }
+    close $fd
+    return $isdos
+}
+
+# procedure to recognize format of a data file by its first symbols (for OCCT 
+# BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
+proc _check_file_format {file} {
+    set fd [open $file rb]
+    set line [read $fd 1024]
+    close $fd
+
+    set warn f
+    set ext [file extension $file]
+    set format unknown
+    if { [regexp {^DBRep_DrawableShape} $line] } {
+        set format BREP
+        if { "$ext" != ".brep" && "$ext" != ".rle" && 
+             "$ext" != ".draw" && "$ext" != "" } {
+            set warn t
+        }
+    } elseif { [regexp {^DrawTrSurf_} $line] } {
+        set format DRAW
+        if { "$ext" != ".rle" && 
+             "$ext" != ".draw" && "$ext" != "" } {
+            set warn t
+        }
+    } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
+        set format STEP
+        if { "$ext" != ".step" && "$ext" != ".stp" } {
+            set warn t
+        }
+    } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
+        set format IGES
+        if { "$ext" != ".iges" && "$ext" != ".igs" } {
+            set warn t
+        }
+    } elseif { "$ext" == ".igs" } {
+        set format IGES
+    } elseif { "$ext" == ".stp" } {
+        set format STEP
+    } else {
+        set format [string toupper [string range $ext 1 end]]
+    }
+    
+    if { $warn } {
+        puts "$file: Warning: extension ($ext) does not match format ($format)"
+    }
+
+    return $format
+}
+
+# procedure to load file knowing its format
+proc load_data_file {file format shape} {
+    switch $format {
+    BREP { uplevel restore $file $shape }
+    DRAW { uplevel restore $file $shape }
+    IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
+    STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
+    STL  { pload XSDRAW; uplevel readstl $shape $file }
+    default { error "Cannot read $format file $file" }
+    }
+}
+
+# procedure to get name of temporary directory,
+# ensuring it is existing and writeable 
+proc _get_temp_dir {} {
+    global env tcl_platform
+
+    # check typical environment variables 
+    foreach var {TempDir Temp Tmp} {
+        # check different case
+        foreach name [list [string toupper $var] $var [string tolower $var]] {
+            if { [info exists env($name)] && [file isdirectory $env($name)] &&
+                 [file writable $env($name)] } {
+                return [regsub -all {\\} $env($name) /]
+            }
+        }
+    }
+
+    # check platform-specific locations
+    set fallback tmp
+    if { "$tcl_platform(platform)" == "windows" } {
+        set paths "c:/TEMP c:/TMP /TEMP /TMP"
+        if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
+            set fallback [regsub -all {\\} "$env(HOMEDRIVE)$(HOMEPATH)/tmp" /]
+        }
+    } else {
+        set paths "/tmp /var/tmp /usr/tmp"
+        if { [info exists env(HOME)] } {
+            set fallback "$env(HOME)/tmp"
+        }
+    }
+    foreach dir $paths {
+        if { [file isdirectory $dir] && [file writable $dir] } {
+            return $dir
+        }
+    }
+
+    # fallback case: use subdir /tmp of home or current dir
+    file mkdir $fallback
+    return $fallback
+}
+
+# extract of code from testgrid command used to process jobs running in 
+# parallel until number of jobs in the queue becomes equal or less than 
+# specified value
+proc _testgrid_process_jobs {worker {nb_ok 0}} {
+    # bind local vars to variables of the caller procedure
+    upvar log log
+    upvar logdir logdir
+    upvar job_def job_def
+    upvar nbpooled nbpooled
+    upvar userbreak userbreak
+    upvar refresh refresh
+    upvar refresh_timer refresh_timer
+
+    catch {tpool::resume $worker}
+    while { ! $userbreak && $nbpooled > $nb_ok } {
+        foreach job [tpool::wait $worker [array names job_def]] {
+            eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
+            unset job_def($job)
+            incr nbpooled -1
+        }
+
+        # check for user break
+        if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
+            set userbreak 1
+        }
+
+        # update summary log with requested period
+        if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
+           _log_summarize $logdir $log
+           set refresh_timer [clock seconds]
+        }
+    }
+    catch {tpool::suspend $worker}
+}