0023970: Ignore dot-paths when searching for data files
[occt.git] / src / DrawResources / TestCommands.tcl
index c2bb23a..29a64e4 100644 (file)
@@ -49,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 } {
@@ -65,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)
@@ -295,13 +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"
-    catch {set log "$log\nDRAW build:\n[dversion]\n" }
-    set log "$log\nEnvironment:\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]] {
-       set log "$log$envar=\"$env($envar)\"\n"
+       lappend log "$envar=\"$env($envar)\""
     }
-    set log "$log\n"
+    lappend log ""
 
     set refresh_timer [clock seconds]
     uplevel dchrono _timer reset
@@ -318,6 +320,11 @@ 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]
        }
     }
 
@@ -325,7 +332,7 @@ proc testgrid {args} {
     set userbreak 0
     foreach test_def $tests_list {
         # check for user break
-        if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
+        if { $userbreak || "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
             set userbreak 1
             break
         }
@@ -378,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
@@ -394,26 +405,12 @@ proc testgrid {args} {
 
     # get results of started threads
     if { $parallel > 0 } {
-       catch {tpool::resume $worker}
-       while { ! $userbreak && [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)
-           }
-
-            # 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]
-           }
-       }
+        _testgrid_process_jobs $worker
        # release thread pool
-       tpool::cancel $worker [array names job_def]
+        if { $nbpooled > 0 } {
+           tpool::cancel $worker [array names job_def]
+        }
+        catch {tpool::resume $worker}
        tpool::release $worker
     }
 
@@ -421,7 +418,7 @@ proc testgrid {args} {
     set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
 
     if { $userbreak } {
-        puts "*********** Stopped by user break ***********"
+        _log_and_puts log "*********** Stopped by user break ***********"
         set time "${time} \nNote: the process is not finished, stopped by user break!"
     }
 
@@ -460,7 +457,7 @@ proc testsummarize {dir} {
     }
 
     # get summary statements from all test cases in one log
-    set log ""
+    set log {}
 
     # to avoid huge listing of logs, first find all subdirectories and iterate
     # by them, parsing log files in each subdirectory independently 
@@ -474,7 +471,7 @@ proc testsummarize {dir} {
                     if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } { 
                         puts "Error: $file contains status line for another test case ($line)"
                     }
-                   set log "$log$line\n"
+                   lappend log $line
                    incr nbfound
                }
            }
@@ -572,7 +569,7 @@ 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)"
     }
@@ -762,10 +759,12 @@ proc locate_data_file {filename} {
            while {[llength $dir] != 0} { 
                set name [lindex $dir 0]
                set dir [lrange $dir 1 end]
-               eval lappend dir [glob -nocomplain -directory $name -type d *]
+                # 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 *]
            }
        }
     }
@@ -776,7 +775,7 @@ proc locate_data_file {filename} {
     }
 
     # raise error
-    error [join [list "Error: file $filename could not be found" \
+    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"]
 }
@@ -885,15 +884,12 @@ 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
-           }
        }
     }
 
@@ -903,6 +899,7 @@ proc _run_test {scriptsdir group gridname casefile echo} {
        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] } {
@@ -971,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 {
 
@@ -1010,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
            }
 
@@ -1020,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
        }
 
@@ -1034,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
                    }
                }
@@ -1042,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]
                    }
@@ -1052,7 +1049,7 @@ if [catch {
            }
        }
        if { ! $ismarked } { 
-           set html_log "$html_log\n$line"
+           lappend html_log $line
        }
     }
 
@@ -1095,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
 }
@@ -1117,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 != "" } {
@@ -1175,7 +1169,7 @@ proc _log_html {file log {title {}}} {
     # 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
@@ -1225,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] {
@@ -1291,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
@@ -1305,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"
        }
@@ -1360,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 {
@@ -1402,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
@@ -1434,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
@@ -1519,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] } {
@@ -1536,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
@@ -1747,7 +1748,7 @@ proc _log_html_diff {file log dir1 dir2} {
     # "Executing <filename>..."
     puts $fd "<pre>"
     set logpath [file split [file normalize $file]]
-    foreach line [split $log "\n"] {
+    foreach line $log {
         puts $fd $line
 
         if { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
@@ -1948,3 +1949,38 @@ proc _get_temp_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}
+}