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
|
||||
}
|
||||
|
||||
# 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
|
||||
help testdiff {
|
||||
Compare results of two executions of tests (CPU times, ...)
|
||||
Use: testdiff dir1 dir2 [options...]
|
||||
Use: testdiff dir1 dir2 [groupname [gridname]] [options...]
|
||||
Where dir1 and dir2 are directories containing logs of two test runs.
|
||||
Allowed options are:
|
||||
-save filename: save resulting log in specified file
|
||||
-subdir name: compare only specified subdirectory (can be nested)
|
||||
-save filename: save resulting log in specified file (default name is
|
||||
\$dir1/diff-\$dir2.log); HTML log is saved with same name
|
||||
and extension .html
|
||||
-status {same|ok|all}: filter cases for comparing by their status:
|
||||
same - only cases with same status are compared (default)
|
||||
ok - only cases with OK status in both logs are compared
|
||||
all - results are compared regardless of status
|
||||
-verbose level:
|
||||
1 - output only differences
|
||||
2 - output list of logs and directories present in one of dirs only
|
||||
3 - (default) output progress messages
|
||||
2 - output also list of logs and directories present in one of dirs only
|
||||
3 - (default) output also progress messages
|
||||
}
|
||||
proc testdiff {dir1 dir2 args} {
|
||||
if { "$dir1" == "$dir2" } {
|
||||
@ -452,7 +498,7 @@ proc testdiff {dir1 dir2 args} {
|
||||
######################################################
|
||||
|
||||
# treat options
|
||||
set logfile ""
|
||||
set logfile [file join $dir1 "diff-[file tail $dir2].log"]
|
||||
set basename ""
|
||||
set status "same"
|
||||
set verbose 3
|
||||
@ -462,7 +508,7 @@ proc testdiff {dir1 dir2 args} {
|
||||
# log file name
|
||||
if { $arg == "-save" } {
|
||||
incr narg
|
||||
if { $narg < [llength $args] } {
|
||||
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||
set logfile [lindex $args $narg]
|
||||
} else {
|
||||
error "Error: Option -save must be followed by log file name"
|
||||
@ -470,21 +516,10 @@ proc testdiff {dir1 dir2 args} {
|
||||
continue
|
||||
}
|
||||
|
||||
# subdirectory to compare
|
||||
if { $arg == "-subdir" } {
|
||||
incr narg
|
||||
if { $narg < [llength $args] } {
|
||||
set basename [lindex $args $narg]
|
||||
} else {
|
||||
error "Error: Option -subdir must be followed by subdirectory path"
|
||||
}
|
||||
continue
|
||||
}
|
||||
|
||||
# status filter
|
||||
if { $arg == "-status" } {
|
||||
incr narg
|
||||
if { $narg < [llength $args] } {
|
||||
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||
set status [lindex $args $narg]
|
||||
} else { set status "" }
|
||||
if { "$status" != "same" && "$status" != "all" && "$status" != "ok" } {
|
||||
@ -496,15 +531,20 @@ proc testdiff {dir1 dir2 args} {
|
||||
# verbose level
|
||||
if { $arg == "-verbose" } {
|
||||
incr narg
|
||||
if { $narg < [llength $args] } {
|
||||
if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } {
|
||||
set verbose [expr [lindex $args $narg]]
|
||||
} else {
|
||||
error "Error: Option -verbose must be followed by integer verbose level"
|
||||
}
|
||||
continue
|
||||
}
|
||||
|
||||
# if { [regexp {^-} $arg] } {
|
||||
if { [regexp {^-} $arg] } {
|
||||
error "Error: unsupported option \"$arg\""
|
||||
# }
|
||||
}
|
||||
|
||||
# non-option arguments form a subdirectory path
|
||||
set basename [file join $basename $arg]
|
||||
}
|
||||
|
||||
# run diff procedure (recursive)
|
||||
@ -513,11 +553,57 @@ proc testdiff {dir1 dir2 args} {
|
||||
# save result to log file
|
||||
if { "$logfile" != "" } {
|
||||
_log_save $logfile $log
|
||||
_log_html_diff "[file rootname $logfile].html" $log $dir1 $dir2
|
||||
puts "Log is saved to $logfile (and .html)"
|
||||
}
|
||||
|
||||
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;
|
||||
# returns:
|
||||
# - dir: path to the base directory of the tests group
|
||||
@ -602,6 +688,7 @@ proc _run_test {scriptsdir group gridname casefile echo} {
|
||||
# start timer
|
||||
uplevel dchrono _timer reset
|
||||
uplevel dchrono _timer start
|
||||
catch {uplevel meminfo w} membase
|
||||
|
||||
# enable commands logging; switch to old-style mode if dlog command is not present
|
||||
set dlog_exists 1
|
||||
@ -677,15 +764,20 @@ proc _run_test {scriptsdir group gridname casefile echo} {
|
||||
# stop cpulimit killer if armed by the test
|
||||
cpulimit
|
||||
|
||||
# add timing info
|
||||
# add memory and timing info
|
||||
set stats ""
|
||||
if { ! [catch {uplevel meminfo w} memuse] } {
|
||||
set stats "MEMORY DELTA: [expr ($memuse - $membase) / 1024] KiB\n"
|
||||
}
|
||||
uplevel dchrono _timer stop
|
||||
set time [uplevel dchrono _timer show]
|
||||
if [regexp -nocase {CPU user time:[ \t]*([0-9.e-]+)} $time res cpu] {
|
||||
if { $dlog_exists && ! $echo } {
|
||||
dlog add "TOTAL CPU TIME: $cpu sec"
|
||||
} else {
|
||||
puts "TOTAL CPU TIME: $cpu sec"
|
||||
}
|
||||
set stats "${stats}TOTAL CPU TIME: $cpu sec\n"
|
||||
}
|
||||
if { $dlog_exists && ! $echo } {
|
||||
dlog add $stats
|
||||
} else {
|
||||
puts $stats
|
||||
}
|
||||
}
|
||||
|
||||
@ -866,6 +958,22 @@ proc _log_save {file log {title {}}} {
|
||||
return
|
||||
}
|
||||
|
||||
# Auxiliary procedure to make a (relative if possible) URL to a file for
|
||||
# inclusion a reference in HTML log
|
||||
proc _make_url {htmldir file} {
|
||||
set htmlpath [file split [file normalize $htmldir]]
|
||||
set filepath [file split [file normalize $file]]
|
||||
for {set i 0} {$i < [llength $htmlpath]} {incr i} {
|
||||
if { "[lindex $htmlpath $i]" != "[lindex $filepath $i]" } {
|
||||
if { $i == 0 } { break }
|
||||
return "[string repeat "../" [expr [llength $htmlpath] - $i - 1]][eval file join [lrange $filepath $i end]]"
|
||||
}
|
||||
}
|
||||
|
||||
# if relative path could not be made, return full file URL
|
||||
return "file://[file normalize $file]"
|
||||
}
|
||||
|
||||
# Auxiliary procedure to save log to file
|
||||
proc _log_html {file log {title {}}} {
|
||||
# create missing directories as needed
|
||||
@ -877,7 +985,7 @@ proc _log_html {file log {title {}}} {
|
||||
}
|
||||
|
||||
# print header
|
||||
puts $fd "<html><head><title>$title</title><head><body><h1>$title</h1>"
|
||||
puts $fd "<html><head><title>$title</title></head><body><h1>$title</h1>"
|
||||
|
||||
# add images if present
|
||||
set imgbasename [file rootname [file tail $file]]
|
||||
@ -888,23 +996,10 @@ proc _log_html {file log {title {}}} {
|
||||
# print log body, trying to add HTML links to script files on lines like
|
||||
# "Executing <filename>..."
|
||||
puts $fd "<pre>"
|
||||
set logpath [file split [file normalize $file]]
|
||||
foreach line [split $log "\n"] {
|
||||
if { [regexp {Executing[ \t]+([a-zA-Z0-9._/:-]+[^.])} $line res script] &&
|
||||
[file exists $script] } {
|
||||
|
||||
# generate relative path to the script file
|
||||
set url "file://[file normalize $script]"
|
||||
set scriptpath [file split [file normalize $script]]
|
||||
for {set i 0} {$i < [llength $logpath]} {incr i} {
|
||||
if { "[lindex $logpath $i]" != "[lindex $scriptpath $i]]" } {
|
||||
if { $i == 0 } { break }
|
||||
set url "[string repeat "../" [expr [llength $logpath] - $i - 1]]/[file join [lrange $scriptpath $i end]]"
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
set line [regsub $script $line "<a href=\"$url\">$script</a>"]
|
||||
set line [regsub $script $line "<a href=\"[_make_url $file $script]\">$script</a>"]
|
||||
}
|
||||
puts $fd $line
|
||||
}
|
||||
@ -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
|
||||
proc _list_diff {list1 list2 _in1 _in2 _common} {
|
||||
upvar $_in1 in1
|
||||
@ -1358,16 +1411,26 @@ proc _read_file {filename} {
|
||||
return $result
|
||||
}
|
||||
|
||||
# procedure to construct name for the mage diff file
|
||||
proc _diff_img_name {dir1 dir2 casepath imgfile} {
|
||||
return [file join $dir1 $casepath "diff-[file tail $dir2]-$imgfile"]
|
||||
}
|
||||
|
||||
# Procedure to compare results of two runs of test cases
|
||||
proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
||||
upvar $_logvar log
|
||||
|
||||
# make sure to load diffimage command
|
||||
uplevel pload VISUALIZATION
|
||||
|
||||
# prepare variable (array) for collecting statistics
|
||||
if { "$_statvar" != "" } {
|
||||
upvar $_statvar stat
|
||||
} else {
|
||||
set stat(cpu1) 0
|
||||
set stat(cpu2) 0
|
||||
set stat(mem1) 0
|
||||
set stat(mem2) 0
|
||||
set log {}
|
||||
}
|
||||
|
||||
@ -1401,6 +1464,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
||||
# load two logs
|
||||
set log1 [_read_file [file join $dir1 $basename $logfile]]
|
||||
set log2 [_read_file [file join $dir2 $basename $logfile]]
|
||||
set casename [file rootname $logfile]
|
||||
|
||||
# check execution statuses
|
||||
set status1 UNDEFINED
|
||||
@ -1408,7 +1472,7 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
||||
if { ! [regexp {CASE [^:]*:\s*([\w]+)} $log1 res1 status1] ||
|
||||
! [regexp {CASE [^:]*:\s*([\w]+)} $log2 res2 status2] ||
|
||||
"$status1" != "$status2" } {
|
||||
_log_and_puts log "STATUS [split $basename /] [file rootname $logfile]: $status1 / $status2"
|
||||
_log_and_puts log "STATUS [split $basename /] $casename: $status1 / $status2"
|
||||
|
||||
# if test statuses are different, further comparison makes
|
||||
# no sense unless explicitly requested
|
||||
@ -1430,17 +1494,101 @@ proc _test_diff {dir1 dir2 basename status verbose _logvar {_statvar ""}} {
|
||||
|
||||
# compare CPU times with 10% precision (but not less 0.5 sec)
|
||||
if { [expr abs ($cpu1 - $cpu2) > 0.5 + 0.05 * abs ($cpu1 + $cpu2)] } {
|
||||
_log_and_puts log "CPU [split $basename /] [file rootname $logfile]: $cpu1 / $cpu2"
|
||||
_log_and_puts log "CPU [split $basename /] $casename: $cpu1 / $cpu2"
|
||||
}
|
||||
}
|
||||
|
||||
# check memory delta
|
||||
set mem1 UNDEFINED
|
||||
set mem2 UNDEFINED
|
||||
if { [regexp {MEMORY DELTA:\s*([\d.]+)} $log1 res1 mem1] &&
|
||||
[regexp {MEMORY DELTA:\s*([\d.]+)} $log2 res1 mem2] } {
|
||||
set stat(mem1) [expr $stat(mem1) + $mem1]
|
||||
set stat(mem2) [expr $stat(mem2) + $mem2]
|
||||
|
||||
# compare memory usage with 10% precision (but not less 16 KiB)
|
||||
if { [expr abs ($mem1 - $mem2) > 16 + 0.05 * abs ($mem1 + $mem2)] } {
|
||||
_log_and_puts log "MEMORY [split $basename /] $casename: $mem1 / $mem2"
|
||||
}
|
||||
}
|
||||
|
||||
# check images
|
||||
set imglist1 [glob -directory $path1 -types f -tails -nocomplain $casename*.{png,gif}]
|
||||
set imglist2 [glob -directory $path2 -types f -tails -nocomplain $casename*.{png,gif}]
|
||||
_list_diff $imglist1 $imglist2 imgin1 imgin2 imgcommon
|
||||
if { "$verbose" > 1 } {
|
||||
if { [llength $imgin1] > 0 } { _log_and_puts log "Only in $path1: $imgin1" }
|
||||
if { [llength $imgin2] > 0 } { _log_and_puts log "Only in $path2: $imgin2" }
|
||||
}
|
||||
foreach imgfile $imgcommon {
|
||||
# if { $verbose > 1 } { _log_and_puts log "Checking [split basename /] $casename: $imgfile" }
|
||||
set diffile [_diff_img_name $dir1 $dir2 $basename $imgfile]
|
||||
if { [catch {diffimage [file join $dir1 $basename $imgfile] \
|
||||
[file join $dir2 $basename $imgfile] \
|
||||
0 0 0 $diffile} diff] } {
|
||||
_log_and_puts log "IMAGE [split $basename /] $casename: $imgfile cannot be compared"
|
||||
file delete -force $diffile ;# clean possible previous result of diffimage
|
||||
} elseif { $diff != 0 } {
|
||||
_log_and_puts log "IMAGE [split $basename /] $casename: $imgfile differs"
|
||||
} else {
|
||||
file delete -force $diffile ;# clean useless artifact of diffimage
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if { "$_statvar" == "" } {
|
||||
_log_and_puts log "Total MEMORY difference: $stat(mem1) / $stat(mem2)"
|
||||
_log_and_puts log "Total CPU difference: $stat(cpu1) / $stat(cpu2)"
|
||||
}
|
||||
}
|
||||
|
||||
# Auxiliary procedure to save log of results comparison to file
|
||||
proc _log_html_diff {file log dir1 dir2} {
|
||||
# create missing directories as needed
|
||||
catch {file mkdir [file dirname $file]}
|
||||
|
||||
# try to open a file
|
||||
if [catch {set fd [open $file w]} res] {
|
||||
error "Error saving log file $file: $res"
|
||||
}
|
||||
|
||||
# print header
|
||||
puts $fd "<html><head><title>Diff $dir1 vs. $dir2</title></head><body>"
|
||||
puts $fd "<h1>Comparison of test results: $dir1 vs. $dir2</h1>"
|
||||
|
||||
# print log body, trying to add HTML links to script files on lines like
|
||||
# "Executing <filename>..."
|
||||
puts $fd "<pre>"
|
||||
set logpath [file split [file normalize $file]]
|
||||
foreach line [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
|
||||
proc _get_nb_cpus {} {
|
||||
global tcl_platform env
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user