mirror of
https://git.dev.opencascade.org/repos/occt.git
synced 2025-04-05 18:16:23 +03:00
0023372: "diffimage" using in tests commands
Comparison of images is implemented in testdiff command; output in HTML form generated Add measurement of memory (working set) delta in test case execution Add memory statistics to output of testdiff command Treatment of parameter -outdir of command testgrid corrected. Function locate_data_file and code to run tests in parallel revised to be usable with Tcl 8.4. Added function testsummarize: regenerate summary log of tests from test case logs Command testdiff is protected against exception raised by diffimage if images have different formats
This commit is contained in:
abv
parent
9ced84ff2d
commit
22db40ebf1
@ -425,22 +425,68 @@ proc testgrid {args} {
|
|||||||
return
|
return
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Procedure to regenerate summary log from logs of test cases
|
||||||
|
help testsummarize {
|
||||||
|
Regenerate summary log in the test directory from logs of test cases.
|
||||||
|
This can be necessary if test grids are executed separately (e.g. on
|
||||||
|
different stations) or some grids have been re-executed.
|
||||||
|
Use: testsummarize dir
|
||||||
|
}
|
||||||
|
proc testsummarize {dir} {
|
||||||
|
global _test_case_regexp
|
||||||
|
|
||||||
|
if { ! [file isdirectory $dir] } {
|
||||||
|
error "Error: \"$dir\" is not a directory"
|
||||||
|
}
|
||||||
|
|
||||||
|
# get summary statements from all test cases in one log
|
||||||
|
set log ""
|
||||||
|
|
||||||
|
# to avoid huge listing of logs, first find all subdirectories and iterate
|
||||||
|
# by them, parsing log files in each subdirectory independently
|
||||||
|
foreach grid [glob -directory $dir -types d -tails */*] {
|
||||||
|
foreach caselog [glob -nocomplain -directory [file join $dir $grid] -types f -tails *.log] {
|
||||||
|
set file [file join $dir $grid $caselog]
|
||||||
|
set nbfound 0
|
||||||
|
set fd [open $file r]
|
||||||
|
while { [gets $fd line] >= 0 } {
|
||||||
|
if { [regexp $_test_case_regexp $line res grp grd cas status message] } {
|
||||||
|
if { "[file join $grid $caselog]" != "[file join $grp $grd ${cas}.log]" } {
|
||||||
|
puts "Error: $file contains status line for another test case ($line)"
|
||||||
|
}
|
||||||
|
set log "$log$line\n"
|
||||||
|
incr nbfound
|
||||||
|
}
|
||||||
|
}
|
||||||
|
close $fd
|
||||||
|
|
||||||
|
if { $nbfound != 1 } {
|
||||||
|
puts "Error: $file contains $nbfound status lines, expected 1"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
_log_summarize $dir $log "Summary regenerated from logs at [clock format [clock seconds]]"
|
||||||
|
return
|
||||||
|
}
|
||||||
|
|
||||||
# Procedure to compare results of two runs of test cases
|
# Procedure to compare results of two runs of test cases
|
||||||
help testdiff {
|
help testdiff {
|
||||||
Compare results of two executions of tests (CPU times, ...)
|
Compare results of two executions of tests (CPU times, ...)
|
||||||
Use: testdiff dir1 dir2 [options...]
|
Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
|
||||||
Where dir1 and dir2 are directories containing logs of two test runs.
|
Where dir1 and dir2 are directories containing logs of two test runs.
|
||||||
Allowed options are:
|
Allowed options are:
|
||||||
-save filename: save resulting log in specified file
|
-save filename: save resulting log in specified file (default name is
|
||||||
-subdir name: compare only specified subdirectory (can be nested)
|
\$dir1/diff-\$dir2.log); HTML log is saved with same name
|
||||||
|
and extension .html
|
||||||
-status {same|ok|all}: filter cases for comparing by their status:
|
-status {same|ok|all}: filter cases for comparing by their status:
|
||||||
same - only cases with same status are compared (default)
|
same - only cases with same status are compared (default)
|
||||||
ok - only cases with OK status in both logs are compared
|
ok - only cases with OK status in both logs are compared
|
||||||
all - results are compared regardless of status
|
all - results are compared regardless of status
|
||||||
-verbose level:
|
-verbose level:
|
||||||
1 - output only differences
|
1 - output only differences
|
||||||
2 - output list of logs and directories present in one of dirs only
|
2 - output also list of logs and directories present in one of dirs only
|
||||||
3 - (default) output progress messages
|
3 - (default) output also progress messages
|
||||||
}
|
}
|
||||||
proc testdiff {dir1 dir2 args} {
|
proc testdiff {dir1 dir2 args} {
|
||||||
if { "$dir1" == "$dir2" } {
|
if { "$dir1" == "$dir2" } {
|
||||||
@ -452,7 +498,7 @@ proc testdiff {dir1 dir2 args} {
|
|||||||
######################################################
|
######################################################
|
||||||
|
|
||||||
# treat options
|
# treat options
|
||||||
set logfile ""
|
set logfile [file join $dir1 "diff-[file tail $dir2].log"]
|
||||||
set basename ""
|
set basename ""
|
||||||
set status "same"
|
set status "same"
|
||||||
set verbose 3
|
set verbose 3
|
||||||
@ -462,7 +508,7 @@ proc testdiff {dir1 dir2 args} {
|
|||||||
# log file name
|
# log file name
|
||||||
if { $arg == "-save" } {
|
if { $arg == "-save" } {
|
||||||
incr narg
|
incr narg
|
||||||
if { $narg < [llength $args] } {
|
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||||
set logfile [lindex $args $narg]
|
set logfile [lindex $args $narg]
|
||||||
} else {
|
} else {
|
||||||
error "Error: Option -save must be followed by log file name"
|
error "Error: Option -save must be followed by log file name"
|
||||||
@ -470,21 +516,10 @@ proc testdiff {dir1 dir2 args} {
|
|||||||
continue
|
continue
|
||||||
}
|
}
|
||||||
|
|
||||||
# subdirectory to compare
|
|
||||||
if { $arg == "-subdir" } {
|
|
||||||
incr narg
|
|
||||||
if { $narg < [llength $args] } {
|
|
||||||
set basename [lindex $args $narg]
|
|
||||||
} else {
|
|
||||||
error "Error: Option -subdir must be followed by subdirectory path"
|
|
||||||
}
|
|
||||||
continue
|
|
||||||
}
|
|
||||||
|
|
||||||
# status filter
|
# status filter
|
||||||
if { $arg == "-status" } {
|
if { $arg == "-status" } {
|
||||||
incr narg
|
incr narg
|
||||||
if { $narg < [llength $args] } {
|
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||||
set status [lindex $args $narg]
|
set status [lindex $args $narg]
|
||||||
} else { set status "" }
|
} else { set status "" }
|
||||||
if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
|
if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
|
||||||
@ -496,15 +531,20 @@ proc testdiff {dir1 dir2 args} {
|
|||||||
# verbose level
|
# verbose level
|
||||||
if { $arg == "-verbose" } {
|
if { $arg == "-verbose" } {
|
||||||
incr narg
|
incr narg
|
||||||
if { $narg < [llength $args] } {
|
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||||
set verbose [expr [lindex $args $narg]]
|
set verbose [expr [lindex $args $narg]]
|
||||||
|
} else {
|
||||||
|
error "Error: Option -verbose must be followed by integer verbose level"
|
||||||
}
|
}
|
||||||
continue
|
continue
|
||||||
}
|
}
|
||||||
|
|
||||||
# if { [regexp {^-} $arg] } {
|
if { [regexp {^-} $arg] } {
|
||||||
error "Error: unsupported option \"$arg\""
|
error "Error: unsupported option \"$arg\""
|
||||||
# }
|
}
|
||||||
|
|
||||||
|
# non-option arguments form a subdirectory path
|
||||||
|
set basename [file join $basename $arg]
|
||||||
}
|
}
|
||||||
|
|
||||||
# run diff procedure (recursive)
|
# run diff procedure (recursive)
|
||||||
@ -513,11 +553,57 @@ proc testdiff {dir1 dir2 args} {
|
|||||||
# save result to log file
|
# save result to log file
|
||||||
if { "$logfile" != "" } {
|
if { "$logfile" != "" } {
|
||||||
_log_save $logfile $log
|
_log_save $logfile $log
|
||||||
|
_log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2
|
||||||
|
puts "Log is saved to $logfile (and .html)"
|
||||||
}
|
}
|
||||||
|
|
||||||
return
|
return
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Procedure to locate data file for test given its name.
|
||||||
|
# The search is performed assuming that the function is called
|
||||||
|
# from the test case script; the search order is:
|
||||||
|
# - subdirectory "data" of the test script (grid) folder
|
||||||
|
# - subdirectories in environment variable CSF_TestDataPath
|
||||||
|
# - subdirectory set by datadir command
|
||||||
|
# If file is not found, raises Tcl error.
|
||||||
|
proc locate_data_file {filename} {
|
||||||
|
global env groupname gridname casename
|
||||||
|
|
||||||
|
# check if the file is located in the subdirectory data of the script dir
|
||||||
|
set scriptfile [info script]
|
||||||
|
if { $scriptfile != "" } {
|
||||||
|
set path [file join [file dirname $scriptfile] data $filename]
|
||||||
|
if { [file exists $path] } {
|
||||||
|
return [file normalize $path]
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# check sub-directories in paths indicated by CSF_TestDataPath
|
||||||
|
if { [info exists env(CSF_TestDataPath)] } {
|
||||||
|
foreach dir [_split_path $env(CSF_TestDataPath)] {
|
||||||
|
while {[llength $dir] != 0} {
|
||||||
|
set name [lindex $dir 0]
|
||||||
|
set dir [lrange $dir 1 end]
|
||||||
|
eval lappend dir [glob -nocomplain -directory $name -type d *]
|
||||||
|
if { [file exists $name/$filename] } {
|
||||||
|
return [file normalize $name/$filename]
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# check current datadir
|
||||||
|
if { [file exists [uplevel datadir]/$filename] } {
|
||||||
|
return [file normalize [uplevel datadir]/$filename]
|
||||||
|
}
|
||||||
|
|
||||||
|
# raise error
|
||||||
|
error [join [list "Error: file $filename could not be found" \
|
||||||
|
"(should be in paths indicated by CSF_TestDataPath environment variable, " \
|
||||||
|
"or in subfolder data in the script directory)"] "\n"]
|
||||||
|
}
|
||||||
|
|
||||||
# Internal procedure to find test case indicated by group, grid, and test case names;
|
# Internal procedure to find test case indicated by group, grid, and test case names;
|
||||||
# returns:
|
# returns:
|
||||||
# - dir: path to the base directory of the tests group
|
# - dir: path to the base directory of the tests group
|
||||||
@ -602,6 +688,7 @@ proc _run_test {scriptsdir group gridname casefile echo} {
|
|||||||
# start timer
|
# start timer
|
||||||
uplevel dchrono _timer reset
|
uplevel dchrono _timer reset
|
||||||
uplevel dchrono _timer start
|
uplevel dchrono _timer start
|
||||||
|
catch {uplevel meminfo w} membase
|
||||||
|
|
||||||
# enable commands logging; switch to old-style mode if dlog command is not present
|
# enable commands logging; switch to old-style mode if dlog command is not present
|
||||||
set dlog_exists 1
|
set dlog_exists 1
|
||||||
@ -677,15 +764,20 @@ proc _run_test {scriptsdir group gridname casefile echo} {
|
|||||||
# stop cpulimit killer if armed by the test
|
# stop cpulimit killer if armed by the test
|
||||||
cpulimit
|
cpulimit
|
||||||
|
|
||||||
# add timing info
|
# add memory and timing info
|
||||||
|
set stats ""
|
||||||
|
if { ! [catch {uplevel meminfo w} memuse] } {
|
||||||
|
set stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
|
||||||
|
}
|
||||||
uplevel dchrono _timer stop
|
uplevel dchrono _timer stop
|
||||||
set time [uplevel dchrono _timer show]
|
set time [uplevel dchrono _timer show]
|
||||||
if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
|
if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
|
||||||
if { $dlog_exists && ! $echo } {
|
set stats "${stats}TOTAL CPU TIME: $cpu sec\n"
|
||||||
dlog add "TOTAL CPU TIME: $cpu sec"
|
}
|
||||||
} else {
|
if { $dlog_exists && ! $echo } {
|
||||||
puts "TOTAL CPU TIME: $cpu sec"
|
dlog add $stats
|
||||||
}
|
} else {
|
||||||
|
puts $stats
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -866,6 +958,22 @@ proc _log_save {file log {title {}}} {
|
|||||||
return
|
return
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Auxiliary procedure to make a (relative if possible) URL to a file for
|
||||||
|
# inclusion a reference in HTML log
|
||||||
|
proc _make_url {htmldir file} {
|
||||||
|
set htmlpath [file split [file normalize $htmldir]]
|
||||||
|
set filepath [file split [file normalize $file]]
|
||||||
|
for {set i 0} {$i < [llength $htmlpath]} {incr i} {
|
||||||
|
if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
|
||||||
|
if { $i == 0 } { break }
|
||||||
|
return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# if relative path could not be made, return full file URL
|
||||||
|
return "file://[file normalize $file]"
|
||||||
|
}
|
||||||
|
|
||||||
# Auxiliary procedure to save log to file
|
# Auxiliary procedure to save log to file
|
||||||
proc _log_html {file log {title {}}} {
|
proc _log_html {file log {title {}}} {
|
||||||
# create missing directories as needed
|
# create missing directories as needed
|
||||||
@ -877,7 +985,7 @@ proc _log_html {file log {title {}}} {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# print header
|
# print header
|
||||||
puts $fd "<html><head><title>$title</title><head><body><h1>$title</h1>"
|
puts $fd "<html><head><title>$title</title></head><body><h1>$title</h1>"
|
||||||
|
|
||||||
# add images if present
|
# add images if present
|
||||||
set imgbasename [file rootname [file tail $file]]
|
set imgbasename [file rootname [file tail $file]]
|
||||||
@ -888,23 +996,10 @@ proc _log_html {file log {title {}}} {
|
|||||||
# print log body, trying to add HTML links to script files on lines like
|
# print log body, trying to add HTML links to script files on lines like
|
||||||
# "Executing <filename>..."
|
# "Executing <filename>..."
|
||||||
puts $fd "<pre>"
|
puts $fd "<pre>"
|
||||||
set logpath [file split [file normalize $file]]
|
|
||||||
foreach line [split $log "\n"] {
|
foreach line [split $log "\n"] {
|
||||||
if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
|
if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
|
||||||
[file exists $script] } {
|
[file exists $script] } {
|
||||||
|
set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
|
||||||
# generate relative path to the script file
|
|
||||||
set url "file://[file normalize $script]"
|
|
||||||
set scriptpath [file split [file normalize $script]]
|
|
||||||
for {set i 0} {$i < [llength $logpath]} {incr i} {
|
|
||||||
if { "[lindex $logpath $i]" != "[lindex $scriptpath $i]]" } {
|
|
||||||
if { $i == 0 } { break }
|
|
||||||
set url "[string repeat "../" [expr [llength $logpath] - $i - 1]]/[file join [lrange $scriptpath $i end]]"
|
|
||||||
break
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
set line [regsub $script $line "<a href=\"$url\">$script</a>"]
|
|
||||||
}
|
}
|
||||||
puts $fd $line
|
puts $fd $line
|
||||||
}
|
}
|
||||||
@ -1284,48 +1379,6 @@ proc _path_separator {} {
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# Procedure to locate data file for test given its name.
|
|
||||||
# The search is performed assuming that the function is called
|
|
||||||
# from the test case script; the search order is:
|
|
||||||
# - subdirectories in environment variable CSF_TestDataPath
|
|
||||||
# If file is not found, raises Tcl error.
|
|
||||||
proc locate_data_file {filename} {
|
|
||||||
global env groupname gridname casename
|
|
||||||
|
|
||||||
# check if the file is located in the subdirectory data of the script dir
|
|
||||||
set scriptfile [info script]
|
|
||||||
if { $scriptfile != "" } {
|
|
||||||
set path [file join [file dirname $scriptfile] data $filename]
|
|
||||||
if { [file exists $path] } {
|
|
||||||
return [file normalize $path]
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# check sub-directories in paths indicated by CSF_TestDataPath
|
|
||||||
if { [info exists env(CSF_TestDataPath)] } {
|
|
||||||
foreach dir [_split_path $env(CSF_TestDataPath)] {
|
|
||||||
while {[llength $dir] != 0} {
|
|
||||||
set name [lindex $dir 0]
|
|
||||||
set dir [lrange $dir 1 end]
|
|
||||||
eval lappend dir [glob -nocomplain -directory $name -type d *]
|
|
||||||
if { [file exists $name/$filename] } {
|
|
||||||
return [file normalize $name/$filename]
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# check current datadir
|
|
||||||
if { [file exists [uplevel datadir]/$filename] } {
|
|
||||||
return [file normalize [uplevel datadir]/$filename]
|
|
||||||
}
|
|
||||||
|
|
||||||
# raise error
|
|
||||||
error [join [list "Error: file $filename could not be found" \
|
|
||||||
"(should be in paths indicated by CSF_TestDataPath environment variable, " \
|
|
||||||
"or in subfolder data in the script directory)"] "\n"]
|
|
||||||
}
|
|
||||||
|
|
||||||
# Procedure to make a diff and common of two lists
|
# Procedure to make a diff and common of two lists
|
||||||
proc _list_diff {list1 list2 _in1 _in2 _common} {
|
proc _list_diff {list1 list2 _in1 _in2 _common} {
|
||||||
upvar $_in1 in1
|
upvar $_in1 in1
|
||||||
@ -1358,16 +1411,26 @@ proc _read_file {filename} {
|
|||||||
return $result
|
return $result
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# procedure to construct name for the mage diff file
|
||||||
|
proc _diff_img_name {dir1 dir2 casepath imgfile} {
|
||||||
|
return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
|
||||||
|
}
|
||||||
|
|
||||||
# Procedure to compare results of two runs of test cases
|
# Procedure to compare results of two runs of test cases
|
||||||
proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
||||||
upvar $_logvar log
|
upvar $_logvar log
|
||||||
|
|
||||||
|
# make sure to load diffimage command
|
||||||
|
uplevel pload VISUALIZATION
|
||||||
|
|
||||||
# prepare variable (array) for collecting statistics
|
# prepare variable (array) for collecting statistics
|
||||||
if { "$_statvar" != "" } {
|
if { "$_statvar" != "" } {
|
||||||
upvar $_statvar stat
|
upvar $_statvar stat
|
||||||
} else {
|
} else {
|
||||||
set stat(cpu1) 0
|
set stat(cpu1) 0
|
||||||
set stat(cpu2) 0
|
set stat(cpu2) 0
|
||||||
|
set stat(mem1) 0
|
||||||
|
set stat(mem2) 0
|
||||||
set log {}
|
set log {}
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -1401,6 +1464,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
|||||||
# load two logs
|
# load two logs
|
||||||
set log1 [_read_file [file join $dir1 $basename $logfile]]
|
set log1 [_read_file [file join $dir1 $basename $logfile]]
|
||||||
set log2 [_read_file [file join $dir2 $basename $logfile]]
|
set log2 [_read_file [file join $dir2 $basename $logfile]]
|
||||||
|
set casename [file rootname $logfile]
|
||||||
|
|
||||||
# check execution statuses
|
# check execution statuses
|
||||||
set status1 UNDEFINED
|
set status1 UNDEFINED
|
||||||
@ -1408,7 +1472,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
|||||||
if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
|
if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
|
||||||
! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
|
! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
|
||||||
"$status1" != "$status2" } {
|
"$status1" != "$status2" } {
|
||||||
_log_and_puts log "STATUS [split $basename /] [file rootname $logfile]: $status1 / $status2"
|
_log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
|
||||||
|
|
||||||
# if test statuses are different, further comparison makes
|
# if test statuses are different, further comparison makes
|
||||||
# no sense unless explicitly requested
|
# no sense unless explicitly requested
|
||||||
@ -1430,17 +1494,101 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
|||||||
|
|
||||||
# compare CPU times with 10% precision (but not less 0.5 sec)
|
# compare CPU times with 10% precision (but not less 0.5 sec)
|
||||||
if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
|
if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
|
||||||
_log_and_puts log "CPU [split $basename /] [file rootname $logfile]: $cpu1 / $cpu2"
|
_log_and_puts log "CPU [split $basename /] $casename: $cpu1 / $cpu2"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# check memory delta
|
||||||
|
set mem1 UNDEFINED
|
||||||
|
set mem2 UNDEFINED
|
||||||
|
if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
|
||||||
|
[regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
|
||||||
|
set stat(mem1) [expr $stat(mem1) + $mem1]
|
||||||
|
set stat(mem2) [expr $stat(mem2) + $mem2]
|
||||||
|
|
||||||
|
# compare memory usage with 10% precision (but not less 16 KiB)
|
||||||
|
if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
|
||||||
|
_log_and_puts log "MEMORY [split $basename /] $casename: $mem1 / $mem2"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# check images
|
||||||
|
set imglist1 [glob -directory $path1 -types f -tails -nocomplain $casename*.{png,gif}]
|
||||||
|
set imglist2 [glob -directory $path2 -types f -tails -nocomplain $casename*.{png,gif}]
|
||||||
|
_list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
|
||||||
|
if { "$verbose" > 1 } {
|
||||||
|
if { [llength $imgin1] > 0 } { _log_and_puts log "Only in $path1: $imgin1" }
|
||||||
|
if { [llength $imgin2] > 0 } { _log_and_puts log "Only in $path2: $imgin2" }
|
||||||
|
}
|
||||||
|
foreach imgfile $imgcommon {
|
||||||
|
# if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
|
||||||
|
set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
|
||||||
|
if { [catch {diffimage [file join $dir1 $basename $imgfile] \
|
||||||
|
[file join $dir2 $basename $imgfile] \
|
||||||
|
0 0 0 $diffile} diff] } {
|
||||||
|
_log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
|
||||||
|
file delete -force $diffile ;# clean possible previous result of diffimage
|
||||||
|
} elseif { $diff != 0 } {
|
||||||
|
_log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs"
|
||||||
|
} else {
|
||||||
|
file delete -force $diffile ;# clean useless artifact of diffimage
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if { "$_statvar" == "" } {
|
if { "$_statvar" == "" } {
|
||||||
|
_log_and_puts log "Total MEMORY difference: $stat(mem1) / $stat(mem2)"
|
||||||
_log_and_puts log "Total CPU difference: $stat(cpu1) / $stat(cpu2)"
|
_log_and_puts log "Total CPU difference: $stat(cpu1) / $stat(cpu2)"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Auxiliary procedure to save log of results comparison to file
|
||||||
|
proc _log_html_diff {file log dir1 dir2} {
|
||||||
|
# create missing directories as needed
|
||||||
|
catch {file mkdir [file dirname $file]}
|
||||||
|
|
||||||
|
# try to open a file
|
||||||
|
if [catch {set fd [open $file w]} res] {
|
||||||
|
error "Error saving log file $file: $res"
|
||||||
|
}
|
||||||
|
|
||||||
|
# print header
|
||||||
|
puts $fd "<html><head><title>Diff $dir1 vs. $dir2</title></head><body>"
|
||||||
|
puts $fd "<h1>Comparison of test results: $dir1 vs. $dir2</h1>"
|
||||||
|
|
||||||
|
# print log body, trying to add HTML links to script files on lines like
|
||||||
|
# "Executing <filename>..."
|
||||||
|
puts $fd "<pre>"
|
||||||
|
set logpath [file split [file normalize $file]]
|
||||||
|
foreach line [split $log "\n"] {
|
||||||
|
puts $fd $line
|
||||||
|
|
||||||
|
if { [regexp {IMAGE[ \t]+([^:]+):[ \t]+([A-Za-z0-9_.-]+)} $line res case img] } {
|
||||||
|
if { [catch {eval file join "" [lrange $case 0 end-1]} gridpath] } {
|
||||||
|
# note: special handler for the case if test grid directoried are compared directly
|
||||||
|
set gridpath ""
|
||||||
|
}
|
||||||
|
set img1 "<img src=\"[_make_url $file [file join $dir1 $gridpath $img]]\">"
|
||||||
|
set img2 "<img src=\"[_make_url $file [file join $dir2 $gridpath $img]]\">"
|
||||||
|
|
||||||
|
set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
|
||||||
|
if { [file exists $difffile] } {
|
||||||
|
set imgd "<img src=\"[_make_url $file $difffile]\">"
|
||||||
|
} else {
|
||||||
|
set imgd "N/A"
|
||||||
|
}
|
||||||
|
|
||||||
|
puts $fd "<table><tr><th>[file tail $dir1]</th><th>[file tail $dir2]</th><th>Different pixels</th></tr>"
|
||||||
|
puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
puts $fd "</pre></body></html>"
|
||||||
|
|
||||||
|
close $fd
|
||||||
|
return
|
||||||
|
}
|
||||||
|
|
||||||
# get number of CPUs on the system
|
# get number of CPUs on the system
|
||||||
proc _get_nb_cpus {} {
|
proc _get_nb_cpus {} {
|
||||||
global tcl_platform env
|
global tcl_platform env
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user