src/DrawResources/TestCommands.tcl

   1 # Copyright (c) 2013-2014 OPEN CASCADE SAS
   2 #
   3 # This file is part of Open CASCADE Technology software library.
   4 #
   5 # This library is free software; you can redistribute it and/or modify it under
   6 # the terms of the GNU Lesser General Public License version 2.1 as published
   7 # by the Free Software Foundation, with special exception defined in the file
   8 # OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
   9 # distribution for complete text of the license and disclaimer of any warranty.
  10 #
  11 # Alternatively, this file may be used under the terms of Open CASCADE
  12 # commercial license or contractual agreement.
  13
  14 ############################################################################
  15 # This file defines scripts for execution of OCCT tests.
  16 # It should be loaded automatically when DRAW is started, and provides
  17 # top-level commands starting with 'test'. Type 'help test' to get their
  18 # synopsys.
  19 # See OCCT Tests User Guide for description of the test system.
  20 #
  21 # Note: procedures with names starting with underscore are for internal use
  22 # inside the test system.
  23 ############################################################################
  24
  25 # Default verbose level for command _run_test
  26 set _tests_verbose 0
  27
  28 # regexp for parsing test case results in summary log
  29 set _test_case_regexp {^CASE\s+([\w.-]+)\s+([\w.-]+)\s+([\w.-]+)\s*:\s*([\w]+)(.*)}
  30
  31 # Basic command to run indicated test case in DRAW
  32 help test {
  33   Run specified test case
  34   Use: test group grid casename [options...]
  35   Allowed options are:
  36   -echo: all commands and results are echoed immediately,
  37          but log is not saved and summary is not produced
  38          It is also possible to use "1" instead of "-echo"
  39          If echo is OFF, log is stored in memory and only summary
  40          is output (the log can be obtained with command "dlog get")
  41   -outfile filename: set log file (should be non-existing),
  42          it is possible to save log file in text file or
  43          in html file(with snapshot), for that "filename"
  44          should have ".html" extension
  45   -overwrite: force writing log in existing file
  46   -beep: play sound signal at the end of the test
  47   -errors: show all lines from the log report that are recognized as errors
  48          This key will be ignored if the "-echo" key is already set.
  49 }
  50 proc test {group grid casename {args {}}} {
  51     # set default values of arguments
  52     set echo 0
  53     set errors 0
  54     set logfile ""
  55     set overwrite 0
  56     set signal 0
  57
  58     # get test case paths (will raise error if input is invalid)
  59     _get_test $group $grid $casename dir gridname casefile
  60
  61     # check arguments
  62     for {set narg 0} {$narg < [llength $args]} {incr narg} {
  63         set arg [lindex $args $narg]
  64         # if echo specified as "-echo", convert it to bool
  65         if { $arg == "-echo" || $arg == "1" } {
  66             set echo t
  67             continue
  68         }
  69
  70         # output log file
  71         if { $arg == "-outfile" } {
  72             incr narg
  73             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
  74                 set logfile [lindex $args $narg]
  75             } else {
  76                 error "Option -outfile requires argument"
  77             }
  78             continue
  79         }
  80
  81         # allow overwrite existing log
  82         if { $arg == "-overwrite" } {
  83             set overwrite 1
  84             continue
  85         }
  86
  87         # sound signal at the end of the test
  88         if { $arg == "-beep" } {
  89             set signal t
  90             continue
  91         }
  92
  93         # if errors specified as "-errors", convert it to bool
  94         if { $arg == "-errors" } {
  95             set errors t
  96             continue
  97         }
  98
  99         # unsupported option
 100         error "Error: unsupported option \"$arg\""
 101     }
 102     # run test
 103     uplevel _run_test $dir $group $gridname $casefile $echo
 104
 105     # check log
 106     if { !$echo } {
 107         _check_log $dir $group $gridname $casename $errors [dlog get] summary html_log
 108
 109         # create log file
 110         if { ! $overwrite && [file isfile $logfile] } {
 111             error "Error: Specified log file \"$logfile\" exists; please remove it before running test or use -overwrite option"
 112         }
 113         if {$logfile != ""} {
 114             if {[file extension $logfile] == ".html"} {
 115                 if {[regexp {vdump ([^\s\n]+)} $html_log dump snapshot]} {
 116                     catch {file copy -force $snapshot [file rootname $logfile][file extension $snapshot]}
 117                 }
 118                 _log_html $logfile $html_log "Test $group $grid $casename"
 119             } else {
 120                 _log_save $logfile "[dlog get]\n$summary" "Test $group $grid $casename"
 121             }
 122         }
 123     }
 124
 125     # play sound signal at the end of test
 126     if {$signal} {
 127         puts "\7\7\7\7"
 128     }
 129     return
 130 }
 131
 132 # Basic command to run indicated test case in DRAW
 133 help testgrid {
 134   Run all tests, or specified group, or one grid
 135   Use: testgrid [groupmask [gridmask [casemask]]] [options...]
 136   Allowed options are:
 137   -exclude N: exclude group, subgroup or single test case from executing, where
 138               N is name of group, subgroup or case. Excluded items should be separated by comma.
 139               Option should be used as the first argument after list of executed groups, grids, and test cases.
 140   -parallel N: run N parallel processes (default is number of CPUs, 0 to disable)
 141   -refresh N: save summary logs every N seconds (default 600, minimal 1, 0 to disable)
 142   -outdir dirname: set log directory (should be empty or non-existing)
 143   -overwrite: force writing logs in existing non-empty directory
 144   -xml filename: write XML report for Jenkins (in JUnit-like format)
 145   -beep: play sound signal at the end of the tests
 146   -regress dirname: re-run only a set of tests that have been detected as regressions on some previous run.
 147   -skipped dirname: re-run only a set of tests that have been skipped on some previous run.
 148                     Here "dirname" is path to directory containing results of previous run.
 149   -skip N: skip first N tests (useful to restart after abort)
 150   Groups, grids, and test cases to be executed can be specified by list of file
 151   masks, separated by spaces or comma; default is all (*).
 152 }
 153 proc testgrid {args} {
 154     global env tcl_platform _tests_verbose
 155
 156     ######################################################
 157     # check arguments
 158     ######################################################
 159
 160     # check that environment variable defining paths to test scripts is defined
 161     if { ! [info exists env(CSF_TestScriptsPath)] ||
 162         [llength $env(CSF_TestScriptsPath)] <= 0 } {
 163         error "Error: Environment variable CSF_TestScriptsPath is not defined"
 164     }
 165
 166     # treat options
 167     set parallel [_get_nb_cpus]
 168     set refresh 60
 169     set logdir ""
 170     set overwrite 0
 171     set xmlfile ""
 172     set signal 0
 173     set exc_group 0
 174     set exc_grid 0
 175     set exc_case 0
 176     set regress 0
 177     set skipped 0
 178     set logdir_regr ""
 179     set logdir_skip ""
 180     set nbskip 0
 181     for {set narg 0} {$narg < [llength $args]} {incr narg} {
 182         set arg [lindex $args $narg]
 183
 184         # parallel execution
 185         if { $arg == "-parallel" } {
 186             incr narg
 187             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 188                 set parallel [expr [lindex $args $narg]]
 189             } else {
 190                 error "Option -parallel requires argument"
 191             }
 192             continue
 193         }
 194
 195         # refresh logs time
 196         if { $arg == "-refresh" } {
 197             incr narg
 198             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 199                 set refresh [expr [lindex $args $narg]]
 200             } else {
 201                 error "Option -refresh requires argument"
 202             }
 203             continue
 204         }
 205
 206         # output directory
 207         if { $arg == "-outdir" } {
 208             incr narg
 209             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 210                 set logdir [lindex $args $narg]
 211             } else {
 212                 error "Option -outdir requires argument"
 213             }
 214             continue
 215         }
 216
 217         # allow overwrite logs
 218         if { $arg == "-overwrite" } {
 219             set overwrite 1
 220             continue
 221         }
 222
 223         # refresh logs time
 224         if { $arg == "-xml" } {
 225             incr narg
 226             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 227                 set xmlfile [lindex $args $narg]
 228             }
 229             if { $xmlfile == "" } {
 230                 set xmlfile TESTS-summary.xml
 231             }
 232             continue
 233         }
 234
 235         # sound signal at the end of the test
 236         if { $arg == "-beep" } {
 237             set signal t
 238             continue
 239         }
 240
 241         # re-run only a set of tests that have been detected as regressions on some previous run
 242         if { $arg == "-regress" || $arg == "-skipped" } {
 243             incr narg
 244             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 245                 if { $arg == "-regress" } {
 246                     set logdir_regr [file normalize [string trim [lindex $args $narg]]]
 247                     set regress 1
 248                 } else {
 249                     set logdir_skip [file normalize [string trim [lindex $args $narg]]]
 250                     set skipped 1
 251                 }
 252             } else {
 253                 error "Option $arg requires argument"
 254             }
 255             continue
 256         }
 257
 258         # skip N first tests
 259         if { $arg == "-skip" } {
 260             incr narg
 261             if { $narg < [llength $args] && [string is integer [lindex $args $narg]] } {
 262                 set nbskip [lindex $args $narg]
 263             } else {
 264                 error "Option -skip requires integer argument"
 265             }
 266             continue
 267         }
 268
 269         # exclude group, subgroup or single test case from executing
 270         if { $arg == "-exclude" } {
 271             incr narg
 272             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 273                 set argts $args
 274                 set idx_begin [string first " -ex" $argts]
 275                 if { ${idx_begin} != "-1" } {
 276                     set argts [string replace $argts 0 $idx_begin]
 277                 }
 278                 set idx_exclude [string first "exclude" $argts]
 279                 if { ${idx_exclude} != "-1" } {
 280                     set argts [string replace $argts 0 $idx_exclude+7]
 281                 }
 282                 set idx [string first " -" $argts]
 283                 if { ${idx} != "-1" } {
 284                     set argts [string replace $argts $idx end]
 285                 }
 286                 set argts [split $argts ,]
 287                 foreach argt $argts {
 288                     if { [llength $argt] == 1 } {
 289                         lappend exclude_group $argt
 290                         set exc_group 1
 291                     } elseif { [llength $argt] == 2 } {
 292                         lappend exclude_grid $argt
 293                         set exc_grid 1
 294                         incr narg
 295                     } elseif { [llength $argt] == 3 } {
 296                         lappend exclude_case $argt
 297                         set exc_case 1
 298                         incr narg
 299                         incr narg
 300                     }
 301                 }
 302             } else {
 303                 error "Option -exclude requires argument"
 304             }
 305             continue
 306         }
 307
 308         # unsupported option
 309         if { [regexp {^-} $arg] } {
 310             error "Error: unsupported option \"$arg\""
 311         }
 312
 313         # treat arguments not recognized as options as group and grid names
 314         if { ! [info exists groupmask] } {
 315             set groupmask [split $arg ,]
 316         } elseif { ! [info exists gridmask] } {
 317             set gridmask [split $arg ,]
 318         } elseif { ! [info exists casemask] } {
 319             set casemask [split $arg ,]
 320         } else {
 321             error "Error: cannot interpret argument $narg ($arg)"
 322         }
 323     }
 324
 325     # check that target log directory is empty or does not exist
 326     set logdir [file normalize [string trim $logdir]]
 327     if { $logdir == "" } {
 328         # if specified logdir is empty string, generate unique name like
 329         # results/<branch>_<timestamp>
 330         set prefix ""
 331         if { ! [catch {exec git branch} gitout] &&
 332              [regexp {[*] ([\w-]+)} $gitout res branch] } {
 333             set prefix "${branch}_"
 334         }
 335         set logdir "results/${prefix}[clock format [clock seconds] -format {%Y-%m-%dT%H%M}]"
 336
 337         set logdir [file normalize $logdir]
 338     }
 339     if { [file isdirectory $logdir] && ! $overwrite && ! [catch {glob -directory $logdir *}] } {
 340         error "Error: Specified log directory \"$logdir\" is not empty; please clean it before running tests"
 341     }
 342     if { [catch {file mkdir $logdir}] || ! [file writable $logdir] } {
 343         error "Error: Cannot create directory \"$logdir\", or it is not writable"
 344     }
 345
 346     # masks for search of test groups, grids, and cases
 347     if { ! [info exists groupmask] } { set groupmask * }
 348     if { ! [info exists gridmask ] } { set gridmask  * }
 349     if { ! [info exists casemask ] } { set casemask  * }
 350
 351     # Find test cases with FAILED and IMPROVEMENT statuses in previous run
 352     # if option "regress" is given
 353     set rerun_group_grid_case {}
 354
 355     if { ${regress} > 0 || ${skipped} > 0 } {
 356         if { "${groupmask}" != "*"} {
 357             lappend rerun_group_grid_case [list $groupmask $gridmask $casemask]
 358         }
 359     } else {
 360         lappend rerun_group_grid_case [list $groupmask $gridmask $casemask]
 361     }
 362
 363     if { ${regress} > 0 } {
 364         if { [file exists ${logdir_regr}/tests.log] } {
 365             set fd [open ${logdir_regr}/tests.log]
 366             while { [gets $fd line] >= 0 } {
 367                 if {[regexp {CASE ([^\s]+) ([^\s]+) ([^\s]+): FAILED} $line dump group grid casename] ||
 368                     [regexp {CASE ([^\s]+) ([^\s]+) ([^\s]+): IMPROVEMENT} $line dump group grid casename]} {
 369                     lappend rerun_group_grid_case [list $group $grid $casename]
 370                 }
 371             }
 372             close $fd
 373         } else {
 374             error "Error: file ${logdir_regr}/tests.log is not found, check your input arguments!"
 375         }
 376     }
 377     if { ${skipped} > 0 } {
 378         if { [file exists ${logdir_skip}/tests.log] } {
 379             set fd [open ${logdir_skip}/tests.log]
 380             while { [gets $fd line] >= 0 } {
 381                 if {[regexp {CASE ([^\s]+) ([^\s]+) ([^\s]+): SKIPPED} $line dump group grid casename] } {
 382                     lappend rerun_group_grid_case [list $group $grid $casename]
 383                 }
 384             }
 385             close $fd
 386         } else {
 387             error "Error: file ${logdir_skip}/tests.log is not found, check your input arguments!"
 388         }
 389     }
 390
 391     ######################################################
 392     # prepare list of tests to be performed
 393     ######################################################
 394
 395     # list of tests, each defined by a list of:
 396     # test scripts directory
 397     # group (subfolder) name
 398     # grid (subfolder) name
 399     # test case name
 400     # path to test case file
 401     set tests_list {}
 402
 403     foreach group_grid_case ${rerun_group_grid_case} {
 404         set groupmask [lindex $group_grid_case 0]
 405         set gridmask  [lindex $group_grid_case 1]
 406         set casemask  [lindex $group_grid_case 2]
 407
 408         # iterate by all script paths
 409         foreach dir [lsort -unique [_split_path $env(CSF_TestScriptsPath)]] {
 410             # protection against empty paths
 411             set dir [string trim $dir]
 412             if { $dir == "" } { continue }
 413
 414             if { $_tests_verbose > 0 } { _log_and_puts log "Examining tests directory $dir" }
 415
 416             # check that directory exists
 417             if { ! [file isdirectory $dir] } {
 418                 _log_and_puts log "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
 419                 continue
 420             }
 421
 422             # search all directories in the current dir with specified mask
 423             if [catch {glob -directory $dir -tail -types d {*}$groupmask} groups] { continue }
 424
 425             # exclude selected groups from all groups
 426             if { ${exc_group} > 0 } {
 427                 foreach exclude_group_element ${exclude_group} {
 428                     set idx [lsearch $groups "${exclude_group_element}"]
 429                     if { ${idx} != "-1" } {
 430                         set groups [lreplace $groups $idx $idx]
 431                     } else {
 432                         continue
 433                     }
 434                 }
 435             }
 436
 437             # iterate by groups
 438             if { $_tests_verbose > 0 } { _log_and_puts log "Groups to be executed: $groups" }
 439             foreach group [lsort -dictionary $groups] {
 440                 if { $_tests_verbose > 0 } { _log_and_puts log "Examining group directory $group" }
 441
 442                 # file grids.list must exist: it defines sequence of grids in the group
 443                 if { ! [file exists $dir/$group/grids.list] } {
 444                     _log_and_puts log "Warning: directory $dir/$group does not contain file grids.list, skipped"
 445                     continue
 446                 }
 447
 448                 # read grids.list file and make a list of grids to be executed
 449                 set gridlist {}
 450                 set fd [open $dir/$group/grids.list]
 451                 set nline 0
 452                 while { [gets $fd line] >= 0 } {
 453                     incr nline
 454
 455                     # skip comments and empty lines
 456                     if { [regexp "\[ \t\]*\#.*" $line] } { continue }
 457                     if { [string trim $line] == "" } { continue }
 458
 459                     # get grid id and name
 460                     if { ! [regexp "^\(\[0-9\]+\)\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridid grid] } {
 461                         _log_and_puts log "Warning: cannot recognize line $nline in file $dir/$group/grids.list as \"gridid gridname\"; ignored"
 462                         continue
 463                     }
 464
 465                     # check that grid fits into the specified mask
 466                     foreach mask $gridmask {
 467                         if { $mask == $gridid || [string match $mask $grid] } {
 468                             lappend gridlist $grid
 469                         }
 470                     }
 471                 }
 472                 close $fd
 473
 474                 # exclude selected grids from all grids
 475                 if { ${exc_grid} > 0 } {
 476                     foreach exclude_grid_element ${exclude_grid} {
 477                         set exclude_elem [lindex $exclude_grid_element end]
 478                         set idx [lsearch $gridlist "${exclude_elem}"]
 479                         if { ${idx} != "-1" } {
 480                             set gridlist [lreplace $gridlist $idx $idx]
 481                         } else {
 482                             continue
 483                         }
 484                     }
 485                 }
 486
 487                 # iterate by all grids
 488                 foreach grid $gridlist {
 489
 490                     # check if this grid is aliased to another one
 491                     set griddir $dir/$group/$grid
 492                     if { [file exists $griddir/cases.list] } {
 493                         set fd [open $griddir/cases.list]
 494                         if { [gets $fd line] >= 0 } {
 495                             set griddir [file normalize $dir/$group/$grid/[string trim $line]]
 496                         }
 497                         close $fd
 498                     }
 499
 500                     # check if grid directory actually exists
 501                     if { ! [file isdirectory $griddir] } {
 502                         _log_and_puts log "Error: tests directory for grid $grid ($griddir) is missing; skipped"
 503                         continue
 504                     }
 505
 506                     # create directory for logging test results
 507                     if { $logdir != "" } { file mkdir $logdir/$group/$grid }
 508
 509                     # iterate by all tests in the grid directory
 510                     if { [catch {glob -directory $griddir -type f {*}$casemask} testfiles] } { continue }
 511
 512                     # exclude selected test cases from all testfiles
 513                     if { ${exc_case} > 0 } {
 514                         foreach exclude_case_element ${exclude_case} {
 515                             set exclude_casegroup_elem [lindex $exclude_case_element end-2]
 516                             set exclude_casegrid_elem [lindex $exclude_case_element end-1]
 517                             set exclude_elem [lindex $exclude_case_element end]
 518                             if { ${exclude_casegrid_elem} == "${grid}" } {
 519                                 set idx [lsearch $testfiles "${dir}/${exclude_casegroup_elem}/${exclude_casegrid_elem}/${exclude_elem}"]
 520                                 if { ${idx} != "-1" } {
 521                                     set testfiles [lreplace $testfiles $idx $idx]
 522                                 } else {
 523                                     continue
 524                                 }
 525                             }
 526                         }
 527                     }
 528
 529                     foreach casefile [lsort -dictionary $testfiles] {
 530                         # filter out files with reserved names
 531                         set casename [file tail $casefile]
 532                         if { $casename == "begin" || $casename == "end" ||
 533                              $casename == "parse.rules" } {
 534                             continue
 535                         }
 536
 537                         if { $nbskip > 0 } {
 538                             incr nbskip -1
 539                         } else {
 540                             lappend tests_list [list $dir $group $grid $casename $casefile]
 541                         }
 542                     }
 543                 }
 544             }
 545         }
 546     }
 547     if { [llength $tests_list] < 1 } {
 548         error "Error: no tests are found, check your input arguments and variable CSF_TestScriptsPath!"
 549     } else {
 550         puts "Running tests (total [llength $tests_list] test cases)..."
 551     }
 552
 553     ######################################################
 554     # run tests
 555     ######################################################
 556
 557     # log command arguments and environment
 558     lappend log "Command: testgrid $args"
 559     lappend log "Host: [info hostname]"
 560     lappend log "Started on: [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}]"
 561     catch {lappend log "DRAW build:\n[dversion]" }
 562     lappend log "Environment:"
 563     foreach envar [lsort [array names env]] {
 564         lappend log "$envar=\"$env($envar)\""
 565     }
 566     lappend log ""
 567
 568     set refresh_timer [clock seconds]
 569     uplevel dchrono _timer reset
 570     uplevel dchrono _timer start
 571
 572     # if parallel execution is requested, allocate thread pool
 573     if { $parallel > 0 } {
 574         if { ! [info exists tcl_platform(threaded)] || [catch {package require Thread}] } {
 575             _log_and_puts log "Warning: Tcl package Thread is not available, running in sequential mode"
 576             set parallel 0
 577         } else {
 578             set worker [tpool::create -minworkers $parallel -maxworkers $parallel]
 579             # suspend the pool until all jobs are posted, to prevent blocking of the process
 580             # of starting / processing jobs by running threads
 581             catch {tpool::suspend $worker}
 582             if { $_tests_verbose > 0 } { _log_and_puts log "Executing tests in (up to) $parallel threads" }
 583             # limit number of jobs in the queue by reasonable value
 584             # to prevent slowdown due to unnecessary queue processing
 585             set nbpooled 0
 586             set nbpooled_max [expr 10 * $parallel]
 587             set nbpooled_ok  [expr  5 * $parallel]
 588         }
 589     }
 590
 591     # start test cases
 592     set userbreak 0
 593     foreach test_def $tests_list {
 594         # check for user break
 595         if { $userbreak || "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
 596             set userbreak 1
 597             break
 598         }
 599
 600         set dir       [lindex $test_def 0]
 601         set group     [lindex $test_def 1]
 602         set grid      [lindex $test_def 2]
 603         set casename  [lindex $test_def 3]
 604         set casefile  [lindex $test_def 4]
 605
 606         # command to set tests for generation of image in results directory
 607         set imgdir_cmd ""
 608         if { $logdir != "" } { set imgdir_cmd "set imagedir $logdir/$group/$grid" }
 609
 610         # prepare command file for running test case in separate instance of DRAW
 611         set file_cmd "$logdir/$group/$grid/${casename}.tcl"
 612         set fd_cmd [open $file_cmd w]
 613
 614         # UTF-8 encoding is used by default on Linux everywhere, and "unicode" is set
 615         # by default as encoding of stdin and stdout on Windows in interactive mode;
 616         # however in batch mode on Windows default encoding is set to system one (e.g. 1252),
 617         # so we need to set UTF-8 encoding explicitly to have Unicode symbols transmitted
 618         # correctly between calling and caller processes
 619         if { "$tcl_platform(platform)" == "windows" } {
 620             puts $fd_cmd "fconfigure stdout -encoding utf-8"
 621             puts $fd_cmd "fconfigure stdin -encoding utf-8"
 622         }
 623
 624         # commands to set up and run test
 625         puts $fd_cmd "$imgdir_cmd"
 626         puts $fd_cmd "set test_image $casename"
 627         puts $fd_cmd "_run_test $dir $group $grid $casefile t"
 628
 629         # use dlog command to obtain complete output of the test when it is absent (i.e. since OCCT 6.6.0)
 630         # note: this is not needed if echo is set to 1 in call to _run_test above
 631         if { ! [catch {dlog get}] } {
 632             puts $fd_cmd "puts \[dlog get\]"
 633         } else {
 634             # else try to use old-style QA_ variables to get more output...
 635             set env(QA_DUMP) 1
 636             set env(QA_DUP) 1
 637             set env(QA_print_command) 1
 638         }
 639
 640         # final 'exit' is needed when running on Linux under VirtualGl
 641         puts $fd_cmd "exit"
 642         close $fd_cmd
 643
 644         # command to run DRAW with a command file;
 645         # note that empty string is passed as standard input to avoid possible
 646         # hang-ups due to waiting for stdin of the launching process
 647         set command "exec <<{} DRAWEXE -f $file_cmd"
 648
 649         # alternative method to run without temporary file; disabled as it needs too many backslashes
 650         # else {
 651         # set command "exec <<\"\" DRAWEXE -c $imgdir_cmd\\\; set test_image $casename\\\; \
 652         # _run_test $dir $group $grid $casefile\\\; \
 653         # puts \\\[dlog get\\\]\\\; exit"
 654         # }
 655
 656         # run test case, either in parallel or sequentially
 657         if { $parallel > 0 } {
 658             # parallel execution
 659             set job [tpool::post -nowait $worker "catch \"$command\" output; return \$output"]
 660             set job_def($job) [list $logdir $dir $group $grid $casename]
 661             incr nbpooled
 662             if { $nbpooled > $nbpooled_max } {
 663                 _testgrid_process_jobs $worker $nbpooled_ok
 664             }
 665         } else {
 666             # sequential execution
 667             catch {eval $command} output
 668             _log_test_case $output $logdir $dir $group $grid $casename log
 669
 670             # update summary log with requested period
 671             if { $logdir != "" && $refresh > 0 && [expr [clock seconds] - $refresh_timer > $refresh] } {
 672                 # update and dump summary
 673                 _log_summarize $logdir $log
 674                 set refresh_timer [clock seconds]
 675             }
 676         }
 677     }
 678
 679     # get results of started threads
 680     if { $parallel > 0 } {
 681         _testgrid_process_jobs $worker
 682         # release thread pool
 683         if { $nbpooled > 0 } {
 684             tpool::cancel $worker [array names job_def]
 685         }
 686         catch {tpool::resume $worker}
 687         tpool::release $worker
 688     }
 689
 690     uplevel dchrono _timer stop
 691     set time [lindex [split [uplevel dchrono _timer show] "\n"] 0]
 692
 693     if { $userbreak } {
 694         _log_and_puts log "*********** Stopped by user break ***********"
 695         set time "${time} \nNote: the process is not finished, stopped by user break!"
 696     }
 697
 698     ######################################################
 699     # output summary logs and exit
 700     ######################################################
 701
 702     _log_summarize $logdir $log $time
 703     if { $logdir != "" } {
 704         puts "Detailed logs are saved in $logdir"
 705     }
 706     if { $logdir != "" && $xmlfile != "" } {
 707         # XML output file is assumed relative to log dir unless it is absolute
 708         if { [ file pathtype $xmlfile] == "relative" } {
 709             set xmlfile [file normalize $logdir/$xmlfile]
 710         }
 711         _log_xml_summary $logdir $xmlfile $log 0
 712         puts "XML summary is saved to $xmlfile"
 713     }
 714     # play sound signal at the end of test
 715     if {$signal} {
 716         puts "\7\7\7\7"
 717     }
 718     return
 719 }
 720
 721 # Procedure to regenerate summary log from logs of test cases
 722 help testsummarize {
 723   Regenerate summary log in the test directory from logs of test cases.
 724   This can be necessary if test grids are executed separately (e.g. on
 725   different stations) or some grids have been re-executed.
 726   Use: testsummarize dir
 727 }
 728 proc testsummarize {dir} {
 729     global _test_case_regexp
 730
 731     if { ! [file isdirectory $dir] } {
 732         error "Error: \"$dir\" is not a directory"
 733     }
 734
 735     # get summary statements from all test cases in one log
 736     set log {}
 737
 738     # to avoid huge listing of logs, first find all subdirectories and iterate
 739     # by them, parsing log files in each subdirectory independently
 740     foreach grid [glob -directory $dir -types d -tails */*] {
 741         foreach caselog [glob -nocomplain -directory [file join $dir $grid] -types f -tails *.log] {
 742             set file [file join $dir $grid $caselog]
 743             set nbfound 0
 744             set fd [open $file r]
 745             while { [gets $fd line] >= 0 } {
 746                 if { [regexp $_test_case_regexp $line res grp grd cas status message] } {
 747                     if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } {
 748                         puts "Error: $file contains status line for another test case ($line)"
 749                     }
 750                     lappend log $line
 751                     incr nbfound
 752                 }
 753             }
 754             close $fd
 755
 756             if { $nbfound != 1 } {
 757                 puts "Error: $file contains $nbfound status lines, expected 1"
 758             }
 759         }
 760     }
 761
 762     _log_summarize $dir $log "Summary regenerated from logs at [clock format [clock seconds]]"
 763     return
 764 }
 765
 766 # Procedure to compare results of two runs of test cases
 767 help testdiff {
 768   Compare results of two executions of tests (CPU times, ...)
 769   Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
 770   Where dir1 and dir2 are directories containing logs of two test runs.
 771   dir1 (A) should point to NEW tests results to be verified and dir2 (B) to REFERENCE results.
 772   Allowed options are:
 773   -image [filename]: compare only images and save its in specified file (default
 774                    name is <dir1>/diffimage-<dir2>.log)
 775   -cpu [filename]: compare only CPU and save it in specified file (default
 776                    name is <dir1>/diffcpu-<dir2>.log)
 777   -memory [filename]: compare only memory and save it in specified file (default
 778                    name is <dir1>/diffmemory-<dir2>.log)
 779   -save filename: save resulting log in specified file (default name is
 780                   <dir1>/diff-<dir2>.log); HTML log is saved with same name
 781                   and extension .html
 782   -status {same|ok|all}: filter cases for comparing by their status:
 783           same - only cases with same status are compared (default)
 784           ok   - only cases with OK status in both logs are compared
 785           all  - results are compared regardless of status
 786   -verbose level:
 787           1 - output only differences
 788           2 - output also list of logs and directories present in one of dirs only
 789           3 - (default) output also progress messages
 790   -highlight_percent value: highlight considerable (>value in %) deviations
 791                             of CPU and memory (default value is 5%)
 792 }
 793 proc testdiff {dir1 dir2 args} {
 794     if { "$dir1" == "$dir2" } {
 795         error "Input directories are the same"
 796     }
 797
 798     ######################################################
 799     # check arguments
 800     ######################################################
 801
 802     # treat options
 803     set logfile [file join $dir1 "diff-[file tail $dir2].log"]
 804     set logfile_image ""
 805     set logfile_cpu ""
 806     set logfile_memory ""
 807     set image false
 808     set cpu false
 809     set memory false
 810     set basename ""
 811     set save false
 812     set status "same"
 813     set verbose 3
 814     set highlight_percent 5
 815     for {set narg 0} {$narg < [llength $args]} {incr narg} {
 816         set arg [lindex $args $narg]
 817         # log file name
 818         if { $arg == "-save" } {
 819             incr narg
 820             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 821                 set logfile [lindex $args $narg]
 822             } else {
 823                 error "Error: Option -save must be followed by log file name"
 824             }
 825             set save true
 826             continue
 827         }
 828
 829         # image compared log
 830         if { $arg == "-image" } {
 831             incr narg
 832             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 833                 set logfile_image [lindex $args $narg]
 834             } else {
 835                 set logfile_image [file join $dir1 "diffimage-[file tail $dir2].log"]
 836                 incr narg -1
 837             }
 838             set image true
 839             continue
 840         }
 841
 842         # CPU compared log
 843         if { $arg == "-cpu" } {
 844             incr narg
 845             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 846                 set logfile_cpu [lindex $args $narg]
 847             } else {
 848                 set logfile_cpu [file join $dir1 "diffcpu-[file tail $dir2].log"]
 849                 incr narg -1
 850             }
 851             set cpu true
 852             continue
 853         }
 854
 855         # memory compared log
 856         if { $arg == "-memory" } {
 857             incr narg
 858             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 859                 set logfile_memory [lindex $args $narg]
 860             } else {
 861                 set logfile_memory [file join $dir1 "diffmemory-[file tail $dir2].log"]
 862                 incr narg -1
 863             }
 864             set memory true
 865             continue
 866         }
 867
 868         # status filter
 869         if { $arg == "-status" } {
 870             incr narg
 871             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 872                 set status [lindex $args $narg]
 873             } else {
 874                 set status ""
 875             }
 876             if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
 877                 error "Error: Option -status must be followed by one of \"same\", \"all\", or \"ok\""
 878             }
 879             continue
 880         }
 881
 882         # verbose level
 883         if { $arg == "-verbose" } {
 884             incr narg
 885             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 886                 set verbose [expr [lindex $args $narg]]
 887             } else {
 888                 error "Error: Option -verbose must be followed by integer verbose level"
 889             }
 890             continue
 891         }
 892
 893         # highlight_percent
 894         if { $arg == "-highlight_percent" } {
 895             incr narg
 896             if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
 897                 set highlight_percent [expr [lindex $args $narg]]
 898             } else {
 899                 error "Error: Option -highlight_percent must be followed by integer value"
 900             }
 901             continue
 902         }
 903
 904         if { [regexp {^-} $arg] } {
 905             error "Error: unsupported option \"$arg\""
 906         }
 907
 908         # non-option arguments form a subdirectory path
 909         set basename [file join $basename $arg]
 910     }
 911
 912     if {$image != false || $cpu != false || $memory != false} {
 913         if {$save != false} {
 914             error "Error: Option -save can not be used with image/cpu/memory options"
 915         }
 916     }
 917
 918     # run diff procedure (recursive)
 919     _test_diff $dir1 $dir2 $basename $image $cpu $memory $status $verbose log log_image log_cpu log_memory
 920
 921     # save result to log file
 922     if {$image == false && $cpu == false && $memory == false} {
 923         if { "$logfile" != "" } {
 924             _log_save $logfile [join $log "\n"]
 925             _log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2 ${highlight_percent}
 926             puts "Log is saved to $logfile (and .html)"
 927         }
 928     } else {
 929         foreach mode {image cpu memory} {
 930             if {"[set logfile_${mode}]" != ""} {
 931                 _log_save "[set logfile_${mode}]" [join "[set log_${mode}]" "\n"]
 932                 _log_html_diff "[file rootname [set logfile_${mode}]].html" "[set log_${mode}]" $dir1 $dir2 ${highlight_percent}
 933                 puts "Log (${mode}) is saved to [set logfile_${mode}] (and .html)"
 934             }
 935         }
 936     }
 937     return
 938 }
 939
 940 # Procedure to check data file before adding it to repository
 941 help testfile {
 942   Checks specified data files for putting them into the test data files repository.
 943
 944   Use: testfile filelist
 945
 946   Will report if:
 947   - data file (non-binary) is in DOS encoding (CR/LF)
 948   - same data file (with same or another name) already exists in the repository
 949   - another file with the same name already exists
 950   Note that names are considered to be case-insensitive (for compatibility
 951   with Windows).
 952
 953   Unless the file is already in the repository, tries to load it, reports
 954   the recognized file format, file size, number of faces and edges in the
 955   loaded shape (if any), information contained its triangulation, and makes
 956   snapshot (in the temporary directory).
 957
 958   Finally it advises whether the file should be put to public section of the
 959   repository.
 960
 961   Use: testfile -check
 962
 963   If "-check" is given as an argument, then procedure will check files already
 964   located in the repository (for possible duplicates and for DOS encoding).
 965 }
 966 proc testfile {filelist} {
 967     global env
 968
 969     # check that CSF_TestDataPath is defined
 970     if { ! [info exists env(CSF_TestDataPath)] } {
 971         error "Environment variable CSF_TestDataPath must be defined!"
 972     }
 973
 974     set checkrepo f
 975     if { "$filelist" == "-check" } { set checkrepo t }
 976
 977     # build registry of existing data files (name -> path) and (size -> path)
 978     puts "Collecting info on test data files repository..."
 979     foreach dir [_split_path $env(CSF_TestDataPath)] {
 980         while {[llength $dir] != 0} {
 981             set curr [lindex $dir 0]
 982             set dir [lrange $dir 1 end]
 983             eval lappend dir [glob -nocomplain -directory $curr -type d *]
 984             foreach file [glob -nocomplain -directory $curr -type f *] {
 985                 set name [file tail $file]
 986                 set name_lower [string tolower $name]
 987                 set size [file size $file]
 988
 989                 # check that the file is not in DOS encoding
 990                 if { $checkrepo } {
 991                     if { [_check_dos_encoding $file] } {
 992                         puts "Warning: file $file is in DOS encoding; was this intended?"
 993                     }
 994                     _check_file_format $file
 995
 996                     # check if file with the same name is present twice or more
 997                     if { [info exists names($name_lower)] } {
 998                         puts "Error: more than one file with name $name is present in the repository:"
 999                         if { [_diff_files $file $names($name_lower)] } {
1000                             puts "(files are different by content)"
1001                         } else {
1002                             puts "(files are same by content)"
1003                         }
1004                         puts "--> $file"
1005                         puts "--> $names($name_lower)"
1006                         continue
1007                     }
1008
1009                     # check if file with the same content exists
1010                     if { [info exists sizes($size)] } {
1011                         foreach other $sizes($size) {
1012                             if { ! [_diff_files $file $other] } {
1013                                 puts "Warning: two files with the same content found:"
1014                                 puts "--> $file"
1015                                 puts "--> $other"
1016                             }
1017                         }
1018                     }
1019                 }
1020
1021                 # add the file to the registry
1022                 lappend names($name_lower) $file
1023                 lappend sizes($size) $file
1024             }
1025         }
1026     }
1027     if { $checkrepo || [llength $filelist] <= 0 } { return }
1028
1029     # check the new files
1030     set has_images f
1031     puts "Checking new file(s)..."
1032     foreach file $filelist {
1033         set name [file tail $file]
1034         set name_lower [string tolower $name]
1035         set found f
1036
1037         # check for presence of the file with same name
1038         if { [info exists names($name_lower)] } {
1039             set found f
1040             foreach other $names($name_lower) {
1041                 # avoid comparing the file with itself
1042                 if { [file normalize $file] == [file normalize $other] } {
1043                     continue
1044                 }
1045                 # compare content
1046                 if { [_diff_files $file $other] } {
1047                     puts "\n* $file: error\n  name is already used by existing file\n  --> $other"
1048                 } else {
1049                     puts "\n* $file: already present \n  --> $other"
1050                 }
1051                 set found t
1052                 break
1053             }
1054             if { $found } { continue }
1055         }
1056
1057         # get size of the file; if it is in DOS encoding and less than 1 MB,
1058         # estimate also its size in UNIX encoding to be able to find same
1059         # file if already present but in UNIX encoding
1060         set sizeact [file size $file]
1061         set sizeunx ""
1062         set isdos [_check_dos_encoding $file]
1063         if { $isdos && $sizeact < 10000000 } {
1064             set fd [open $file r]
1065             fconfigure $fd -translation crlf
1066             set sizeunx [string length [read $fd]]
1067             close $fd
1068         }
1069
1070         # check if file with the same content exists
1071         foreach size "$sizeact $sizeunx" {
1072           if { [info exists sizes($size)] } {
1073             foreach other $sizes($size) {
1074                 # avoid comparing the file with itself
1075                 if { [file normalize $file] == [file normalize $other] } {
1076                     continue
1077                 }
1078                 # compare content
1079                 if { ! [_diff_files $file $other] } {
1080                     puts "\n* $file: duplicate \n  already present under name [file tail $other]\n  --> $other"
1081                     set found t
1082                     break
1083                 }
1084             }
1085             if { $found } { break }
1086           }
1087         }
1088         if { $found } { continue }
1089
1090         # file is not present yet, so to be analyzed
1091         puts "\n* $file: new file"
1092
1093         # add the file to the registry as if it were added to the repository,
1094         # to report possible duplicates among the currently processed files
1095         lappend names($name_lower) $file
1096         if { "$sizeunx" != "" } {
1097             lappend sizes($sizeunx) $file
1098         } else {
1099             lappend sizes($sizeact) $file
1100         }
1101
1102         # first of all, complain if it is in DOS encoding
1103         if { $isdos } {
1104             puts "  Warning: DOS encoding detected, consider converting to"
1105             puts "           UNIX unless DOS line ends are needed for the test"
1106         }
1107
1108         # try to read the file
1109         set format [_check_file_format $file]
1110         if { [catch {uplevel load_data_file $file $format a}] } {
1111             puts "  Warning: Cannot read as $format file"
1112             continue
1113         }
1114
1115         # warn if shape contains triangulation
1116         pload MODELING
1117         if { "$format" != "STL" &&
1118              [regexp {contains\s+([0-9]+)\s+triangles} [uplevel trinfo a] res nbtriangles] &&
1119              $nbtriangles != 0 } {
1120             puts "  Warning: shape contains triangulation ($nbtriangles triangles),"
1121             puts "           consider removing them unless they are needed for the test!"
1122         }
1123
1124         # get number of faces and edges
1125         set edges 0
1126         set faces 0
1127         set nbs [uplevel nbshapes a]
1128         regexp {EDGE[ \t:]*([0-9]+)} $nbs res edges
1129         regexp {FACE[ \t:]*([0-9]+)} $nbs res faces
1130
1131         # classify; first check file size and number of faces and edges
1132         if { $size < 95000 && $faces < 20 && $edges < 100 } {
1133             set dir public
1134         } else {
1135             set dir private
1136         }
1137
1138         # add stats
1139         puts "  $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
1140
1141         set tmpdir [_get_temp_dir]
1142         file mkdir $tmpdir/$dir
1143
1144         # make snapshot
1145         pload AISV
1146         uplevel vdisplay a
1147         uplevel vsetdispmode 1
1148         uplevel vfit
1149         uplevel vzfit
1150         uplevel vdump $tmpdir/$dir/[file rootname [file tail $file]].png
1151         set has_images t
1152     }
1153     if { $has_images } {
1154         puts "Snapshots are saved in subdirectory [_get_temp_dir]"
1155     }
1156 }
1157
1158 # Procedure to locate data file for test given its name.
1159 # The search is performed assuming that the function is called
1160 # from the test case script; the search order is:
1161 # - subdirectory "data" of the test script (grid) folder
1162 # - subdirectories in environment variable CSF_TestDataPath
1163 # - subdirectory set by datadir command
1164 # If file is not found, raises Tcl error.
1165 proc locate_data_file {filename} {
1166     global env groupname gridname casename
1167
1168     # check if the file is located in the subdirectory data of the script dir
1169     set scriptfile [info script]
1170     if { "$scriptfile" != "" } {
1171         set path [file join [file dirname "$scriptfile"] data "$filename"]
1172         if { [file exists "$path"] } {
1173             return [file normalize "$path"]
1174         }
1175     }
1176
1177     # check sub-directories in paths indicated by CSF_TestDataPath
1178     if { [info exists env(CSF_TestDataPath)] } {
1179         foreach dir [_split_path $env(CSF_TestDataPath)] {
1180             set dir [list "$dir"]
1181             while {[llength "$dir"] != 0} {
1182                 set name [lindex "$dir" 0]
1183                 set dir  [lrange "$dir" 1 end]
1184
1185                 # skip directories starting with dot
1186                 set aTail [file tail "$name"]
1187                 if { [regexp {^[.]} "$aTail"] } { continue }
1188                 if { [file exists "$name/$filename"] } {
1189                     return [file normalize "$name/$filename"]
1190                 }
1191                 eval lappend dir [glob -nocomplain -directory "$name" -type d *]
1192             }
1193         }
1194     }
1195
1196     # check current datadir
1197     if { [file exists "[uplevel datadir]/$filename"] } {
1198         return [file normalize "[uplevel datadir]/$filename"]
1199     }
1200
1201     # raise error
1202     error [join [list "File $filename could not be found" \
1203                       "(should be in paths indicated by CSF_TestDataPath environment variable, " \
1204                       "or in subfolder data in the script directory)"] "\n"]
1205 }
1206
1207 # Internal procedure to find test case indicated by group, grid, and test case names;
1208 # returns:
1209 # - dir: path to the base directory of the tests group
1210 # - gridname: actual name of the grid
1211 # - casefile: path to the test case script
1212 # if no such test is found, raises error with appropriate message
1213 proc _get_test {group grid casename _dir _gridname _casefile} {
1214     upvar $_dir dir
1215     upvar $_gridname gridname
1216     upvar $_casefile casefile
1217
1218     global env
1219
1220     # check that environment variable defining paths to test scripts is defined
1221     if { ! [info exists env(CSF_TestScriptsPath)] ||
1222          [llength $env(CSF_TestScriptsPath)] <= 0 } {
1223         error "Error: Environment variable CSF_TestScriptsPath is not defined"
1224     }
1225
1226     # iterate by all script paths
1227     foreach dir [_split_path $env(CSF_TestScriptsPath)] {
1228         # protection against empty paths
1229         set dir [string trim $dir]
1230         if { $dir == "" } { continue }
1231
1232         # check that directory exists
1233         if { ! [file isdirectory $dir] } {
1234             puts "Warning: directory $dir listed in CSF_TestScriptsPath does not exist, skipped"
1235             continue
1236         }
1237
1238         # check if test group with given name exists in this dir
1239         # if not, continue to the next test dir
1240         if { ! [file isdirectory $dir/$group] } { continue }
1241
1242         # check that grid with given name (possibly alias) exists; stop otherwise
1243         set gridname $grid
1244         if { ! [file isdirectory $dir/$group/$gridname] } {
1245             # check if grid is named by alias rather than by actual name
1246             if { [file exists $dir/$group/grids.list] } {
1247                 set fd [open $dir/$group/grids.list]
1248                 while { [gets $fd line] >= 0 } {
1249                     if { [regexp "\[ \t\]*\#.*" $line] } { continue }
1250                     if { [regexp "^$grid\[ \t\]*\(\[A-Za-z0-9_.-\]+\)\$" $line res gridname] } {
1251                         break
1252                     }
1253                 }
1254                 close $fd
1255             }
1256         }
1257         if { ! [file isdirectory $dir/$group/$gridname] } { continue }
1258
1259         # get actual file name of the script; stop if it cannot be found
1260         set casefile $dir/$group/$gridname/$casename
1261         if { ! [file exists $casefile] } {
1262             # check if this grid is aliased to another one
1263             if { [file exists $dir/$group/$gridname/cases.list] } {
1264                 set fd [open $dir/$group/$gridname/cases.list]
1265                 if { [gets $fd line] >= 0 } {
1266                     set casefile [file normalize $dir/$group/$gridname/[string trim $line]/$casename]
1267                 }
1268                 close $fd
1269             }
1270         }
1271         if { [file exists $casefile] } {
1272             # normal return
1273             return
1274         }
1275     }
1276
1277     # coming here means specified test is not found; report error
1278     error [join [list "Error: test case $group / $grid / $casename is not found in paths listed in variable" \
1279                       "CSF_TestScriptsPath (current value is \"$env(CSF_TestScriptsPath)\")"] "\n"]
1280 }
1281
1282 # Internal procedure to run test case indicated by base directory,
1283 # grid and grid names, and test case file path.
1284 # The log can be obtained by command "dlog get".
1285 proc _run_test {scriptsdir group gridname casefile echo} {
1286     global env
1287
1288     # start timer
1289     uplevel dchrono _timer reset
1290     uplevel dchrono _timer start
1291     catch {uplevel meminfo h} membase
1292
1293     # enable commands logging; switch to old-style mode if dlog command is not present
1294     set dlog_exists 1
1295     if { [catch {dlog reset}] } {
1296         set dlog_exists 0
1297     } elseif { $echo } {
1298         decho on
1299     } else {
1300         dlog reset
1301         dlog on
1302         rename puts puts-saved
1303         proc puts args {
1304             global _tests_verbose
1305
1306             # log only output to stdout and stderr, not to file!
1307             if {[llength $args] > 1} {
1308                 set optarg [lindex $args end-1]
1309                 if { $optarg == "stdout" || $optarg == "stderr" || $optarg == "-newline" } {
1310                     dlog add [lindex $args end]
1311                 } else {
1312                     eval puts-saved $args
1313                 }
1314             } else {
1315                 dlog add [lindex $args end]
1316             }
1317         }
1318     }
1319
1320     # evaluate test case
1321     set tmp_imagedir 0
1322     set anExcep ""
1323     if [catch {
1324         # set variables identifying test case
1325         uplevel set casename [file tail $casefile]
1326         uplevel set groupname $group
1327         uplevel set gridname $gridname
1328         uplevel set dirname  $scriptsdir
1329
1330         # set path for saving of log and images (if not yet set) to temp dir
1331         if { ! [uplevel info exists imagedir] } {
1332             uplevel set test_image \$casename
1333
1334             # create subdirectory in temp named after group and grid with timestamp
1335             set rootlogdir [_get_temp_dir]
1336
1337             set imagedir "${group}-${gridname}-${::casename}-[clock format [clock seconds] -format {%Y-%m-%dT%Hh%Mm%Ss}]"
1338             set imagedir [file normalize ${rootlogdir}/$imagedir]
1339
1340             if { [catch {file mkdir $imagedir}] || ! [file writable $imagedir] ||
1341                  ! [catch {glob -directory $imagedir *}] } {
1342                  # puts "Warning: Cannot create directory \"$imagedir\", or it is not empty; \"${rootlogdir}\" is used"
1343                 set imagedir $rootlogdir
1344             }
1345
1346             uplevel set imagedir \"$imagedir\"
1347             set tmp_imagedir 1
1348         }
1349
1350         # execute test scripts
1351         if { [file exists $scriptsdir/$group/begin] } {
1352             puts "Executing $scriptsdir/$group/begin..."; flush stdout
1353             uplevel source -encoding utf-8 $scriptsdir/$group/begin
1354         }
1355         if { [file exists $scriptsdir/$group/$gridname/begin] } {
1356             puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
1357             uplevel source -encoding utf-8 $scriptsdir/$group/$gridname/begin
1358         }
1359
1360         puts "Executing $casefile..."; flush stdout
1361         uplevel source -encoding utf-8 $casefile
1362
1363         if { [file exists $scriptsdir/$group/$gridname/end] } {
1364             puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
1365             uplevel source -encoding utf-8 $scriptsdir/$group/$gridname/end
1366         }
1367         if { [file exists $scriptsdir/$group/end] } {
1368             puts "Executing $scriptsdir/$group/end..."; flush stdout
1369             uplevel source -encoding utf-8 $scriptsdir/$group/end
1370         }
1371     } res] {
1372         set anExcep $res
1373         if { "$res" == "" } { set anExcep "EMPTY" }
1374     }
1375
1376     # stop logging
1377     if { $dlog_exists } {
1378         if { $echo } {
1379             decho off
1380             if { "$anExcep" != "" } { dputs -red -intense "Tcl Exception: $res" }
1381         } else {
1382             rename puts {}
1383             rename puts-saved puts
1384             dlog off
1385         }
1386     }
1387
1388     # stop cpulimit killer if armed by the test
1389     cpulimit
1390
1391     # add memory and timing info
1392     set stats ""
1393     if { ! [catch {uplevel meminfo h} memuse] } {
1394         append stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
1395     }
1396     uplevel dchrono _timer stop
1397     set time [uplevel dchrono _timer show]
1398     if { [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu_usr] } {
1399         append stats "TOTAL CPU TIME: $cpu_usr sec\n"
1400     }
1401     if { $dlog_exists && ! $echo } {
1402         dlog add $stats
1403     } else {
1404         puts $stats
1405     }
1406
1407     # unset global vars
1408     uplevel unset casename groupname gridname dirname
1409     if { $tmp_imagedir } { uplevel unset imagedir test_image }
1410 }
1411
1412 # Internal procedure to check log of test execution and decide if it passed or failed
1413 proc _check_log {dir group gridname casename errors log {_summary {}} {_html_log {}}} {
1414     global env
1415     if { $_summary != "" } { upvar $_summary summary }
1416     if { $_html_log != "" } { upvar $_html_log html_log }
1417     set summary {}
1418     set html_log {}
1419     set errors_log {}
1420
1421     if [catch {
1422
1423         # load definition of 'bad words' indicating test failure
1424         # note that rules are loaded in the order of decreasing priority (grid - group - common),
1425         # thus grid rules will override group ones
1426         set badwords {}
1427         foreach rulesfile [list $dir/$group/$gridname/parse.rules $dir/$group/parse.rules $dir/parse.rules] {
1428             if [catch {set fd [open $rulesfile r]}] { continue }
1429             while { [gets $fd line] >= 0 } {
1430                 # skip comments and empty lines
1431                 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
1432                 if { [string trim $line] == "" } { continue }
1433                 # extract regexp
1434                 if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } {
1435                     puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
1436                     continue
1437                 }
1438                 set status [string trim $status]
1439                 if { $comment != "" } { append status " ([string trim $comment])" }
1440                 set rexp [regsub -all {\\b} $rexp {\\y}] ;# convert regexp from Perl to Tcl style
1441                 lappend badwords [list $status $rexp]
1442             }
1443             close $fd
1444         }
1445         if { [llength $badwords] <= 0 } {
1446             puts "Warning: no definition of error indicators found (check files parse.rules)"
1447         }
1448
1449         # analyse log line-by-line
1450         set todos {} ;# TODO statements
1451         set requs {} ;# REQUIRED statements
1452         set todo_incomplete -1
1453         set status ""
1454         foreach line [split $log "\n"] {
1455             # check if line defines specific treatment of some messages
1456             if [regexp -nocase {^[ \s]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
1457                 if { ! [regexp -nocase {\mAll\M} $platforms] &&
1458                      ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
1459                     lappend html_log [_html_highlight IGNORE $line]
1460                     continue ;# TODO statement is for another platform
1461                 }
1462
1463                 # record TODOs that mark unstable cases
1464                 if { [regexp {[\?]} $platforms] } {
1465                     set todos_unstable([llength $todos]) 1
1466                 }
1467
1468                 # convert legacy regexps from Perl to Tcl style
1469                 set pattern [regsub -all {\\b} [string trim $pattern] {\\y}]
1470
1471                 # special case: TODO TEST INCOMPLETE
1472                 if { [string trim $pattern] == "TEST INCOMPLETE" } {
1473                     set todo_incomplete [llength $todos]
1474                 }
1475
1476                 lappend todos [list $pattern [llength $html_log] $line]
1477                 lappend html_log [_html_highlight BAD $line]
1478                 continue
1479             }
1480             if [regexp -nocase {^[ \s]*REQUIRED ([^:]*):[ \s]*(.*)$} $line res platforms pattern] {
1481                 if { ! [regexp -nocase {\mAll\M} $platforms] &&
1482                      ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
1483                     lappend html_log [_html_highlight IGNORE $line]
1484                     continue ;# REQUIRED statement is for another platform
1485                 }
1486                 lappend requs [list $pattern [llength $html_log] $line]
1487                 lappend html_log [_html_highlight OK $line]
1488                 continue
1489             }
1490
1491             # check for presence of required messages
1492             set ismarked 0
1493             for {set i 0} {$i < [llength $requs]} {incr i} {
1494                 set pattern [lindex $requs $i 0]
1495                 if { [regexp $pattern $line] } {
1496                     incr required_count($i)
1497                     lappend html_log [_html_highlight OK $line]
1498                     set ismarked 1
1499                     continue
1500                 }
1501             }
1502             if { $ismarked } {
1503                 continue
1504             }
1505
1506             # check for presence of messages indicating test result
1507             foreach bw $badwords {
1508                 if { [regexp [lindex $bw 1] $line] } {
1509                     # check if this is known bad case
1510                     set is_known 0
1511                     for {set i 0} {$i < [llength $todos]} {incr i} {
1512                         set pattern [lindex $todos $i 0]
1513                         if { [regexp $pattern $line] } {
1514                             set is_known 1
1515                             incr todo_count($i)
1516                             lappend html_log [_html_highlight BAD $line]
1517                             break
1518                         }
1519                     }
1520
1521                     # if it is not in todo, define status
1522                     if { ! $is_known } {
1523                         set stat [lindex $bw 0 0]
1524                         if {$errors} {
1525                             lappend errors_log $line
1526                         }
1527                         lappend html_log [_html_highlight $stat $line]
1528                         if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
1529                             set status [lindex $bw 0]
1530                         }
1531                     }
1532                     set ismarked 1
1533                     break
1534                 }
1535             }
1536             if { ! $ismarked } {
1537                lappend html_log $line
1538             }
1539         }
1540
1541         # check for presence of TEST COMPLETED statement
1542         if { $status == "" && ! [regexp {TEST COMPLETED} $log] } {
1543             # check whether absence of TEST COMPLETED is known problem
1544             if { $todo_incomplete >= 0 } {
1545                 incr todo_count($todo_incomplete)
1546             } else {
1547                 set status "FAILED (no final message is found)"
1548             }
1549         }
1550
1551         # report test as failed if it doesn't contain required pattern
1552         if { $status == "" } {
1553             for {set i 0} {$i < [llength $requs]} {incr i} {
1554                 if { ! [info exists required_count($i)] } {
1555                     set linenum [lindex $requs $i 1]
1556                     set html_log [lreplace $html_log $linenum $linenum [_html_highlight FAILED [lindex $requs $i 2]]]
1557                     set status "FAILED (REQUIRED statement no. [expr $i + 1] is not found)"
1558                 }
1559             }
1560         }
1561
1562         # check declared bad cases and diagnose possible improvement
1563         # (bad case declared but not detected).
1564         # Note that absence of the problem marked by TODO with question mark
1565         # (unstable) is not reported as improvement.
1566         if { $status == "" } {
1567             for {set i 0} {$i < [llength $todos]} {incr i} {
1568                 if { ! [info exists todos_unstable($i)] &&
1569                      (! [info exists todo_count($i)] || $todo_count($i) <= 0) } {
1570                     set linenum [lindex $todos $i 1]
1571                     set html_log [lreplace $html_log $linenum $linenum [_html_highlight IMPROVEMENT [lindex $todos $i 2]]]
1572                     set status "IMPROVEMENT (expected problem TODO no. [expr $i + 1] is not detected)"
1573                     break;
1574                 }
1575             }
1576         }
1577
1578         # report test as known bad if at least one of expected problems is found
1579         if { $status == "" && [llength [array names todo_count]] > 0 } {
1580             set status "BAD (known problem)"
1581         }
1582
1583         # report normal OK
1584         if { $status == "" } {set status "OK" }
1585
1586     } res] {
1587         set status "FAILED ($res)"
1588     }
1589
1590     # put final message
1591     _log_and_puts summary "CASE $group $gridname $casename: $status"
1592     set summary [join $summary "\n"]
1593     if {$errors} {
1594         foreach error $errors_log {
1595             _log_and_puts summary "  $error"
1596         }
1597     }
1598     set html_log "[_html_highlight [lindex $status 0] $summary]\n[join $html_log \n]"
1599 }
1600
1601 # Auxiliary procedure putting message to both cout and log variable (list)
1602 proc _log_and_puts {logvar message} {
1603     if { $logvar != "" } {
1604         upvar $logvar log
1605         lappend log $message
1606     }
1607     puts $message
1608 }
1609
1610 # Auxiliary procedure to log result on single test case
1611 proc _log_test_case {output logdir dir group grid casename logvar} {
1612     upvar $logvar log
1613     set show_errors 0
1614
1615     # check result and make HTML log
1616     _check_log $dir $group $grid $casename $show_errors $output summary html_log
1617     lappend log $summary
1618
1619     # save log to file
1620     if { $logdir != "" } {
1621         _log_html $logdir/$group/$grid/$casename.html $html_log "Test $group $grid $casename"
1622         _log_save $logdir/$group/$grid/$casename.log "$output\n$summary" "Test $group $grid $casename"
1623     }
1624
1625     # remove intermediate command file used to run test
1626     if { [file exists $logdir/$group/$grid/${casename}.tcl] } {
1627         file delete $logdir/$group/$grid/${casename}.tcl
1628     }
1629 }
1630
1631 # Auxiliary procedure to save log to file
1632 proc _log_save {file log {title {}}} {
1633     # create missing directories as needed
1634     catch {file mkdir [file dirname $file]}
1635
1636     # try to open a file
1637     if [catch {set fd [open $file w]} res] {
1638         error "Error saving log file $file: $res"
1639     }
1640
1641     # dump log and close
1642     puts $fd "$title\n"
1643     puts $fd $log
1644     close $fd
1645     return
1646 }
1647
1648 # Auxiliary procedure to make a (relative if possible) URL to a file for
1649 # inclusion a reference in HTML log
1650 proc _make_url {htmldir file} {
1651     set htmlpath [file split [file normalize $htmldir]]
1652     set filepath [file split [file normalize $file]]
1653     for {set i 0} {$i < [llength $htmlpath]} {incr i} {
1654         if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
1655             if { $i == 0 } { break }
1656             return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
1657         }
1658     }
1659
1660     # if relative path could not be made, return full file URL
1661     return "file://[file normalize $file]"
1662 }
1663
1664 # Auxiliary procedure to save log to file
1665 proc _log_html {file log {title {}}} {
1666     # create missing directories as needed
1667     catch {file mkdir [file dirname $file]}
1668
1669     # try to open a file
1670     if [catch {set fd [open $file w]} res] {
1671         error "Error saving log file $file: $res"
1672     }
1673
1674     # print header
1675     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
1676     puts $fd "<title>$title</title></head><body><h1>$title</h1>"
1677
1678     # add images if present; these should have either PNG, GIF, or JPG extension,
1679     # and start with name of the test script, with optional suffix separated
1680     # by underscore or dash
1681     set imgbasename [file rootname [file tail $file]]
1682     foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails \
1683                              ${imgbasename}.gif   ${imgbasename}.png   ${imgbasename}.jpg \
1684                              ${imgbasename}_*.gif ${imgbasename}_*.png ${imgbasename}_*.jpg \
1685                              ${imgbasename}-*.gif ${imgbasename}-*.png ${imgbasename}-*.jpg]] {
1686         puts $fd "<p>[file tail $img]<br><img src=\"$img\"/><p>"
1687     }
1688
1689     # print log body, trying to add HTML links to script files on lines like
1690     # "Executing <filename>..."
1691     puts $fd "<pre>"
1692     foreach line [split $log "\n"] {
1693         if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
1694              [file exists $script] } {
1695             set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
1696         }
1697         puts $fd $line
1698     }
1699     puts $fd "</pre></body></html>"
1700
1701     close $fd
1702     return
1703 }
1704
1705 # Auxiliary method to make text with HTML highlighting according to status
1706 proc _html_color {status} {
1707     # choose a color for the cell according to result
1708     if { $status == "OK" } {
1709         return lightgreen
1710     } elseif { [regexp -nocase {^FAIL} $status] } {
1711         return ff8080
1712     } elseif { [regexp -nocase {^BAD} $status] } {
1713         return yellow
1714     } elseif { [regexp -nocase {^IMP} $status] } {
1715         return orange
1716     } elseif { [regexp -nocase {^SKIP} $status] } {
1717         return gray
1718     } elseif { [regexp -nocase {^IGNOR} $status] } {
1719         return gray
1720     } else {
1721         puts "Warning: no color defined for status $status, using red as if FAILED"
1722         return red
1723     }
1724 }
1725
1726 # Format text line in HTML to be colored according to the status
1727 proc _html_highlight {status line} {
1728     return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
1729 }
1730
1731 # Internal procedure to generate HTML page presenting log of the tests
1732 # execution in tabular form, with links to reports on individual cases
1733 proc _log_html_summary {logdir log totals regressions improvements skipped total_time} {
1734     global _test_case_regexp
1735
1736     # create missing directories as needed
1737     file mkdir $logdir
1738
1739     # try to open a file and start HTML
1740     if [catch {set fd [open $logdir/summary.html w]} res] {
1741         error "Error creating log file: $res"
1742     }
1743
1744     # write HRML header, including command to refresh log if still in progress
1745     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
1746     puts $fd "<title>Tests summary</title>"
1747     if { $total_time == "" } {
1748         puts $fd "<meta http-equiv=\"refresh\" content=\"10\">"
1749     }
1750     puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
1751     puts $fd "</head><body>"
1752
1753     # put summary
1754     set legend(OK)          "Test passed OK"
1755     set legend(FAILED)      "Test failed (regression)"
1756     set legend(BAD)         "Known problem"
1757     set legend(IMPROVEMENT) "Possible improvement (expected problem not detected)"
1758     set legend(SKIPPED)     "Test skipped due to lack of data file"
1759     puts $fd "<h1>Summary</h1><table>"
1760     foreach nbstat $totals {
1761         set status [lindex $nbstat 1]
1762         if { [info exists legend($status)] } {
1763             set comment $legend($status)
1764         } else {
1765             set comment "User-defined status"
1766         }
1767         puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
1768     }
1769     puts $fd "</table>"
1770
1771     # time stamp and elapsed time info
1772     puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname]\n<p>"
1773     if { $total_time != "" } {
1774         puts $fd [join [split $total_time "\n"] "<p>"]
1775     } else {
1776         puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
1777     }
1778
1779     # print regressions and improvements
1780     foreach featured [list $regressions $improvements $skipped] {
1781         if { [llength $featured] <= 1 } { continue }
1782         set status [string trim [lindex $featured 0] { :}]
1783         puts $fd "<h2>$status</h2>"
1784         puts $fd "<table>"
1785         set groupgrid ""
1786         foreach test [lrange $featured 1 end] {
1787             if { ! [regexp {^(.*)\s+([\w\-.]+)$} $test res gg name] } {
1788                 set gg UNKNOWN
1789                 set name "Error building short list; check details"
1790             }
1791             if { $gg != $groupgrid } {
1792                 if { $groupgrid != "" } { puts $fd "</tr>" }
1793                 set groupgrid $gg
1794                 puts $fd "<tr><td>$gg</td>"
1795             }
1796             puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
1797         }
1798         if { $groupgrid != "" } { puts $fd "</tr>" }
1799         puts $fd "</table>"
1800     }
1801
1802     # put detailed log with TOC
1803     puts $fd "<hr><h1>Details</h1>"
1804     puts $fd "<div style=\"float:right; padding: 10px; border-style: solid; border-color: blue; border-width: 2px;\">"
1805
1806     # process log line-by-line
1807     set group {}
1808     set letter {}
1809     set body {}
1810     foreach line [lsort -dictionary $log] {
1811         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1812         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1813             continue
1814         }
1815
1816         # start new group
1817         if { $grp != $group } {
1818             if { $letter != "" } { lappend body "</tr></table>" }
1819             set letter {}
1820             set group $grp
1821             set grid {}
1822             puts $fd "<a href=\"#$group\">$group</a><br>"
1823             lappend body "<h2><a name=\"$group\">Group $group</a></h2>"
1824         }
1825
1826         # start new grid
1827         if { $grd != $grid } {
1828             if { $letter != "" } { lappend body "</tr></table>" }
1829             set letter {}
1830             set grid $grd
1831             puts $fd "&nbsp;&nbsp;&nbsp;&nbsp;<a href=\"#$group-$grid\">$grid</a><br>"
1832             lappend body "<h2><a name=\"$group-$grid\">Grid $group $grid</a></h2>"
1833         }
1834
1835         # check if test case name is <letter><digit>;
1836         # if not, set alnum to period "." to recognize non-standard test name
1837         if { ! [regexp {\A([A-Za-z]{1,2})([0-9]{1,2})\Z} $casename res alnum number] &&
1838              ! [regexp {\A([A-Za-z0-9]+)_([0-9]+)\Z} $casename res alnum number] } {
1839             set alnum $casename
1840         }
1841
1842         # start new row when letter changes or for non-standard names
1843         if { $alnum != $letter || $alnum == "." } {
1844             if { $letter != "" } {
1845                 lappend body "</tr><tr>"
1846             } else {
1847                 lappend body "<table><tr>"
1848             }
1849             set letter $alnum
1850         }
1851
1852         lappend body "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
1853     }
1854     puts $fd "</div>\n[join $body "\n"]</tr></table>"
1855
1856     # add remaining lines of log as plain text
1857     puts $fd "<h2>Plain text messages</h2>\n<pre>"
1858     foreach line $log {
1859         if { ! [regexp $_test_case_regexp $line] } {
1860             puts $fd "$line"
1861         }
1862     }
1863     puts $fd "</pre>"
1864
1865     # close file and exit
1866     puts $fd "</body>"
1867     close $fd
1868     return
1869 }
1870
1871 # Procedure to dump summary logs of tests
1872 proc _log_summarize {logdir log {total_time {}}} {
1873
1874     # sort log records alphabetically to have the same behavior on Linux and Windows
1875     # (also needed if tests are run in parallel)
1876     set loglist [lsort -dictionary $log]
1877
1878     # classify test cases by status
1879     foreach line $loglist {
1880         if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
1881             lappend stat($status) $caseid
1882         }
1883     }
1884     set totals {}
1885     set improvements {Improvements:}
1886     set regressions {Failed:}
1887     set skipped {Skipped:}
1888     if { [info exists stat] } {
1889         foreach status [lsort [array names stat]] {
1890             lappend totals [list [llength $stat($status)] $status]
1891
1892             # separately count improvements (status starting with IMP), skipped (status starting with SKIP) and regressions (all except IMP, OK, BAD, and SKIP)
1893             if { [regexp -nocase {^IMP} $status] } {
1894                 eval lappend improvements $stat($status)
1895             } elseif { [regexp -nocase {^SKIP} $status] } {
1896                 eval lappend skipped $stat($status)
1897             } elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
1898                 eval lappend regressions $stat($status)
1899             }
1900         }
1901     }
1902
1903     # if time is specified, add totals
1904     if { $total_time != "" } {
1905         if { [llength $improvements] > 1 } {
1906             _log_and_puts log [join $improvements "\n  "]
1907         }
1908         if { [llength $regressions] > 1 } {
1909             _log_and_puts log [join $regressions "\n  "]
1910         }
1911         if { [llength $skipped] > 1 } {
1912             _log_and_puts log [join $skipped "\n  "]
1913         }
1914         if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
1915             _log_and_puts log "No regressions"
1916         }
1917         _log_and_puts log "Total cases: [join $totals {, }]"
1918         _log_and_puts log $total_time
1919     }
1920
1921     # save log to files
1922     if { $logdir != "" } {
1923         _log_html_summary $logdir $log $totals $regressions $improvements $skipped $total_time
1924         _log_save $logdir/tests.log [join $log "\n"] "Tests summary"
1925     }
1926
1927     return
1928 }
1929
1930 # Internal procedure to generate XML log in JUnit style, for further
1931 # consumption by Jenkins or similar systems.
1932 #
1933 # The output is intended to conform to XML schema supported by Jenkins found at
1934 # 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
1935 #
1936 # The mapping of the fields is inspired by annotated schema of Apache Ant JUnit XML format found at
1937 # http://windyroad.org/dl/Open%20Source/JUnit.xsd
1938 proc _log_xml_summary {logdir filename log include_cout} {
1939     global _test_case_regexp
1940
1941     catch {file mkdir [file dirname $filename]}
1942
1943     # try to open a file and start XML
1944     if [catch {set fd [open $filename w]} res] {
1945         error "Error creating XML summary file $filename: $res"
1946     }
1947     puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1948     puts $fd "<testsuites>"
1949
1950     # prototype for command to generate test suite tag
1951     set time_and_host "timestamp=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\" hostname=\"[info hostname]\""
1952     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"}
1953
1954     # sort log and process it line-by-line
1955     set group {}
1956     foreach line [lsort -dictionary $log] {
1957         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1958         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1959             continue
1960         }
1961         set message [string trim $message " \t\r\n()"]
1962
1963         # start new testsuite for each grid
1964         if { $grp != $group || $grd != $grid } {
1965
1966             # write previous test suite
1967             if [info exists testcases] { eval $cmd_testsuite }
1968
1969             set testcases {}
1970             set nbtests 0
1971             set nberr 0
1972             set nbfail 0
1973             set nbskip 0
1974             set time 0.
1975
1976             set group $grp
1977             set grid $grd
1978         }
1979
1980         incr nbtests
1981
1982         # parse test log and get its CPU time
1983         set testout {}
1984         set add_cpu {}
1985         if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } {
1986             puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1987         } else {
1988             while { [gets $fdlog logline] >= 0 } {
1989                 if { $include_cout } {
1990                     append testout "$logline\n"
1991                 }
1992                 if [regexp -nocase {TOTAL CPU TIME:\s*([\d.]+)\s*sec} $logline res cpu] {
1993                     set add_cpu " time=\"$cpu\""
1994                     set time [expr $time + $cpu]
1995                 }
1996             }
1997             close $fdlog
1998         }
1999         if { ! $include_cout } {
2000             set testout "$line\n"
2001         }
2002
2003         # record test case with its output and status
2004         # Mapping is: SKIPPED, BAD, and OK to OK, all other to failure
2005         append testcases "\n  <testcase name=\"$casename\"$add_cpu status=\"$result\">\n"
2006         append testcases "\n    <system-out>\n$testout    </system-out>"
2007         if { $result != "OK" } {
2008             if { [regexp -nocase {^SKIP} $result] } {
2009                 incr nberr
2010                 append testcases "\n    <error name=\"$result\" message=\"$message\"/>"
2011             } elseif { [regexp -nocase {^BAD} $result] } {
2012                 incr nbskip
2013                 append testcases "\n    <skipped>$message</skipped>"
2014             } else {
2015                 incr nbfail
2016                 append testcases "\n    <failure name=\"$result\" message=\"$message\"/>"
2017             }
2018         }
2019         append testcases "\n  </testcase>"
2020     }
2021
2022     # write last test suite
2023     if [info exists testcases] { eval $cmd_testsuite }
2024
2025     # the end
2026     puts $fd "</testsuites>"
2027     close $fd
2028     return
2029 }
2030
2031 # Auxiliary procedure to split path specification (usually defined by
2032 # environment variable) into list of directories or files
2033 proc _split_path {pathspec} {
2034     global tcl_platform
2035
2036     # first replace all \ (which might occur on Windows) by /
2037     regsub -all "\\\\" $pathspec "/" pathspec
2038
2039     # split path by platform-specific separator
2040     return [split $pathspec [_path_separator]]
2041 }
2042
2043 # Auxiliary procedure to define platform-specific separator for directories in
2044 # path specification
2045 proc _path_separator {} {
2046     global tcl_platform
2047
2048     # split path by platform-specific separator
2049     if { $tcl_platform(platform) == "windows" } {
2050         return ";"
2051     } else {
2052         return ":"
2053     }
2054 }
2055
2056 # Procedure to make a diff and common of two lists
2057 proc _list_diff {list1 list2 _in1 _in2 _common} {
2058     upvar $_in1 in1
2059     upvar $_in2 in2
2060     upvar $_common common
2061
2062     set in1 {}
2063     set in2 {}
2064     set common {}
2065     foreach item $list1 {
2066         if { [lsearch -exact $list2 $item] >= 0 } {
2067             lappend common $item
2068         } else {
2069             lappend in1 $item
2070         }
2071     }
2072     foreach item $list2 {
2073         if { [lsearch -exact $common $item] < 0 } {
2074             lappend in2 $item
2075         }
2076     }
2077     return
2078 }
2079
2080 # procedure to load a file to Tcl string
2081 proc _read_file {filename} {
2082     set fd [open $filename r]
2083     set result [read -nonewline $fd]
2084     close $fd
2085     return $result
2086 }
2087
2088 # procedure to construct name for the mage diff file
2089 proc _diff_img_name {dir1 dir2 casepath imgfile} {
2090     return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
2091 }
2092
2093 # auxiliary procedure to produce string comparing two values
2094 proc _diff_show_ratio {value1 value2} {
2095     if {[expr double ($value2)] == 0.} {
2096         return "$value1 / $value2"
2097     } else {
2098         return "$value1 / $value2 \[[format "%+5.2f%%" [expr 100 * ($value1 - $value2) / double($value2)]]\]"
2099     }
2100 }
2101
2102 # auxiliary procedure to produce string comparing two values, where first value is a portion of second
2103 proc _diff_show_positive_ratio {value1 value2} {
2104     if {[expr double ($value2)] == 0.} {
2105         return "$value1 / $value2"
2106     } else {
2107         return "$value1 / $value2 \[[format "%5.2f%%" [expr 100 * double($value1) / double($value2)]]\]"
2108     }
2109 }
2110
2111 # procedure to check cpu user time
2112 proc _check_time {regexp_msg} {
2113     upvar log log
2114     upvar log1 log1
2115     upvar log2 log2
2116     upvar log_cpu log_cpu
2117     upvar cpu cpu
2118     upvar basename basename
2119     upvar casename casename
2120     set time1_list [dict create]
2121     set time2_list [dict create]
2122     set cpu_find UNDEFINED
2123
2124     foreach line1 [split $log1 "\n"] {
2125         if { [regexp "${regexp_msg}" $line1 dump chronometer_name cpu_find] } {
2126             dict set time1_list "${chronometer_name}" "${cpu_find}"
2127         }
2128     }
2129
2130     foreach line2 [split $log2 "\n"] {
2131         if { [regexp "${regexp_msg}" $line2 dump chronometer_name cpu_find] } {
2132             dict set time2_list "${chronometer_name}" "${cpu_find}"
2133         }
2134     }
2135
2136     if { [llength [dict keys $time1_list]] != [llength [dict keys $time2_list]] } {
2137         puts "Error: number of dchrono/chrono COUNTER are different in the same test cases"
2138     } else {
2139         foreach key [dict keys $time1_list] {
2140             set time1 [dict get $time1_list $key]
2141             set time2 [dict get $time2_list $key]
2142
2143             # compare CPU user time with 10% precision (but not less 0.5 sec)
2144             if { [expr abs ($time1 - $time2) > 0.5 + 0.05 * abs ($time1 + $time2)] } {
2145                 if {$cpu != false} {
2146                     _log_and_puts log_cpu "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2147                 } else {
2148                     _log_and_puts log "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2149                 }
2150             }
2151         }
2152     }
2153 }
2154
2155 # Procedure to compare results of two runs of test cases
2156 proc _test_diff {dir1 dir2 basename image cpu memory status verbose _logvar _logimage _logcpu _logmemory {_statvar ""}} {
2157     upvar $_logvar log
2158     upvar $_logimage log_image
2159     upvar $_logcpu log_cpu
2160     upvar $_logmemory log_memory
2161
2162     # make sure to load diffimage command
2163     uplevel pload VISUALIZATION
2164
2165     # prepare variable (array) for collecting statistics
2166     if { "$_statvar" != "" } {
2167         upvar $_statvar stat
2168     } else {
2169         set stat(cpu1) 0
2170         set stat(cpu2) 0
2171         set stat(mem1) 0
2172         set stat(mem2) 0
2173         set stat(img1) 0
2174         set stat(img2) 0
2175         set log {}
2176         set log_image {}
2177         set log_cpu {}
2178         set log_memory {}
2179     }
2180
2181     # first check subdirectories
2182     set path1 [file join $dir1 $basename]
2183     set path2 [file join $dir2 $basename]
2184     set list1 [glob -directory $path1 -types d -tails -nocomplain *]
2185     set list2 [glob -directory $path2 -types d -tails -nocomplain *]
2186     if { [llength $list1] >0 || [llength $list2] > 0 } {
2187         _list_diff $list1 $list2 in1 in2 common
2188         if { "$verbose" > 1 } {
2189             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2190             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2191         }
2192         foreach subdir $common {
2193             if { "$verbose" > 2 } {
2194                 _log_and_puts log "Checking [file join $basename $subdir]"
2195             }
2196             _test_diff $dir1 $dir2 [file join $basename $subdir] $image $cpu $memory $status $verbose log log_image log_cpu log_memory stat
2197         }
2198     } else {
2199         # check log files (only if directory has no subdirs)
2200         set list1 [glob -directory $path1 -types f -tails -nocomplain *.log]
2201         set list2 [glob -directory $path2 -types f -tails -nocomplain *.log]
2202         _list_diff $list1 $list2 in1 in2 common
2203         if { "$verbose" > 1 } {
2204             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2205             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2206         }
2207         set gcpu1 0
2208         set gcpu2 0
2209         set gmem1 0
2210         set gmem2 0
2211         foreach logfile $common {
2212             # load two logs
2213             set log1 [_read_file [file join $dir1 $basename $logfile]]
2214             set log2 [_read_file [file join $dir2 $basename $logfile]]
2215             set casename [file rootname $logfile]
2216
2217             # check execution statuses
2218             if {$image == false && $cpu == false && $memory == false} {
2219                 set status1 UNDEFINED
2220                 set status2 UNDEFINED
2221                 if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
2222                     ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
2223                     "$status1" != "$status2" } {
2224                     _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
2225                     # if test statuses are different, further comparison makes
2226                     # no sense unless explicitly requested
2227                     if { "$status" != "all" } {
2228                         continue
2229                     }
2230                 }
2231                 if { "$status" == "ok" && "$status1" != "OK" } {
2232                     continue
2233                 }
2234             }
2235
2236             if { ! $image } {
2237                 # check CPU user time in test cases
2238                 set checkCPURegexp "COUNTER (.+): (\[-0-9.+eE\]+)"
2239                 if { [regexp "${checkCPURegexp}" $log1] &&
2240                      [regexp "${checkCPURegexp}" $log2] } {
2241                   _check_time "${checkCPURegexp}"
2242                 }
2243             }
2244
2245             # check CPU times
2246             if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2247                 set cpu1 UNDEFINED
2248                 set cpu2 UNDEFINED
2249                 if { [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log1 res1 cpu1] &&
2250                      [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log2 res1 cpu2] } {
2251                     set stat(cpu1) [expr $stat(cpu1) + $cpu1]
2252                     set stat(cpu2) [expr $stat(cpu2) + $cpu2]
2253                     set gcpu1 [expr $gcpu1 + $cpu1]
2254                     set gcpu2 [expr $gcpu2 + $cpu2]
2255
2256                     # compare CPU times with 10% precision (but not less 0.5 sec)
2257                     if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
2258                         if {$cpu != false} {
2259                             _log_and_puts log_cpu "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2260                         } else {
2261                             _log_and_puts log "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2262                         }
2263                     }
2264                 }
2265             }
2266
2267             # check memory delta
2268             if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2269                 set mem1 UNDEFINED
2270                 set mem2 UNDEFINED
2271                 if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
2272                      [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
2273                     set stat(mem1) [expr $stat(mem1) + $mem1]
2274                     set stat(mem2) [expr $stat(mem2) + $mem2]
2275                     set gmem1 [expr $gmem1 + $mem1]
2276                     set gmem2 [expr $gmem2 + $mem2]
2277
2278                     # compare memory usage with 10% precision (but not less 16 KiB)
2279                     if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
2280                         if {$memory != false} {
2281                             _log_and_puts log_memory "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2282                         } else {
2283                             _log_and_puts log "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2284                         }
2285                     }
2286                 }
2287             }
2288
2289             # check images
2290             if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2291                 set aCaseDiffColorTol 0
2292                 if { [regexp {IMAGE_COLOR_TOLERANCE:\s*([\d.]+)} $log1 res1 imgtol1] } { set aCaseDiffColorTol $imgtol1 }
2293                 set imglist1 [glob -directory $path1 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2294                 set imglist2 [glob -directory $path2 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2295                 _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
2296                 if { "$verbose" > 1 } {
2297                     if { [llength $imgin1] > 0 } {
2298                         if {$image != false} {
2299                             _log_and_puts log_image "Only in $path1: $imgin1"
2300                         } else {
2301                             _log_and_puts log "Only in $path1: $imgin1"
2302                         }
2303                     }
2304                     if { [llength $imgin2] > 0 } {
2305                         if {$image != false} {
2306                             _log_and_puts log_image "Only in $path2: $imgin2"
2307                         } else {
2308                             _log_and_puts log "Only in $path2: $imgin2"
2309                         }
2310                     }
2311                 }
2312
2313                 foreach imgfile $imgcommon {
2314                     set stat(img2) [expr $stat(img2) + 1]
2315                     # if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
2316                     set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
2317                     if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2318                                            [file join $dir2 $basename $imgfile] \
2319                                            -toleranceOfColor 0.0 -blackWhite off -borderFilter off $diffile} diff] } {
2320                         if {$image != false} {
2321                             set stat(img1) [expr $stat(img1) + 1]
2322                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2323                         } else {
2324                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2325                         }
2326                         file delete -force $diffile ;# clean possible previous result of diffimage
2327                     } elseif { $diff != 0 } {
2328                         set diff [string trimright $diff \n]
2329                         if {$aCaseDiffColorTol != 0} {
2330                             # retry with color tolerance
2331                             if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2332                                                    [file join $dir2 $basename $imgfile] \
2333                                                    -toleranceOfColor $aCaseDiffColorTol -blackWhite off -borderFilter off $diffile} diff2] } {
2334                                 if {$image != false} {
2335                                     set stat(img1) [expr $stat(img1) + 1]
2336                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2337                                 } else {
2338                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2339                                 }
2340                                 continue
2341                             } elseif { $diff2 == 0 } {
2342                                 # exclude image diff within tolerance but still keep info in the log
2343                                 set toLogImageCase false
2344                                 file delete -force $diffile
2345                                 if {$image != false} {
2346                                     set stat(img1) [expr $stat(img1) + 1]
2347                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2348                                 } else {
2349                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2350                                 }
2351                                 continue
2352                             }
2353                         }
2354
2355                         if {$image != false} {
2356                             set stat(img1) [expr $stat(img1) + 1]
2357                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2358                         } else {
2359                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2360                         }
2361                     } else {
2362                         file delete -force $diffile ;# clean useless artifact of diffimage
2363                     }
2364                 }
2365             }
2366         }
2367
2368         # report CPU and memory difference in group if it is greater than 10%
2369         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2370             if { [expr abs ($gcpu1 - $gcpu2) > 0.5 + 0.005 * abs ($gcpu1 + $gcpu2)] } {
2371                 if {$cpu != false} {
2372                     _log_and_puts log_cpu "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2373                 } else {
2374                     _log_and_puts log "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2375                 }
2376             }
2377         }
2378         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2379             if { [expr abs ($gmem1 - $gmem2) > 16 + 0.005 * abs ($gmem1 + $gmem2)] } {
2380                 if {$memory != false} {
2381                     _log_and_puts log_memory "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2382                 } else {
2383                     _log_and_puts log "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2384                 }
2385             }
2386         }
2387     }
2388
2389     if { "$_statvar" == "" } {
2390         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2391             if {$memory != false} {
2392                 _log_and_puts log_memory "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2393             } else {
2394                 _log_and_puts log "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2395             }
2396         }
2397         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2398             if {$cpu != false} {
2399                 _log_and_puts log_cpu "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2400             } else {
2401                 _log_and_puts log "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2402             }
2403         }
2404         if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2405             if {$image != false} {
2406                 _log_and_puts log_image "Total Image difference: [_diff_show_positive_ratio $stat(img1) $stat(img2)]"
2407             } else {
2408                 _log_and_puts log "Total Image difference: [_diff_show_positive_ratio $stat(img1) $stat(img2)]"
2409             }
2410         }
2411     }
2412 }
2413
2414 # Auxiliary procedure to save log of results comparison to file
2415 proc _log_html_diff {file log dir1 dir2 highlight_percent} {
2416     # create missing directories as needed
2417     catch {file mkdir [file dirname $file]}
2418
2419     # try to open a file
2420     if [catch {set fd [open $file w]} res] {
2421         error "Error saving log file $file: $res"
2422     }
2423
2424     # print header
2425     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
2426     puts $fd "<title>Diff $dir1 vs. $dir2</title></head><body>"
2427     puts $fd "<h1>Comparison of test results:</h1>"
2428     puts $fd "<h2>Version A \[NEW\] - $dir1</h2>"
2429     puts $fd "<h2>Version B \[REF\] - $dir2</h2>"
2430
2431     # add script for switching between images on click
2432     puts $fd ""
2433     puts $fd "<script type=\"text/javascript\">"
2434     puts $fd "  function diffimage_toggle(img,url1,url2)"
2435     puts $fd "  {"
2436     puts $fd "    if (img.show2nd) { img.src = url1; img.show2nd = false; }"
2437     puts $fd "    else { img.src = url2; img.show2nd = true; }"
2438     puts $fd "  }"
2439     puts $fd "  function diffimage_reset(img,url) { img.src = url; img.show2nd = true; }"
2440     puts $fd "</script>"
2441     puts $fd ""
2442
2443     # print log body
2444     puts $fd "<pre>"
2445     set logpath [file split [file normalize $file]]
2446     foreach line $log {
2447         # put a line; highlight considerable (> ${highlight_percent}%) deviations of CPU and memory
2448         if { [regexp "\[\\\[](\[0-9.e+-]+)%\[\]]" $line res value] &&
2449              [expr abs($value)] > ${highlight_percent} } {
2450             puts $fd "<table><tr><td bgcolor=\"[expr $value > 0 ? \"ff8080\" : \"lightgreen\"]\">$line</td></tr></table>"
2451         } elseif { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+) is similar} $line res case img] } {
2452             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2453                 # note: special handler for the case if test grid directoried are compared directly
2454                 set gridpath ""
2455             }
2456             set aCaseName [lindex $case end]
2457             puts $fd "<table><tr><td bgcolor=\"orange\"><a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\">$line</a></td></tr></table>"
2458         } elseif { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
2459             # add images
2460             puts $fd $line
2461             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2462                 # note: special handler for the case if test grid directoried are compared directly
2463                 set gridpath ""
2464             }
2465             set aCaseName [lindex $case end]
2466             set img1url [_make_url $file [file join $dir1 $gridpath $img]]
2467             set img2url [_make_url $file [file join $dir2 $gridpath $img]]
2468             set img1 "<a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\"><img src=\"$img1url\"></a>"
2469             set img2 "<a href=\"[_make_url $file [file join $dir2 $gridpath $aCaseName.html]]\"><img src=\"$img2url\"></a>"
2470
2471             set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
2472             set imgdurl [_make_url $file $difffile]
2473             if { [file exists $difffile] } {
2474                 set imgd "<img src=\"$imgdurl\" onmouseout=diffimage_reset(this,\"$imgdurl\") onclick=diffimage_toggle(this,\"$img1url\",\"$img2url\")>"
2475             } else {
2476                 set imgd "N/A"
2477             }
2478
2479             puts $fd "<table><tr><th><abbr title=\"$dir1\">Version A</abbr></th><th><abbr title=\"$dir2\">Version B</abbr></th><th>Diff (click to toggle)</th></tr>"
2480             puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
2481         } else {
2482             puts $fd $line
2483         }
2484     }
2485     puts $fd "</pre></body></html>"
2486
2487     close $fd
2488     return
2489 }
2490
2491 # get number of CPUs on the system
2492 proc _get_nb_cpus {} {
2493     global tcl_platform env
2494
2495     if { "$tcl_platform(platform)" == "windows" } {
2496         # on Windows, take the value of the environment variable
2497         if { [info exists env(NUMBER_OF_PROCESSORS)] &&
2498              ! [catch {expr $env(NUMBER_OF_PROCESSORS) > 0} res] && $res >= 0 } {
2499             return $env(NUMBER_OF_PROCESSORS)
2500         }
2501     } elseif { "$tcl_platform(os)" == "Linux" } {
2502         # on Linux, take number of logical processors listed in /proc/cpuinfo
2503         if { [catch {open "/proc/cpuinfo" r} fd] } {
2504             return 0 ;# should never happen, but...
2505         }
2506         set nb 0
2507         while { [gets $fd line] >= 0 } {
2508             if { [regexp {^processor[ \t]*:} $line] } {
2509                 incr nb
2510             }
2511         }
2512         close $fd
2513         return $nb
2514     } elseif { "$tcl_platform(os)" == "Darwin" } {
2515         # on MacOS X, call sysctl command
2516         if { ! [catch {exec sysctl hw.ncpu} ret] &&
2517              [regexp {^hw[.]ncpu[ \t]*:[ \t]*([0-9]+)} $ret res nb] } {
2518             return $nb
2519         }
2520     }
2521
2522     # if cannot get good value, return 0 as default
2523     return 0
2524 }
2525
2526 # check two files for difference
2527 proc _diff_files {file1 file2} {
2528     set fd1 [open $file1 "r"]
2529     set fd2 [open $file2 "r"]
2530
2531     set differ f
2532     while {! $differ} {
2533         set nb1 [gets $fd1 line1]
2534         set nb2 [gets $fd2 line2]
2535         if { $nb1 != $nb2 } { set differ t; break }
2536         if { $nb1 < 0 } { break }
2537         if { [string compare $line1 $line2] } {
2538             set differ t
2539         }
2540     }
2541
2542     close $fd1
2543     close $fd2
2544
2545     return $differ
2546 }
2547
2548 # Check if file is in DOS encoding.
2549 # This check is done by presence of \r\n combination at the end of the first
2550 # line (i.e. prior to any other \n symbol).
2551 # Note that presence of non-ascii symbols typically used for recognition
2552 # of binary files is not suitable since some IGES and STEP files contain
2553 # non-ascii symbols.
2554 # Special check is added for PNG files which contain \r\n in the beginning.
2555 proc _check_dos_encoding {file} {
2556     set fd [open $file rb]
2557     set isdos f
2558     if { [gets $fd line] && [regexp {.*\r$} $line] &&
2559          ! [regexp {^.PNG} $line] } {
2560         set isdos t
2561     }
2562     close $fd
2563     return $isdos
2564 }
2565
2566 # procedure to recognize format of a data file by its first symbols (for OCCT
2567 # BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
2568 proc _check_file_format {file} {
2569     set fd [open $file rb]
2570     set line [read $fd 1024]
2571     close $fd
2572
2573     set warn f
2574     set ext [file extension $file]
2575     set format unknown
2576     if { [regexp {^DBRep_DrawableShape} $line] } {
2577         set format BREP
2578         if { "$ext" != ".brep" && "$ext" != ".rle" &&
2579              "$ext" != ".draw" && "$ext" != "" } {
2580             set warn t
2581         }
2582     } elseif { [regexp {^DrawTrSurf_} $line] } {
2583         set format DRAW
2584         if { "$ext" != ".rle" &&
2585              "$ext" != ".draw" && "$ext" != "" } {
2586             set warn t
2587         }
2588     } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
2589         set format STEP
2590         if { "$ext" != ".step" && "$ext" != ".stp" } {
2591             set warn t
2592         }
2593     } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
2594         set format IGES
2595         if { "$ext" != ".iges" && "$ext" != ".igs" } {
2596             set warn t
2597         }
2598     } elseif { "$ext" == ".igs" } {
2599         set format IGES
2600     } elseif { "$ext" == ".stp" } {
2601         set format STEP
2602     } else {
2603         set format [string toupper [string range $ext 1 end]]
2604     }
2605
2606     if { $warn } {
2607         puts "$file: Warning: extension ($ext) does not match format ($format)"
2608     }
2609
2610     return $format
2611 }
2612
2613 # procedure to load file knowing its format
2614 proc load_data_file {file format shape} {
2615     switch $format {
2616         BREP { uplevel restore $file $shape }
2617         DRAW { uplevel restore $file $shape }
2618         IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
2619         STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
2620         STL  { pload XSDRAW; uplevel readstl $shape $file triangulation }
2621         default { error "Cannot read $format file $file" }
2622     }
2623 }
2624
2625 # procedure to get name of temporary directory,
2626 # ensuring it is existing and writeable
2627 proc _get_temp_dir {} {
2628     global env tcl_platform
2629
2630     # check typical environment variables
2631     foreach var {TempDir Temp Tmp} {
2632         # check different case
2633         foreach name [list [string toupper $var] $var [string tolower $var]] {
2634             if { [info exists env($name)] && [file isdirectory $env($name)] &&
2635                  [file writable $env($name)] } {
2636                 return [regsub -all {\\} $env($name) /]
2637             }
2638         }
2639     }
2640
2641     # check platform-specific locations
2642     set fallback tmp
2643     if { "$tcl_platform(platform)" == "windows" } {
2644         set paths "c:/TEMP c:/TMP /TEMP /TMP"
2645         if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
2646             set fallback [regsub -all {\\} "$env(HOMEDRIVE)$env(HOMEPATH)/tmp" /]
2647         }
2648     } else {
2649         set paths "/tmp /var/tmp /usr/tmp"
2650         if { [info exists env(HOME)] } {
2651             set fallback "$env(HOME)/tmp"
2652         }
2653     }
2654     foreach dir $paths {
2655         if { [file isdirectory $dir] && [file writable $dir] } {
2656             return $dir
2657         }
2658     }
2659
2660     # fallback case: use subdir /tmp of home or current dir
2661     file mkdir $fallback
2662     return $fallback
2663 }
2664
2665 # extract of code from testgrid command used to process jobs running in
2666 # parallel until number of jobs in the queue becomes equal or less than
2667 # specified value
2668 proc _testgrid_process_jobs {worker {nb_ok 0}} {
2669     # bind local vars to variables of the caller procedure
2670     upvar log log
2671     upvar logdir logdir
2672     upvar job_def job_def
2673     upvar nbpooled nbpooled
2674     upvar userbreak userbreak
2675     upvar refresh refresh
2676     upvar refresh_timer refresh_timer
2677
2678     catch {tpool::resume $worker}
2679     while { ! $userbreak && $nbpooled > $nb_ok } {
2680         foreach job [tpool::wait $worker [array names job_def]] {
2681             eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
2682             unset job_def($job)
2683             incr nbpooled -1
2684         }
2685
2686         # check for user break
2687         if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
2688             set userbreak 1
2689         }
2690
2691         # update summary log with requested period
2692         if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
2693             _log_summarize $logdir $log
2694             set refresh_timer [clock seconds]
2695         }
2696     }
2697     catch {tpool::suspend $worker}
2698 }
2699
2700 help checkcolor {
2701   Check pixel color.
2702   Use: checkcolor x y red green blue
2703   x y - pixel coordinates
2704   red green blue - expected pixel color (values from 0 to 1)
2705   Function check color with tolerance (5x5 area)
2706 }
2707 # Procedure to check color using command vreadpixel with tolerance
2708 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
2709     puts "Coordinate x = $coord_x"
2710     puts "Coordinate y = $coord_y"
2711     puts "RED color of RGB is $rd_get"
2712     puts "GREEN color of RGB is $gr_get"
2713     puts "BLUE color of RGB is $bl_get"
2714
2715     if { $coord_x <= 1 || $coord_y <= 1 } {
2716         puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
2717         return -1
2718     }
2719
2720     set color ""
2721     catch { [set color "[vreadpixel ${coord_x} ${coord_y} rgb]"] }
2722     if {"$color" == ""} {
2723         puts "Error : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2724     }
2725     set rd [lindex $color 0]
2726     set gr [lindex $color 1]
2727     set bl [lindex $color 2]
2728     set rd_int [expr int($rd * 1.e+05)]
2729     set gr_int [expr int($gr * 1.e+05)]
2730     set bl_int [expr int($bl * 1.e+05)]
2731     set rd_ch [expr int($rd_get * 1.e+05)]
2732     set gr_ch [expr int($gr_get * 1.e+05)]
2733     set bl_ch [expr int($bl_get * 1.e+05)]
2734
2735     if { $rd_ch != 0 } {
2736         set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2737     } else {
2738         set tol_rd $rd_int
2739     }
2740     if { $gr_ch != 0 } {
2741         set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2742     } else {
2743         set tol_gr $gr_int
2744     }
2745     if { $bl_ch != 0 } {
2746         set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2747     } else {
2748         set tol_bl $bl_int
2749     }
2750
2751     set status 0
2752     if { $tol_rd > 0.2 } {
2753         puts "Warning : RED light of additive color model RGB is invalid"
2754         set status 1
2755     }
2756     if { $tol_gr > 0.2 } {
2757         puts "Warning : GREEN light of additive color model RGB is invalid"
2758         set status 1
2759     }
2760     if { $tol_bl > 0.2 } {
2761         puts "Warning : BLUE light of additive color model RGB is invalid"
2762         set status 1
2763     }
2764
2765     if { $status != 0 } {
2766         puts "Warning : Colors of default coordinate are not equal"
2767     }
2768
2769     global stat
2770     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2771         set info [_checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
2772         set stat [lindex $info end]
2773         if { ${stat} != 1 } {
2774             puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
2775             return $stat
2776         } else {
2777             puts "Point with valid color was found"
2778             return $stat
2779         }
2780     } else {
2781         set stat 1
2782     }
2783 }
2784
2785 # Procedure to check color in the point near default coordinate
2786 proc _checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
2787     set x_start [expr ${coord_x} - 2]
2788     set y_start [expr ${coord_y} - 2]
2789     set mistake 0
2790     set i 0
2791     while { $mistake != 1 && $i <= 5 } {
2792         set j 0
2793         while { $mistake != 1 && $j <= 5 } {
2794             set position_x [expr ${x_start} + $j]
2795             set position_y [expr ${y_start} + $i]
2796             puts $position_x
2797             puts $position_y
2798
2799             set color ""
2800             catch { [set color "[vreadpixel ${position_x} ${position_y} rgb]"] }
2801             if {"$color" == ""} {
2802                 puts "Warning : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2803                 incr j
2804                 continue
2805             }
2806             set rd [lindex $color 0]
2807             set gr [lindex $color 1]
2808             set bl [lindex $color 2]
2809             set rd_int [expr int($rd * 1.e+05)]
2810             set gr_int [expr int($gr * 1.e+05)]
2811             set bl_int [expr int($bl * 1.e+05)]
2812
2813             if { $rd_ch != 0 } {
2814                 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2815             } else {
2816                 set tol_rd $rd_int
2817             }
2818             if { $gr_ch != 0 } {
2819                 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2820             } else {
2821                 set tol_gr $gr_int
2822             }
2823             if { $bl_ch != 0 } {
2824                 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2825             } else {
2826                 set tol_bl $bl_int
2827             }
2828
2829             if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2830                 puts "Warning : Point with true color was not found near default coordinates"
2831                 set mistake 0
2832             } else {
2833                 set mistake 1
2834             }
2835             incr j
2836         }
2837         incr i
2838     }
2839     return $mistake
2840 }
2841
2842 # Procedure to check if sequence of values in listval follows linear trend
2843 # adding the same delta on each step.
2844 #
2845 # The function does statistical estimation of the mean variation of the
2846 # values of the sequence, and dispersion, and returns true only if both
2847 # dispersion and deviation of the mean from expected delta are within
2848 # specified tolerance.
2849 #
2850 # If mean variation differs from expected delta on more than two dispersions,
2851 # the check fails and procedure raises error with specified message.
2852 #
2853 # Otherwise the procedure returns false meaning that more iterations are needed.
2854 # Note that false is returned in any case if length of listval is less than 3.
2855 #
2856 # See example of use to check memory leaks in bugs/caf/bug23489
2857 #
2858 proc checktrend {listval delta tolerance message} {
2859     set nbval [llength $listval]
2860     if { $nbval < 3} {
2861         return 0
2862     }
2863
2864     # calculate mean value
2865     set mean 0.
2866     set prev [lindex $listval 0]
2867     foreach val [lrange $listval 1 end] {
2868         set mean [expr $mean + ($val - $prev)]
2869         set prev $val
2870     }
2871     set mean [expr $mean / ($nbval - 1)]
2872
2873     # calculate dispersion
2874     set sigma 0.
2875     set prev [lindex $listval 0]
2876     foreach val [lrange $listval 1 end] {
2877         set d [expr ($val - $prev) - $mean]
2878         set sigma [expr $sigma + $d * $d]
2879         set prev $val
2880     }
2881     set sigma [expr sqrt ($sigma / ($nbval - 2))]
2882
2883     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
2884
2885     # check if deviation is definitely too big
2886     if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
2887         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
2888         error "$message"
2889     }
2890
2891     # check if deviation is clearly within a range
2892     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
2893 }