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 # synopsis.
  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     if [catch {
1323         # set variables identifying test case
1324         uplevel set casename [file tail $casefile]
1325         uplevel set groupname $group
1326         uplevel set gridname $gridname
1327         uplevel set dirname  $scriptsdir
1328
1329         # set path for saving of log and images (if not yet set) to temp dir
1330         if { ! [uplevel info exists imagedir] } {
1331             uplevel set test_image \$casename
1332
1333             # create subdirectory in temp named after group and grid with timestamp
1334             set rootlogdir [_get_temp_dir]
1335
1336             set imagedir "${group}-${gridname}-${::casename}-[clock format [clock seconds] -format {%Y-%m-%dT%Hh%Mm%Ss}]"
1337             set imagedir [file normalize ${rootlogdir}/$imagedir]
1338
1339             if { [catch {file mkdir $imagedir}] || ! [file writable $imagedir] ||
1340                  ! [catch {glob -directory $imagedir *}] } {
1341                  # puts "Warning: Cannot create directory \"$imagedir\", or it is not empty; \"${rootlogdir}\" is used"
1342                 set imagedir $rootlogdir
1343             }
1344
1345             uplevel set imagedir \"$imagedir\"
1346             set tmp_imagedir 1
1347         }
1348
1349         # execute test scripts
1350         if { [file exists $scriptsdir/$group/begin] } {
1351             puts "Executing $scriptsdir/$group/begin..."; flush stdout
1352             uplevel source -encoding utf-8 $scriptsdir/$group/begin
1353         }
1354         if { [file exists $scriptsdir/$group/$gridname/begin] } {
1355             puts "Executing $scriptsdir/$group/$gridname/begin..."; flush stdout
1356             uplevel source -encoding utf-8 $scriptsdir/$group/$gridname/begin
1357         }
1358
1359         puts "Executing $casefile..."; flush stdout
1360         uplevel source -encoding utf-8 $casefile
1361
1362         if { [file exists $scriptsdir/$group/$gridname/end] } {
1363             puts "Executing $scriptsdir/$group/$gridname/end..."; flush stdout
1364             uplevel source -encoding utf-8 $scriptsdir/$group/$gridname/end
1365         }
1366         if { [file exists $scriptsdir/$group/end] } {
1367             puts "Executing $scriptsdir/$group/end..."; flush stdout
1368             uplevel source -encoding utf-8 $scriptsdir/$group/end
1369         }
1370     } res] {
1371         if { "$res" == "" } { set res "EMPTY" }
1372         # in echo mode, output error message using dputs command to have it colored,
1373         # note that doing the same in logged mode would duplicate the message
1374         if { ! $dlog_exists || ! $echo } {
1375             puts "Tcl Exception: $res"
1376         } else {
1377             decho off
1378             dputs -red -intense "Tcl Exception: $res"
1379         }
1380     }
1381
1382     # stop logging
1383     if { $dlog_exists } {
1384         if { $echo } {
1385             decho off
1386         } else {
1387             rename puts {}
1388             rename puts-saved puts
1389             dlog off
1390         }
1391     }
1392
1393     # stop cpulimit killer if armed by the test
1394     cpulimit
1395
1396     # add memory and timing info
1397     set stats ""
1398     if { ! [catch {uplevel meminfo h} memuse] } {
1399         append stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
1400     }
1401     uplevel dchrono _timer stop
1402     set time [uplevel dchrono _timer show]
1403     if { [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu_usr] } {
1404         append stats "TOTAL CPU TIME: $cpu_usr sec\n"
1405     }
1406     if { $dlog_exists && ! $echo } {
1407         dlog add $stats
1408     } else {
1409         puts $stats
1410     }
1411
1412     # unset global vars
1413     uplevel unset casename groupname gridname dirname
1414     if { $tmp_imagedir } { uplevel unset imagedir test_image }
1415 }
1416
1417 # Internal procedure to check log of test execution and decide if it passed or failed
1418 proc _check_log {dir group gridname casename errors log {_summary {}} {_html_log {}}} {
1419     global env
1420     if { $_summary != "" } { upvar $_summary summary }
1421     if { $_html_log != "" } { upvar $_html_log html_log }
1422     set summary {}
1423     set html_log {}
1424     set errors_log {}
1425
1426     if [catch {
1427
1428         # load definition of 'bad words' indicating test failure
1429         # note that rules are loaded in the order of decreasing priority (grid - group - common),
1430         # thus grid rules will override group ones
1431         set badwords {}
1432         foreach rulesfile [list $dir/$group/$gridname/parse.rules $dir/$group/parse.rules $dir/parse.rules] {
1433             if [catch {set fd [open $rulesfile r]}] { continue }
1434             while { [gets $fd line] >= 0 } {
1435                 # skip comments and empty lines
1436                 if { [regexp "\[ \t\]*\#.*" $line] } { continue }
1437                 if { [string trim $line] == "" } { continue }
1438                 # extract regexp
1439                 if { ! [regexp {^([^/]*)/([^/]*)/(.*)$} $line res status rexp comment] } {
1440                     puts "Warning: cannot recognize parsing rule \"$line\" in file $rulesfile"
1441                     continue
1442                 }
1443                 set status [string trim $status]
1444                 if { $comment != "" } { append status " ([string trim $comment])" }
1445                 set rexp [regsub -all {\\b} $rexp {\\y}] ;# convert regexp from Perl to Tcl style
1446                 lappend badwords [list $status $rexp]
1447             }
1448             close $fd
1449         }
1450         if { [llength $badwords] <= 0 } {
1451             puts "Warning: no definition of error indicators found (check files parse.rules)"
1452         }
1453
1454         # analyse log line-by-line
1455         set todos {} ;# TODO statements
1456         set requs {} ;# REQUIRED statements
1457         set todo_incomplete -1
1458         set status ""
1459         foreach line [split $log "\n"] {
1460             # check if line defines specific treatment of some messages
1461             if [regexp -nocase {^[ \s]*TODO ([^:]*):(.*)$} $line res platforms pattern] {
1462                 if { ! [regexp -nocase {\mAll\M} $platforms] &&
1463                      ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
1464                     lappend html_log [_html_highlight IGNORE $line]
1465                     continue ;# TODO statement is for another platform
1466                 }
1467
1468                 # record TODOs that mark unstable cases
1469                 if { [regexp {[\?]} $platforms] } {
1470                     set todos_unstable([llength $todos]) 1
1471                 }
1472
1473                 # convert legacy regexps from Perl to Tcl style
1474                 set pattern [regsub -all {\\b} [string trim $pattern] {\\y}]
1475
1476                 # special case: TODO TEST INCOMPLETE
1477                 if { [string trim $pattern] == "TEST INCOMPLETE" } {
1478                     set todo_incomplete [llength $todos]
1479                 }
1480
1481                 lappend todos [list $pattern [llength $html_log] $line]
1482                 lappend html_log [_html_highlight BAD $line]
1483                 continue
1484             }
1485             if [regexp -nocase {^[ \s]*REQUIRED ([^:]*):[ \s]*(.*)$} $line res platforms pattern] {
1486                 if { ! [regexp -nocase {\mAll\M} $platforms] &&
1487                      ! [regexp -nocase "\\m[checkplatform]\\M" $platforms] } {
1488                     lappend html_log [_html_highlight IGNORE $line]
1489                     continue ;# REQUIRED statement is for another platform
1490                 }
1491                 lappend requs [list $pattern [llength $html_log] $line]
1492                 lappend html_log [_html_highlight OK $line]
1493                 continue
1494             }
1495
1496             # check for presence of required messages
1497             set ismarked 0
1498             for {set i 0} {$i < [llength $requs]} {incr i} {
1499                 set pattern [lindex $requs $i 0]
1500                 if { [regexp $pattern $line] } {
1501                     incr required_count($i)
1502                     lappend html_log [_html_highlight OK $line]
1503                     set ismarked 1
1504                     continue
1505                 }
1506             }
1507             if { $ismarked } {
1508                 continue
1509             }
1510
1511             # check for presence of messages indicating test result
1512             foreach bw $badwords {
1513                 if { [regexp [lindex $bw 1] $line] } {
1514                     # check if this is known bad case
1515                     set is_known 0
1516                     for {set i 0} {$i < [llength $todos]} {incr i} {
1517                         set pattern [lindex $todos $i 0]
1518                         if { [regexp $pattern $line] } {
1519                             set is_known 1
1520                             incr todo_count($i)
1521                             lappend html_log [_html_highlight BAD $line]
1522                             break
1523                         }
1524                     }
1525
1526                     # if it is not in todo, define status
1527                     if { ! $is_known } {
1528                         set stat [lindex $bw 0 0]
1529                         if {$errors} {
1530                             lappend errors_log $line
1531                         }
1532                         lappend html_log [_html_highlight $stat $line]
1533                         if { $status == "" && $stat != "OK" && ! [regexp -nocase {^IGNOR} $stat] } {
1534                             set status [lindex $bw 0]
1535                         }
1536                     }
1537                     set ismarked 1
1538                     break
1539                 }
1540             }
1541             if { ! $ismarked } {
1542                lappend html_log $line
1543             }
1544         }
1545
1546         # check for presence of TEST COMPLETED statement
1547         if { $status == "" && ! [regexp {TEST COMPLETED} $log] } {
1548             # check whether absence of TEST COMPLETED is known problem
1549             if { $todo_incomplete >= 0 } {
1550                 incr todo_count($todo_incomplete)
1551             } else {
1552                 set status "FAILED (no final message is found)"
1553             }
1554         }
1555
1556         # report test as failed if it doesn't contain required pattern
1557         if { $status == "" } {
1558             for {set i 0} {$i < [llength $requs]} {incr i} {
1559                 if { ! [info exists required_count($i)] } {
1560                     set linenum [lindex $requs $i 1]
1561                     set html_log [lreplace $html_log $linenum $linenum [_html_highlight FAILED [lindex $requs $i 2]]]
1562                     set status "FAILED (REQUIRED statement no. [expr $i + 1] is not found)"
1563                 }
1564             }
1565         }
1566
1567         # check declared bad cases and diagnose possible improvement
1568         # (bad case declared but not detected).
1569         # Note that absence of the problem marked by TODO with question mark
1570         # (unstable) is not reported as improvement.
1571         if { $status == "" } {
1572             for {set i 0} {$i < [llength $todos]} {incr i} {
1573                 if { ! [info exists todos_unstable($i)] &&
1574                      (! [info exists todo_count($i)] || $todo_count($i) <= 0) } {
1575                     set linenum [lindex $todos $i 1]
1576                     set html_log [lreplace $html_log $linenum $linenum [_html_highlight IMPROVEMENT [lindex $todos $i 2]]]
1577                     set status "IMPROVEMENT (expected problem TODO no. [expr $i + 1] is not detected)"
1578                     break;
1579                 }
1580             }
1581         }
1582
1583         # report test as known bad if at least one of expected problems is found
1584         if { $status == "" && [llength [array names todo_count]] > 0 } {
1585             set status "BAD (known problem)"
1586         }
1587
1588         # report normal OK
1589         if { $status == "" } {set status "OK" }
1590
1591     } res] {
1592         set status "FAILED ($res)"
1593     }
1594
1595     # put final message
1596     _log_and_puts summary "CASE $group $gridname $casename: $status"
1597     set summary [join $summary "\n"]
1598     if {$errors} {
1599         foreach error $errors_log {
1600             _log_and_puts summary "  $error"
1601         }
1602     }
1603     set html_log "[_html_highlight [lindex $status 0] $summary]\n[join $html_log \n]"
1604 }
1605
1606 # Auxiliary procedure putting message to both cout and log variable (list)
1607 proc _log_and_puts {logvar message} {
1608     if { $logvar != "" } {
1609         upvar $logvar log
1610         lappend log $message
1611     }
1612     puts $message
1613 }
1614
1615 # Auxiliary procedure to log result on single test case
1616 proc _log_test_case {output logdir dir group grid casename logvar} {
1617     upvar $logvar log
1618     set show_errors 0
1619
1620     # check result and make HTML log
1621     _check_log $dir $group $grid $casename $show_errors $output summary html_log
1622     lappend log $summary
1623
1624     # save log to file
1625     if { $logdir != "" } {
1626         _log_html $logdir/$group/$grid/$casename.html $html_log "Test $group $grid $casename"
1627         _log_save $logdir/$group/$grid/$casename.log "$output\n$summary" "Test $group $grid $casename"
1628     }
1629
1630     # remove intermediate command file used to run test
1631     if { [file exists $logdir/$group/$grid/${casename}.tcl] } {
1632         file delete $logdir/$group/$grid/${casename}.tcl
1633     }
1634 }
1635
1636 # Auxiliary procedure to save log to file
1637 proc _log_save {file log {title {}}} {
1638     # create missing directories as needed
1639     catch {file mkdir [file dirname $file]}
1640
1641     # try to open a file
1642     if [catch {set fd [open $file w]} res] {
1643         error "Error saving log file $file: $res"
1644     }
1645
1646     # dump log and close
1647     puts $fd "$title\n"
1648     puts $fd $log
1649     close $fd
1650     return
1651 }
1652
1653 # Auxiliary procedure to make a (relative if possible) URL to a file for
1654 # inclusion a reference in HTML log
1655 proc _make_url {htmldir file} {
1656     set htmlpath [file split [file normalize $htmldir]]
1657     set filepath [file split [file normalize $file]]
1658     for {set i 0} {$i < [llength $htmlpath]} {incr i} {
1659         if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
1660             if { $i == 0 } { break }
1661             return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
1662         }
1663     }
1664
1665     # if relative path could not be made, return full file URL
1666     return "file://[file normalize $file]"
1667 }
1668
1669 # Auxiliary procedure to save log to file
1670 proc _log_html {file log {title {}}} {
1671     # create missing directories as needed
1672     catch {file mkdir [file dirname $file]}
1673
1674     # try to open a file
1675     if [catch {set fd [open $file w]} res] {
1676         error "Error saving log file $file: $res"
1677     }
1678
1679     # print header
1680     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
1681     puts $fd "<title>$title</title></head><body><h1>$title</h1>"
1682
1683     # add images if present; these should have either PNG, GIF, or JPG extension,
1684     # and start with name of the test script, with optional suffix separated
1685     # by underscore or dash
1686     set imgbasename [file rootname [file tail $file]]
1687     foreach img [lsort [glob -nocomplain -directory [file dirname $file] -tails \
1688                              ${imgbasename}.gif   ${imgbasename}.png   ${imgbasename}.jpg \
1689                              ${imgbasename}_*.gif ${imgbasename}_*.png ${imgbasename}_*.jpg \
1690                              ${imgbasename}-*.gif ${imgbasename}-*.png ${imgbasename}-*.jpg]] {
1691         puts $fd "<p>[file tail $img]<br><img src=\"$img\"/><p>"
1692     }
1693
1694     # print log body, trying to add HTML links to script files on lines like
1695     # "Executing <filename>..."
1696     puts $fd "<pre>"
1697     foreach line [split $log "\n"] {
1698         if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
1699              [file exists $script] } {
1700             set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
1701         }
1702         puts $fd $line
1703     }
1704     puts $fd "</pre></body></html>"
1705
1706     close $fd
1707     return
1708 }
1709
1710 # Auxiliary method to make text with HTML highlighting according to status
1711 proc _html_color {status} {
1712     # choose a color for the cell according to result
1713     if { $status == "OK" } {
1714         return lightgreen
1715     } elseif { [regexp -nocase {^FAIL} $status] } {
1716         return ff8080
1717     } elseif { [regexp -nocase {^BAD} $status] } {
1718         return yellow
1719     } elseif { [regexp -nocase {^IMP} $status] } {
1720         return orange
1721     } elseif { [regexp -nocase {^SKIP} $status] } {
1722         return gray
1723     } elseif { [regexp -nocase {^IGNOR} $status] } {
1724         return gray
1725     } else {
1726         puts "Warning: no color defined for status $status, using red as if FAILED"
1727         return red
1728     }
1729 }
1730
1731 # Format text line in HTML to be colored according to the status
1732 proc _html_highlight {status line} {
1733     return "<table><tr><td bgcolor=\"[_html_color $status]\">$line</td></tr></table>"
1734 }
1735
1736 # Internal procedure to generate HTML page presenting log of the tests
1737 # execution in tabular form, with links to reports on individual cases
1738 proc _log_html_summary {logdir log totals regressions improvements skipped total_time} {
1739     global _test_case_regexp
1740
1741     # create missing directories as needed
1742     file mkdir $logdir
1743
1744     # try to open a file and start HTML
1745     if [catch {set fd [open $logdir/summary.html w]} res] {
1746         error "Error creating log file: $res"
1747     }
1748
1749     # write HRML header, including command to refresh log if still in progress
1750     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
1751     puts $fd "<title>Tests summary</title>"
1752     if { $total_time == "" } {
1753         puts $fd "<meta http-equiv=\"refresh\" content=\"10\">"
1754     }
1755     puts $fd "<meta http-equiv=\"pragma\" content=\"NO-CACHE\">"
1756     puts $fd "</head><body>"
1757
1758     # put summary
1759     set legend(OK)          "Test passed OK"
1760     set legend(FAILED)      "Test failed (regression)"
1761     set legend(BAD)         "Known problem"
1762     set legend(IMPROVEMENT) "Possible improvement (expected problem not detected)"
1763     set legend(SKIPPED)     "Test skipped due to lack of data file"
1764     puts $fd "<h1>Summary</h1><table>"
1765     foreach nbstat $totals {
1766         set status [lindex $nbstat 1]
1767         if { [info exists legend($status)] } {
1768             set comment $legend($status)
1769         } else {
1770             set comment "User-defined status"
1771         }
1772         puts $fd "<tr><td align=\"right\">[lindex $nbstat 0]</td><td bgcolor=\"[_html_color $status]\">$status</td><td>$comment</td></tr>"
1773     }
1774     puts $fd "</table>"
1775
1776     # time stamp and elapsed time info
1777     puts $fd "<p>Generated on [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] on [info hostname]\n<p>"
1778     if { $total_time != "" } {
1779         puts $fd [join [split $total_time "\n"] "<p>"]
1780     } else {
1781         puts $fd "<p>NOTE: This is intermediate summary; the tests are still running! This page will refresh automatically until tests are finished."
1782     }
1783
1784     # print regressions and improvements
1785     foreach featured [list $regressions $improvements $skipped] {
1786         if { [llength $featured] <= 1 } { continue }
1787         set status [string trim [lindex $featured 0] { :}]
1788         puts $fd "<h2>$status</h2>"
1789         puts $fd "<table>"
1790         set groupgrid ""
1791         foreach test [lrange $featured 1 end] {
1792             if { ! [regexp {^(.*)\s+([\w\-.]+)$} $test res gg name] } {
1793                 set gg UNKNOWN
1794                 set name "Error building short list; check details"
1795             }
1796             if { $gg != $groupgrid } {
1797                 if { $groupgrid != "" } { puts $fd "</tr>" }
1798                 set groupgrid $gg
1799                 puts $fd "<tr><td>$gg</td>"
1800             }
1801             puts $fd "<td bgcolor=\"[_html_color $status]\"><a href=\"[regsub -all { } $gg /]/${name}.html\">$name</a></td>"
1802         }
1803         if { $groupgrid != "" } { puts $fd "</tr>" }
1804         puts $fd "</table>"
1805     }
1806
1807     # put detailed log with TOC
1808     puts $fd "<hr><h1>Details</h1>"
1809     puts $fd "<div style=\"float:right; padding: 10px; border-style: solid; border-color: blue; border-width: 2px;\">"
1810
1811     # process log line-by-line
1812     set group {}
1813     set letter {}
1814     set body {}
1815     foreach line [lsort -dictionary $log] {
1816         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1817         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1818             continue
1819         }
1820
1821         # start new group
1822         if { $grp != $group } {
1823             if { $letter != "" } { lappend body "</tr></table>" }
1824             set letter {}
1825             set group $grp
1826             set grid {}
1827             puts $fd "<a href=\"#$group\">$group</a><br>"
1828             lappend body "<h2><a name=\"$group\">Group $group</a></h2>"
1829         }
1830
1831         # start new grid
1832         if { $grd != $grid } {
1833             if { $letter != "" } { lappend body "</tr></table>" }
1834             set letter {}
1835             set grid $grd
1836             puts $fd "&nbsp;&nbsp;&nbsp;&nbsp;<a href=\"#$group-$grid\">$grid</a><br>"
1837             lappend body "<h2><a name=\"$group-$grid\">Grid $group $grid</a></h2>"
1838         }
1839
1840         # check if test case name is <letter><digit>;
1841         # if not, set alnum to period "." to recognize non-standard test name
1842         if { ! [regexp {\A([A-Za-z]{1,2})([0-9]{1,2})\Z} $casename res alnum number] &&
1843              ! [regexp {\A([A-Za-z0-9]+)_([0-9]+)\Z} $casename res alnum number] } {
1844             set alnum $casename
1845         }
1846
1847         # start new row when letter changes or for non-standard names
1848         if { $alnum != $letter || $alnum == "." } {
1849             if { $letter != "" } {
1850                 lappend body "</tr><tr>"
1851             } else {
1852                 lappend body "<table><tr>"
1853             }
1854             set letter $alnum
1855         }
1856
1857         lappend body "<td bgcolor=\"[_html_color $result]\"><a href=\"$group/$grid/${casename}.html\">$casename</a></td>"
1858     }
1859     puts $fd "</div>\n[join $body "\n"]</tr></table>"
1860
1861     # add remaining lines of log as plain text
1862     puts $fd "<h2>Plain text messages</h2>\n<pre>"
1863     foreach line $log {
1864         if { ! [regexp $_test_case_regexp $line] } {
1865             puts $fd "$line"
1866         }
1867     }
1868     puts $fd "</pre>"
1869
1870     # close file and exit
1871     puts $fd "</body>"
1872     close $fd
1873     return
1874 }
1875
1876 # Procedure to dump summary logs of tests
1877 proc _log_summarize {logdir log {total_time {}}} {
1878
1879     # sort log records alphabetically to have the same behavior on Linux and Windows
1880     # (also needed if tests are run in parallel)
1881     set loglist [lsort -dictionary $log]
1882
1883     # classify test cases by status
1884     foreach line $loglist {
1885         if { [regexp {^CASE ([^:]*): ([[:alnum:]]+).*$} $line res caseid status] } {
1886             lappend stat($status) $caseid
1887         }
1888     }
1889     set totals {}
1890     set improvements {Improvements:}
1891     set regressions {Failed:}
1892     set skipped {Skipped:}
1893     if { [info exists stat] } {
1894         foreach status [lsort [array names stat]] {
1895             lappend totals [list [llength $stat($status)] $status]
1896
1897             # separately count improvements (status starting with IMP), skipped (status starting with SKIP) and regressions (all except IMP, OK, BAD, and SKIP)
1898             if { [regexp -nocase {^IMP} $status] } {
1899                 eval lappend improvements $stat($status)
1900             } elseif { [regexp -nocase {^SKIP} $status] } {
1901                 eval lappend skipped $stat($status)
1902             } elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
1903                 eval lappend regressions $stat($status)
1904             }
1905         }
1906     }
1907
1908     # if time is specified, add totals
1909     if { $total_time != "" } {
1910         if { [llength $improvements] > 1 } {
1911             _log_and_puts log [join $improvements "\n  "]
1912         }
1913         if { [llength $regressions] > 1 } {
1914             _log_and_puts log [join $regressions "\n  "]
1915         }
1916         if { [llength $skipped] > 1 } {
1917             _log_and_puts log [join $skipped "\n  "]
1918         }
1919         if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
1920             _log_and_puts log "No regressions"
1921         }
1922         _log_and_puts log "Total cases: [join $totals {, }]"
1923         _log_and_puts log $total_time
1924     }
1925
1926     # save log to files
1927     if { $logdir != "" } {
1928         _log_html_summary $logdir $log $totals $regressions $improvements $skipped $total_time
1929         _log_save $logdir/tests.log [join $log "\n"] "Tests summary"
1930     }
1931
1932     return
1933 }
1934
1935 # Internal procedure to generate XML log in JUnit style, for further
1936 # consumption by Jenkins or similar systems.
1937 #
1938 # The output is intended to conform to XML schema supported by Jenkins found at
1939 # 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
1940 #
1941 # The mapping of the fields is inspired by annotated schema of Apache Ant JUnit XML format found at
1942 # http://windyroad.org/dl/Open%20Source/JUnit.xsd
1943 proc _log_xml_summary {logdir filename log include_cout} {
1944     global _test_case_regexp
1945
1946     catch {file mkdir [file dirname $filename]}
1947
1948     # try to open a file and start XML
1949     if [catch {set fd [open $filename w]} res] {
1950         error "Error creating XML summary file $filename: $res"
1951     }
1952     puts $fd "<?xml version='1.0' encoding='utf-8'?>"
1953     puts $fd "<testsuites>"
1954
1955     # prototype for command to generate test suite tag
1956     set time_and_host "timestamp=\"[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}]\" hostname=\"[info hostname]\""
1957     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"}
1958
1959     # sort log and process it line-by-line
1960     set group {}
1961     foreach line [lsort -dictionary $log] {
1962         # check that the line is case report in the form "CASE group grid name: result (explanation)"
1963         if { ! [regexp $_test_case_regexp $line res grp grd casename result message] } {
1964             continue
1965         }
1966         set message [string trim $message " \t\r\n()"]
1967
1968         # start new testsuite for each grid
1969         if { $grp != $group || $grd != $grid } {
1970
1971             # write previous test suite
1972             if [info exists testcases] { eval $cmd_testsuite }
1973
1974             set testcases {}
1975             set nbtests 0
1976             set nberr 0
1977             set nbfail 0
1978             set nbskip 0
1979             set time 0.
1980
1981             set group $grp
1982             set grid $grd
1983         }
1984
1985         incr nbtests
1986
1987         # parse test log and get its CPU time
1988         set testout {}
1989         set add_cpu {}
1990         if { [catch {set fdlog [open $logdir/$group/$grid/${casename}.log r]} ret] } {
1991             puts "Error: cannot open $logdir/$group/$grid/${casename}.log: $ret"
1992         } else {
1993             while { [gets $fdlog logline] >= 0 } {
1994                 if { $include_cout } {
1995                     append testout "$logline\n"
1996                 }
1997                 if [regexp -nocase {TOTAL CPU TIME:\s*([\d.]+)\s*sec} $logline res cpu] {
1998                     set add_cpu " time=\"$cpu\""
1999                     set time [expr $time + $cpu]
2000                 }
2001             }
2002             close $fdlog
2003         }
2004         if { ! $include_cout } {
2005             set testout "$line\n"
2006         }
2007
2008         # record test case with its output and status
2009         # Mapping is: SKIPPED, BAD, and OK to OK, all other to failure
2010         append testcases "\n  <testcase name=\"$casename\"$add_cpu status=\"$result\">\n"
2011         append testcases "\n    <system-out>\n$testout    </system-out>"
2012         if { $result != "OK" } {
2013             if { [regexp -nocase {^SKIP} $result] } {
2014                 incr nberr
2015                 append testcases "\n    <error name=\"$result\" message=\"$message\"/>"
2016             } elseif { [regexp -nocase {^BAD} $result] } {
2017                 incr nbskip
2018                 append testcases "\n    <skipped>$message</skipped>"
2019             } else {
2020                 incr nbfail
2021                 append testcases "\n    <failure name=\"$result\" message=\"$message\"/>"
2022             }
2023         }
2024         append testcases "\n  </testcase>"
2025     }
2026
2027     # write last test suite
2028     if [info exists testcases] { eval $cmd_testsuite }
2029
2030     # the end
2031     puts $fd "</testsuites>"
2032     close $fd
2033     return
2034 }
2035
2036 # Auxiliary procedure to split path specification (usually defined by
2037 # environment variable) into list of directories or files
2038 proc _split_path {pathspec} {
2039     global tcl_platform
2040
2041     # first replace all \ (which might occur on Windows) by /
2042     regsub -all "\\\\" $pathspec "/" pathspec
2043
2044     # split path by platform-specific separator
2045     return [split $pathspec [_path_separator]]
2046 }
2047
2048 # Auxiliary procedure to define platform-specific separator for directories in
2049 # path specification
2050 proc _path_separator {} {
2051     global tcl_platform
2052
2053     # split path by platform-specific separator
2054     if { $tcl_platform(platform) == "windows" } {
2055         return ";"
2056     } else {
2057         return ":"
2058     }
2059 }
2060
2061 # Procedure to make a diff and common of two lists
2062 proc _list_diff {list1 list2 _in1 _in2 _common} {
2063     upvar $_in1 in1
2064     upvar $_in2 in2
2065     upvar $_common common
2066
2067     set in1 {}
2068     set in2 {}
2069     set common {}
2070     foreach item $list1 {
2071         if { [lsearch -exact $list2 $item] >= 0 } {
2072             lappend common $item
2073         } else {
2074             lappend in1 $item
2075         }
2076     }
2077     foreach item $list2 {
2078         if { [lsearch -exact $common $item] < 0 } {
2079             lappend in2 $item
2080         }
2081     }
2082     return
2083 }
2084
2085 # procedure to load a file to Tcl string
2086 proc _read_file {filename} {
2087     set fd [open $filename r]
2088     set result [read -nonewline $fd]
2089     close $fd
2090     return $result
2091 }
2092
2093 # procedure to construct name for the mage diff file
2094 proc _diff_img_name {dir1 dir2 casepath imgfile} {
2095     return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
2096 }
2097
2098 # auxiliary procedure to produce string comparing two values
2099 proc _diff_show_ratio {value1 value2} {
2100     if {[expr double ($value2)] == 0.} {
2101         return "$value1 / $value2"
2102     } else {
2103         return "$value1 / $value2 \[[format "%+5.2f%%" [expr 100 * ($value1 - $value2) / double($value2)]]\]"
2104     }
2105 }
2106
2107 # auxiliary procedure to produce string comparing two values, where first value is a portion of second
2108 proc _diff_show_positive_ratio {value1 value2} {
2109     if {[expr double ($value2)] == 0.} {
2110         return "$value1 / $value2"
2111     } else {
2112         return "$value1 / $value2 \[[format "%4.2f%%" [expr 100 * double($value1) / double($value2)]]\]"
2113     }
2114 }
2115
2116 # procedure to check cpu user time
2117 proc _check_time {regexp_msg} {
2118     upvar log log
2119     upvar log1 log1
2120     upvar log2 log2
2121     upvar log_cpu log_cpu
2122     upvar cpu cpu
2123     upvar basename basename
2124     upvar casename casename
2125     set time1_list [dict create]
2126     set time2_list [dict create]
2127     set cpu_find UNDEFINED
2128
2129     foreach line1 [split $log1 "\n"] {
2130         if { [regexp "${regexp_msg}" $line1 dump chronometer_name cpu_find] } {
2131             dict set time1_list "${chronometer_name}" "${cpu_find}"
2132         }
2133     }
2134
2135     foreach line2 [split $log2 "\n"] {
2136         if { [regexp "${regexp_msg}" $line2 dump chronometer_name cpu_find] } {
2137             dict set time2_list "${chronometer_name}" "${cpu_find}"
2138         }
2139     }
2140
2141     if { [llength [dict keys $time1_list]] != [llength [dict keys $time2_list]] } {
2142         puts "Error: number of dchrono/chrono COUNTER are different in the same test cases"
2143     } else {
2144         foreach key [dict keys $time1_list] {
2145             set time1 [dict get $time1_list $key]
2146             set time2 [dict get $time2_list $key]
2147
2148             # compare CPU user time with 10% precision (but not less 0.5 sec)
2149             if { [expr abs ($time1 - $time2) > 0.5 + 0.05 * abs ($time1 + $time2)] } {
2150                 if {$cpu != false} {
2151                     _log_and_puts log_cpu "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2152                 } else {
2153                     _log_and_puts log "COUNTER $key: [split $basename /] $casename: [_diff_show_ratio $time1 $time2]"
2154                 }
2155             }
2156         }
2157     }
2158 }
2159
2160 # Procedure to compare results of two runs of test cases
2161 proc _test_diff {dir1 dir2 basename image cpu memory status verbose _logvar _logimage _logcpu _logmemory {_statvar ""}} {
2162     upvar $_logvar log
2163     upvar $_logimage log_image
2164     upvar $_logcpu log_cpu
2165     upvar $_logmemory log_memory
2166
2167     # make sure to load diffimage command
2168     uplevel pload VISUALIZATION
2169
2170     # prepare variable (array) for collecting statistics
2171     if { "$_statvar" != "" } {
2172         upvar $_statvar stat
2173     } else {
2174         set stat(cpu1) 0
2175         set stat(cpu2) 0
2176         set stat(mem1) 0
2177         set stat(mem2) 0
2178         set stat(img1) 0
2179         set stat(img2) 0
2180         set log {}
2181         set log_image {}
2182         set log_cpu {}
2183         set log_memory {}
2184     }
2185
2186     # first check subdirectories
2187     set path1 [file join $dir1 $basename]
2188     set path2 [file join $dir2 $basename]
2189     set list1 [glob -directory $path1 -types d -tails -nocomplain *]
2190     set list2 [glob -directory $path2 -types d -tails -nocomplain *]
2191     if { [llength $list1] >0 || [llength $list2] > 0 } {
2192         _list_diff $list1 $list2 in1 in2 common
2193         if { "$verbose" > 1 } {
2194             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2195             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2196         }
2197         foreach subdir $common {
2198             if { "$verbose" > 2 } {
2199                 _log_and_puts log "Checking [file join $basename $subdir]"
2200             }
2201             _test_diff $dir1 $dir2 [file join $basename $subdir] $image $cpu $memory $status $verbose log log_image log_cpu log_memory stat
2202         }
2203     } else {
2204         # check log files (only if directory has no subdirs)
2205         set list1 [glob -directory $path1 -types f -tails -nocomplain *.log]
2206         set list2 [glob -directory $path2 -types f -tails -nocomplain *.log]
2207         _list_diff $list1 $list2 in1 in2 common
2208         if { "$verbose" > 1 } {
2209             if { [llength $in1] > 0 } { _log_and_puts log "Only in $path1: $in1" }
2210             if { [llength $in2] > 0 } { _log_and_puts log "Only in $path2: $in2" }
2211         }
2212         set gcpu1 0
2213         set gcpu2 0
2214         set gmem1 0
2215         set gmem2 0
2216         foreach logfile $common {
2217             # load two logs
2218             set log1 [_read_file [file join $dir1 $basename $logfile]]
2219             set log2 [_read_file [file join $dir2 $basename $logfile]]
2220             set casename [file rootname $logfile]
2221
2222             # check execution statuses
2223             if {$image == false && $cpu == false && $memory == false} {
2224                 set status1 UNDEFINED
2225                 set status2 UNDEFINED
2226                 if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
2227                     ! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
2228                     "$status1" != "$status2" } {
2229                     _log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
2230                     # if test statuses are different, further comparison makes
2231                     # no sense unless explicitly requested
2232                     if { "$status" != "all" } {
2233                         continue
2234                     }
2235                 }
2236                 if { "$status" == "ok" && "$status1" != "OK" } {
2237                     continue
2238                 }
2239             }
2240
2241             if { ! $image } {
2242                 # check CPU user time in test cases
2243                 set checkCPURegexp "COUNTER (.+): (\[-0-9.+eE\]+)"
2244                 if { [regexp "${checkCPURegexp}" $log1] &&
2245                      [regexp "${checkCPURegexp}" $log2] } {
2246                   _check_time "${checkCPURegexp}"
2247                 }
2248             }
2249
2250             # check CPU times
2251             if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2252                 set cpu1 UNDEFINED
2253                 set cpu2 UNDEFINED
2254                 if { [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log1 res1 cpu1] &&
2255                      [regexp {TOTAL CPU TIME:\s*([\d.]+)} $log2 res1 cpu2] } {
2256                     set stat(cpu1) [expr $stat(cpu1) + $cpu1]
2257                     set stat(cpu2) [expr $stat(cpu2) + $cpu2]
2258                     set gcpu1 [expr $gcpu1 + $cpu1]
2259                     set gcpu2 [expr $gcpu2 + $cpu2]
2260
2261                     # compare CPU times with 10% precision (but not less 0.5 sec)
2262                     if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
2263                         if {$cpu != false} {
2264                             _log_and_puts log_cpu "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2265                         } else {
2266                             _log_and_puts log "CPU [split $basename /] $casename: [_diff_show_ratio $cpu1 $cpu2]"
2267                         }
2268                     }
2269                 }
2270             }
2271
2272             # check memory delta
2273             if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2274                 set mem1 UNDEFINED
2275                 set mem2 UNDEFINED
2276                 if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
2277                      [regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
2278                     set stat(mem1) [expr $stat(mem1) + $mem1]
2279                     set stat(mem2) [expr $stat(mem2) + $mem2]
2280                     set gmem1 [expr $gmem1 + $mem1]
2281                     set gmem2 [expr $gmem2 + $mem2]
2282
2283                     # compare memory usage with 10% precision (but not less 16 KiB)
2284                     if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
2285                         if {$memory != false} {
2286                             _log_and_puts log_memory "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2287                         } else {
2288                             _log_and_puts log "MEMORY [split $basename /] $casename: [_diff_show_ratio $mem1 $mem2]"
2289                         }
2290                     }
2291                 }
2292             }
2293
2294             # check images
2295             if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2296                 set aCaseDiffColorTol 0
2297                 if { [regexp {IMAGE_COLOR_TOLERANCE:\s*([\d.]+)} $log1 res1 imgtol1] } { set aCaseDiffColorTol $imgtol1 }
2298                 set imglist1 [glob -directory $path1 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2299                 set imglist2 [glob -directory $path2 -types f -tails -nocomplain ${casename}.{png,gif} ${casename}-*.{png,gif} ${casename}_*.{png,gif}]
2300                 _list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
2301                 if { "$verbose" > 1 } {
2302                     # Differences in image lists might reflect changes in test case or in list of tests (new/removed test cases),
2303                     # but might also reflect image dump failures.
2304                     if { [llength $imgin1] > 0 } {
2305                         set stat(img1) [expr $stat(img1) + [llength $imgin1]]
2306                         set stat(img2) [expr $stat(img2) + [llength $imgin1]]
2307                         if {$image != false} {
2308                             _log_and_puts log_image "Only in $path1: $imgin1"
2309                         } else {
2310                             _log_and_puts log "Only in $path1: $imgin1"
2311                         }
2312                     }
2313                     if { [llength $imgin2] > 0 } {
2314                         set stat(img1) [expr $stat(img1) + [llength $imgin2]]
2315                         if {$image != false} {
2316                             _log_and_puts log_image "Only in $path2: $imgin2"
2317                         } else {
2318                             _log_and_puts log "Only in $path2: $imgin2"
2319                         }
2320                     }
2321                 }
2322
2323                 foreach imgfile $imgcommon {
2324                     set stat(img2) [expr $stat(img2) + 1]
2325                     # if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
2326                     set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
2327                     if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2328                                            [file join $dir2 $basename $imgfile] \
2329                                            -toleranceOfColor 0.0 -blackWhite off -borderFilter off $diffile} diff] } {
2330                         set stat(img1) [expr $stat(img1) + 1]
2331                         if {$image != false} {
2332                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2333                         } else {
2334                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2335                         }
2336                         file delete -force $diffile ;# clean possible previous result of diffimage
2337                     } elseif { $diff != 0 } {
2338                         set diff [string trimright $diff \n]
2339                         if {$aCaseDiffColorTol != 0} {
2340                             # retry with color tolerance
2341                             if { [catch {diffimage [file join $dir1 $basename $imgfile] \
2342                                                    [file join $dir2 $basename $imgfile] \
2343                                                    -toleranceOfColor $aCaseDiffColorTol -blackWhite off -borderFilter off $diffile} diff2] } {
2344                                 set stat(img1) [expr $stat(img1) + 1]
2345                                 if {$image != false} {
2346                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2347                                 } else {
2348                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
2349                                 }
2350                                 continue
2351                             } elseif { $diff2 == 0 } {
2352                                 # exclude image diff within tolerance but still keep info in the log
2353                                 set toLogImageCase false
2354                                 file delete -force $diffile
2355                                 set stat(img1) [expr $stat(img1) + 1]
2356                                 if {$image != false} {
2357                                     _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2358                                 } else {
2359                                     _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile is similar \[$diff different pixels\]"
2360                                 }
2361                                 continue
2362                             }
2363                         }
2364
2365                         set stat(img1) [expr $stat(img1) + 1]
2366                         if {$image != false} {
2367                             _log_and_puts log_image "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2368                         } else {
2369                             _log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs \[$diff different pixels\]"
2370                         }
2371                     } else {
2372                         file delete -force $diffile ;# clean useless artifact of diffimage
2373                     }
2374                 }
2375             }
2376         }
2377
2378         # report CPU and memory difference in group if it is greater than 10%
2379         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2380             if { [expr abs ($gcpu1 - $gcpu2) > 0.5 + 0.005 * abs ($gcpu1 + $gcpu2)] } {
2381                 if {$cpu != false} {
2382                     _log_and_puts log_cpu "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2383                 } else {
2384                     _log_and_puts log "CPU [split $basename /]: [_diff_show_ratio $gcpu1 $gcpu2]"
2385                 }
2386             }
2387         }
2388         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2389             if { [expr abs ($gmem1 - $gmem2) > 16 + 0.005 * abs ($gmem1 + $gmem2)] } {
2390                 if {$memory != false} {
2391                     _log_and_puts log_memory "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2392                 } else {
2393                     _log_and_puts log "MEMORY [split $basename /]: [_diff_show_ratio $gmem1 $gmem2]"
2394                 }
2395             }
2396         }
2397     }
2398
2399     if { "$_statvar" == "" } {
2400         if {$memory != false || ($image == false && $cpu == false && $memory == false)} {
2401             if {$memory != false} {
2402                 _log_and_puts log_memory "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2403             } else {
2404                 _log_and_puts log "Total MEMORY difference: [_diff_show_ratio $stat(mem1) $stat(mem2)]"
2405             }
2406         }
2407         if {$cpu != false || ($image == false && $cpu == false && $memory == false)} {
2408             if {$cpu != false} {
2409                 _log_and_puts log_cpu "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2410             } else {
2411                 _log_and_puts log "Total CPU difference: [_diff_show_ratio $stat(cpu1) $stat(cpu2)]"
2412             }
2413         }
2414         if {$image != false || ($image == false && $cpu == false && $memory == false)} {
2415             if {$image != false} {
2416                 _log_and_puts log_image "Total IMAGE difference: [_diff_show_positive_ratio $stat(img1) $stat(img2)]"
2417             } else {
2418                 _log_and_puts log "Total IMAGE difference: [_diff_show_positive_ratio $stat(img1) $stat(img2)]"
2419             }
2420         }
2421     }
2422 }
2423
2424 # Auxiliary procedure to save log of results comparison to file
2425 proc _log_html_diff {file log dir1 dir2 highlight_percent} {
2426     # create missing directories as needed
2427     catch {file mkdir [file dirname $file]}
2428
2429     # try to open a file
2430     if [catch {set fd [open $file w]} res] {
2431         error "Error saving log file $file: $res"
2432     }
2433
2434     # print header
2435     puts $fd "<html><head><meta http-equiv='Content-Type' content='text/html; charset=utf-8'/>"
2436     puts $fd "<title>Diff $dir1 vs. $dir2</title></head><body>"
2437     puts $fd "<h1>Comparison of test results:</h1>"
2438     puts $fd "<h2>Version A \[NEW\] - $dir1</h2>"
2439     puts $fd "<h2>Version B \[REF\] - $dir2</h2>"
2440
2441     # add script for switching between images on click
2442     puts $fd ""
2443     puts $fd "<script type=\"text/javascript\">"
2444     puts $fd "  function diffimage_toggle(img,url1,url2)"
2445     puts $fd "  {"
2446     puts $fd "    if (img.show2nd) { img.src = url1; img.show2nd = false; }"
2447     puts $fd "    else { img.src = url2; img.show2nd = true; }"
2448     puts $fd "  }"
2449     puts $fd "  function diffimage_reset(img,url) { img.src = url; img.show2nd = true; }"
2450     puts $fd "</script>"
2451     puts $fd ""
2452
2453     # print log body
2454     puts $fd "<pre>"
2455     set logpath [file split [file normalize $file]]
2456     foreach line $log {
2457         # put a line; highlight considerable (> ${highlight_percent}%) deviations of CPU and memory
2458         if { [regexp "\[\\\[](\[0-9.e+-]+)%\[\]]" $line res value] &&
2459              [expr abs($value)] > ${highlight_percent} } {
2460             puts $fd "<table><tr><td bgcolor=\"[expr $value > 0 ? \"ff8080\" : \"lightgreen\"]\">$line</td></tr></table>"
2461         } elseif { [regexp {^IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+) is similar} $line res case img] } {
2462             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2463                 # note: special handler for the case if test grid directoried are compared directly
2464                 set gridpath ""
2465             }
2466             set aCaseName [lindex $case end]
2467             puts $fd "<table><tr><td bgcolor=\"orange\"><a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\">$line</a></td></tr></table>"
2468         } elseif { [regexp {^IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
2469             # add images
2470             puts $fd $line
2471             if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
2472                 # note: special handler for the case if test grid directoried are compared directly
2473                 set gridpath ""
2474             }
2475             set aCaseName [lindex $case end]
2476             set img1url [_make_url $file [file join $dir1 $gridpath $img]]
2477             set img2url [_make_url $file [file join $dir2 $gridpath $img]]
2478             set img1 "<a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\"><img src=\"$img1url\"></a>"
2479             set img2 "<a href=\"[_make_url $file [file join $dir2 $gridpath $aCaseName.html]]\"><img src=\"$img2url\"></a>"
2480
2481             set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
2482             set imgdurl [_make_url $file $difffile]
2483             if { [file exists $difffile] } {
2484                 set imgd "<img src=\"$imgdurl\" onmouseout=diffimage_reset(this,\"$imgdurl\") onclick=diffimage_toggle(this,\"$img1url\",\"$img2url\")>"
2485             } else {
2486                 set imgd "N/A"
2487             }
2488
2489             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>"
2490             puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
2491         } else {
2492             puts $fd $line
2493         }
2494     }
2495     puts $fd "</pre></body></html>"
2496
2497     close $fd
2498     return
2499 }
2500
2501 # get number of CPUs on the system
2502 proc _get_nb_cpus {} {
2503     global tcl_platform env
2504
2505     if { "$tcl_platform(platform)" == "windows" } {
2506         # on Windows, take the value of the environment variable
2507         if { [info exists env(NUMBER_OF_PROCESSORS)] &&
2508              ! [catch {expr $env(NUMBER_OF_PROCESSORS) > 0} res] && $res >= 0 } {
2509             return $env(NUMBER_OF_PROCESSORS)
2510         }
2511     } elseif { "$tcl_platform(os)" == "Linux" } {
2512         # on Linux, take number of logical processors listed in /proc/cpuinfo
2513         if { [catch {open "/proc/cpuinfo" r} fd] } {
2514             return 0 ;# should never happen, but...
2515         }
2516         set nb 0
2517         while { [gets $fd line] >= 0 } {
2518             if { [regexp {^processor[ \t]*:} $line] } {
2519                 incr nb
2520             }
2521         }
2522         close $fd
2523         return $nb
2524     } elseif { "$tcl_platform(os)" == "Darwin" } {
2525         # on MacOS X, call sysctl command
2526         if { ! [catch {exec sysctl hw.ncpu} ret] &&
2527              [regexp {^hw[.]ncpu[ \t]*:[ \t]*([0-9]+)} $ret res nb] } {
2528             return $nb
2529         }
2530     }
2531
2532     # if cannot get good value, return 0 as default
2533     return 0
2534 }
2535
2536 # check two files for difference
2537 proc _diff_files {file1 file2} {
2538     set fd1 [open $file1 "r"]
2539     set fd2 [open $file2 "r"]
2540
2541     set differ f
2542     while {! $differ} {
2543         set nb1 [gets $fd1 line1]
2544         set nb2 [gets $fd2 line2]
2545         if { $nb1 != $nb2 } { set differ t; break }
2546         if { $nb1 < 0 } { break }
2547         if { [string compare $line1 $line2] } {
2548             set differ t
2549         }
2550     }
2551
2552     close $fd1
2553     close $fd2
2554
2555     return $differ
2556 }
2557
2558 # Check if file is in DOS encoding.
2559 # This check is done by presence of \r\n combination at the end of the first
2560 # line (i.e. prior to any other \n symbol).
2561 # Note that presence of non-ascii symbols typically used for recognition
2562 # of binary files is not suitable since some IGES and STEP files contain
2563 # non-ascii symbols.
2564 # Special check is added for PNG files which contain \r\n in the beginning.
2565 proc _check_dos_encoding {file} {
2566     set fd [open $file rb]
2567     set isdos f
2568     if { [gets $fd line] && [regexp {.*\r$} $line] &&
2569          ! [regexp {^.PNG} $line] } {
2570         set isdos t
2571     }
2572     close $fd
2573     return $isdos
2574 }
2575
2576 # procedure to recognize format of a data file by its first symbols (for OCCT
2577 # BREP and geometry DRAW formats, IGES, and STEP) and extension (all others)
2578 proc _check_file_format {file} {
2579     set fd [open $file rb]
2580     set line [read $fd 1024]
2581     close $fd
2582
2583     set warn f
2584     set ext [file extension $file]
2585     set format unknown
2586     if { [regexp {^DBRep_DrawableShape} $line] } {
2587         set format BREP
2588         if { "$ext" != ".brep" && "$ext" != ".rle" &&
2589              "$ext" != ".draw" && "$ext" != "" } {
2590             set warn t
2591         }
2592     } elseif { [regexp {^DrawTrSurf_} $line] } {
2593         set format DRAW
2594         if { "$ext" != ".rle" &&
2595              "$ext" != ".draw" && "$ext" != "" } {
2596             set warn t
2597         }
2598     } elseif { [regexp {^[ \t]*ISO-10303-21} $line] } {
2599         set format STEP
2600         if { "$ext" != ".step" && "$ext" != ".stp" } {
2601             set warn t
2602         }
2603     } elseif { [regexp {^.\{72\}S[0 ]\{6\}1} $line] } {
2604         set format IGES
2605         if { "$ext" != ".iges" && "$ext" != ".igs" } {
2606             set warn t
2607         }
2608     } elseif { "$ext" == ".igs" } {
2609         set format IGES
2610     } elseif { "$ext" == ".stp" } {
2611         set format STEP
2612     } else {
2613         set format [string toupper [string range $ext 1 end]]
2614     }
2615
2616     if { $warn } {
2617         puts "$file: Warning: extension ($ext) does not match format ($format)"
2618     }
2619
2620     return $format
2621 }
2622
2623 # procedure to load file knowing its format
2624 proc load_data_file {file format shape} {
2625     switch $format {
2626         BREP { uplevel restore $file $shape }
2627         DRAW { uplevel restore $file $shape }
2628         IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
2629         STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
2630         STL  { pload XSDRAW; uplevel readstl $shape $file triangulation }
2631         default { error "Cannot read $format file $file" }
2632     }
2633 }
2634
2635 # procedure to get name of temporary directory,
2636 # ensuring it is existing and writeable
2637 proc _get_temp_dir {} {
2638     global env tcl_platform
2639
2640     # check typical environment variables
2641     foreach var {TempDir Temp Tmp} {
2642         # check different case
2643         foreach name [list [string toupper $var] $var [string tolower $var]] {
2644             if { [info exists env($name)] && [file isdirectory $env($name)] &&
2645                  [file writable $env($name)] } {
2646                 return [regsub -all {\\} $env($name) /]
2647             }
2648         }
2649     }
2650
2651     # check platform-specific locations
2652     set fallback tmp
2653     if { "$tcl_platform(platform)" == "windows" } {
2654         set paths "c:/TEMP c:/TMP /TEMP /TMP"
2655         if { [info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)] } {
2656             set fallback [regsub -all {\\} "$env(HOMEDRIVE)$env(HOMEPATH)/tmp" /]
2657         }
2658     } else {
2659         set paths "/tmp /var/tmp /usr/tmp"
2660         if { [info exists env(HOME)] } {
2661             set fallback "$env(HOME)/tmp"
2662         }
2663     }
2664     foreach dir $paths {
2665         if { [file isdirectory $dir] && [file writable $dir] } {
2666             return $dir
2667         }
2668     }
2669
2670     # fallback case: use subdir /tmp of home or current dir
2671     file mkdir $fallback
2672     return $fallback
2673 }
2674
2675 # extract of code from testgrid command used to process jobs running in
2676 # parallel until number of jobs in the queue becomes equal or less than
2677 # specified value
2678 proc _testgrid_process_jobs {worker {nb_ok 0}} {
2679     # bind local vars to variables of the caller procedure
2680     upvar log log
2681     upvar logdir logdir
2682     upvar job_def job_def
2683     upvar nbpooled nbpooled
2684     upvar userbreak userbreak
2685     upvar refresh refresh
2686     upvar refresh_timer refresh_timer
2687
2688     catch {tpool::resume $worker}
2689     while { ! $userbreak && $nbpooled > $nb_ok } {
2690         foreach job [tpool::wait $worker [array names job_def]] {
2691             eval _log_test_case \[tpool::get $worker $job\] $job_def($job) log
2692             unset job_def($job)
2693             incr nbpooled -1
2694         }
2695
2696         # check for user break
2697         if { "[info commands dbreak]" == "dbreak" && [catch dbreak] } {
2698             set userbreak 1
2699         }
2700
2701         # update summary log with requested period
2702         if { $logdir != "" && $refresh > 0 && [clock seconds] > $refresh_timer + $refresh } {
2703             _log_summarize $logdir $log
2704             set refresh_timer [clock seconds]
2705         }
2706     }
2707     catch {tpool::suspend $worker}
2708 }
2709
2710 help checkcolor {
2711   Check pixel color.
2712   Use: checkcolor x y red green blue
2713   x y - pixel coordinates
2714   red green blue - expected pixel color (values from 0 to 1)
2715   Function check color with tolerance (5x5 area)
2716 }
2717 # Procedure to check color using command vreadpixel with tolerance
2718 proc checkcolor { coord_x coord_y rd_get gr_get bl_get } {
2719     puts "Coordinate x = $coord_x"
2720     puts "Coordinate y = $coord_y"
2721     puts "RED color of RGB is $rd_get"
2722     puts "GREEN color of RGB is $gr_get"
2723     puts "BLUE color of RGB is $bl_get"
2724
2725     if { $coord_x <= 1 || $coord_y <= 1 } {
2726         puts "Error : minimal coordinate is x = 2, y = 2. But we have x = $coord_x y = $coord_y"
2727         return -1
2728     }
2729
2730     set color ""
2731     catch { [set color "[vreadpixel ${coord_x} ${coord_y} rgb]"] }
2732     if {"$color" == ""} {
2733         puts "Error : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2734     }
2735     set rd [lindex $color 0]
2736     set gr [lindex $color 1]
2737     set bl [lindex $color 2]
2738     set rd_int [expr int($rd * 1.e+05)]
2739     set gr_int [expr int($gr * 1.e+05)]
2740     set bl_int [expr int($bl * 1.e+05)]
2741     set rd_ch [expr int($rd_get * 1.e+05)]
2742     set gr_ch [expr int($gr_get * 1.e+05)]
2743     set bl_ch [expr int($bl_get * 1.e+05)]
2744
2745     if { $rd_ch != 0 } {
2746         set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2747     } else {
2748         set tol_rd $rd_int
2749     }
2750     if { $gr_ch != 0 } {
2751         set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2752     } else {
2753         set tol_gr $gr_int
2754     }
2755     if { $bl_ch != 0 } {
2756         set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2757     } else {
2758         set tol_bl $bl_int
2759     }
2760
2761     set status 0
2762     if { $tol_rd > 0.2 } {
2763         puts "Warning : RED light of additive color model RGB is invalid"
2764         set status 1
2765     }
2766     if { $tol_gr > 0.2 } {
2767         puts "Warning : GREEN light of additive color model RGB is invalid"
2768         set status 1
2769     }
2770     if { $tol_bl > 0.2 } {
2771         puts "Warning : BLUE light of additive color model RGB is invalid"
2772         set status 1
2773     }
2774
2775     if { $status != 0 } {
2776         puts "Warning : Colors of default coordinate are not equal"
2777     }
2778
2779     global stat
2780     if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2781         set info [_checkpoint $coord_x $coord_y $rd_ch $gr_ch $bl_ch]
2782         set stat [lindex $info end]
2783         if { ${stat} != 1 } {
2784             puts "Error : Colors are not equal in default coordinate and in the near coordinates too"
2785             return $stat
2786         } else {
2787             puts "Point with valid color was found"
2788             return $stat
2789         }
2790     } else {
2791         set stat 1
2792     }
2793 }
2794
2795 # Procedure to check color in the point near default coordinate
2796 proc _checkpoint {coord_x coord_y rd_ch gr_ch bl_ch} {
2797     set x_start [expr ${coord_x} - 2]
2798     set y_start [expr ${coord_y} - 2]
2799     set mistake 0
2800     set i 0
2801     while { $mistake != 1 && $i <= 5 } {
2802         set j 0
2803         while { $mistake != 1 && $j <= 5 } {
2804             set position_x [expr ${x_start} + $j]
2805             set position_y [expr ${y_start} + $i]
2806             puts $position_x
2807             puts $position_y
2808
2809             set color ""
2810             catch { [set color "[vreadpixel ${position_x} ${position_y} rgb]"] }
2811             if {"$color" == ""} {
2812                 puts "Warning : Pixel coordinates (${position_x}; ${position_y}) are out of view"
2813                 incr j
2814                 continue
2815             }
2816             set rd [lindex $color 0]
2817             set gr [lindex $color 1]
2818             set bl [lindex $color 2]
2819             set rd_int [expr int($rd * 1.e+05)]
2820             set gr_int [expr int($gr * 1.e+05)]
2821             set bl_int [expr int($bl * 1.e+05)]
2822
2823             if { $rd_ch != 0 } {
2824                 set tol_rd [expr abs($rd_ch - $rd_int)/$rd_ch]
2825             } else {
2826                 set tol_rd $rd_int
2827             }
2828             if { $gr_ch != 0 } {
2829                 set tol_gr [expr abs($gr_ch - $gr_int)/$gr_ch]
2830             } else {
2831                 set tol_gr $gr_int
2832             }
2833             if { $bl_ch != 0 } {
2834                 set tol_bl [expr abs($bl_ch - $bl_int)/$bl_ch]
2835             } else {
2836                 set tol_bl $bl_int
2837             }
2838
2839             if { $tol_rd > 0.2 || $tol_gr > 0.2 || $tol_bl > 0.2 } {
2840                 puts "Warning : Point with true color was not found near default coordinates"
2841                 set mistake 0
2842             } else {
2843                 set mistake 1
2844             }
2845             incr j
2846         }
2847         incr i
2848     }
2849     return $mistake
2850 }
2851
2852 # Procedure to check if sequence of values in listval follows linear trend
2853 # adding the same delta on each step.
2854 #
2855 # The function does statistical estimation of the mean variation of the
2856 # values of the sequence, and dispersion, and returns true only if both
2857 # dispersion and deviation of the mean from expected delta are within
2858 # specified tolerance.
2859 #
2860 # If mean variation differs from expected delta on more than two dispersions,
2861 # the check fails and procedure raises error with specified message.
2862 #
2863 # Otherwise the procedure returns false meaning that more iterations are needed.
2864 # Note that false is returned in any case if length of listval is less than 3.
2865 #
2866 # See example of use to check memory leaks in bugs/caf/bug23489
2867 #
2868 proc checktrend {listval delta tolerance message} {
2869     set nbval [llength $listval]
2870     if { $nbval < 3} {
2871         return 0
2872     }
2873
2874     # calculate mean value
2875     set mean 0.
2876     set prev [lindex $listval 0]
2877     foreach val [lrange $listval 1 end] {
2878         set mean [expr $mean + ($val - $prev)]
2879         set prev $val
2880     }
2881     set mean [expr $mean / ($nbval - 1)]
2882
2883     # calculate dispersion
2884     set sigma 0.
2885     set prev [lindex $listval 0]
2886     foreach val [lrange $listval 1 end] {
2887         set d [expr ($val - $prev) - $mean]
2888         set sigma [expr $sigma + $d * $d]
2889         set prev $val
2890     }
2891     set sigma [expr sqrt ($sigma / ($nbval - 2))]
2892
2893     puts "Checking trend: nb = $nbval, mean delta = $mean, sigma = $sigma"
2894
2895     # check if deviation is definitely too big
2896     if { abs ($mean - $delta) > $tolerance + 2. * $sigma } {
2897         puts "Checking trend failed: mean delta per step = $mean, sigma = $sigma, expected delta = $delta"
2898         error "$message"
2899     }
2900
2901     # check if deviation is clearly within a range
2902     return [expr abs ($mean - $delta) <= $sigma && $sigma <= $tolerance]
2903 }