# Procedure to check data file before adding it to repository
help testfile {
- Check data file and prepare it for putting to test data files repository.
- Use: testfile [filelist]
+ Checks specified data files for putting them into the test data files repository.
+
+ Use: testfile filelist
Will report if:
- data file (non-binary) is in DOS encoding (CR/LF)
- same data file (with same or another name) already exists in the repository
- another file with the same name already exists
- Note that names are assumed to be case-insensitive (for Windows).
+ Note that names are considered to be case-insensitive (for compatibility
+ with Windows).
Unless the file is already in the repository, tries to load it, reports
the recognized file format, file size, number of faces and edges in the
- loaded shape (if any), and makes snapshot (in the temporary directory).
+ loaded shape (if any), information contained its triangulation, and makes
+ snapshot (in the temporary directory).
+
Finally it advises whether the file should be put to public section of the
repository.
+
+ Use: testfile -check
+
+ If "-check" is given as an argument, then procedure will check files already
+ located in the repository (for possible duplicates and for DOS encoding).
}
proc testfile {filelist} {
global env
error "Environment variable CSF_TestDataPath must be defined!"
}
+ set checkrepo f
+ if { "$filelist" == "-check" } { set checkrepo t }
+
# build registry of existing data files (name -> path) and (size -> path)
- puts "Checking available test data files..."
+ puts "Collecting info on test data files repository..."
foreach dir [_split_path $env(CSF_TestDataPath)] {
while {[llength $dir] != 0} {
set curr [lindex $dir 0]
foreach file [glob -nocomplain -directory $curr -type f *] {
set name [file tail $file]
set name_lower [string tolower $name]
+ set size [file size $file]
# check that the file is not in DOS encoding
- if { [_check_dos_encoding $file] } {
- puts "Warning: file $file is in DOS encoding; was this intended?"
- }
- _check_file_format $file
-
- # check if file with the same name is present twice or more
- if { [info exists names($name_lower)] } {
- puts "Error: more than one file with name $name is present in the repository:"
- if { [_diff_files $file $names($name_lower)] } {
- puts "(files are different by content)"
- } else {
- puts "(files are same by content)"
+ if { $checkrepo } {
+ if { [_check_dos_encoding $file] } {
+ puts "Warning: file $file is in DOS encoding; was this intended?"
}
- puts "--> $file"
- puts "--> $names($name_lower)"
- continue
- }
+ _check_file_format $file
+
+ # check if file with the same name is present twice or more
+ if { [info exists names($name_lower)] } {
+ puts "Error: more than one file with name $name is present in the repository:"
+ if { [_diff_files $file $names($name_lower)] } {
+ puts "(files are different by content)"
+ } else {
+ puts "(files are same by content)"
+ }
+ puts "--> $file"
+ puts "--> $names($name_lower)"
+ continue
+ }
- # check if file with the same content exists
- set size [file size $file]
- if { [info exists sizes($size)] } {
- foreach other $sizes($size) {
- if { ! [_diff_files $file $other] } {
- puts "Warning: two files with the same content found:"
- puts "--> $file"
- puts "--> $other"
+ # check if file with the same content exists
+ if { [info exists sizes($size)] } {
+ foreach other $sizes($size) {
+ if { ! [_diff_files $file $other] } {
+ puts "Warning: two files with the same content found:"
+ puts "--> $file"
+ puts "--> $other"
+ }
}
}
}
# add the file to the registry
- set names($name_lower) $file
+ lappend names($name_lower) $file
lappend sizes($size) $file
}
}
}
- if { [llength $filelist] <= 0 } { return }
+ if { $checkrepo || [llength $filelist] <= 0 } { return }
# check the new files
set has_images f
puts "Checking new file(s)..."
foreach file $filelist {
- # check for DOS encoding
- if { [_check_dos_encoding $file] } {
- puts "$file: Warning: DOS encoding detected"
- }
-
set name [file tail $file]
set name_lower [string tolower $name]
+ set found f
# check for presence of the file with same name
if { [info exists names($name_lower)] } {
- if { [_diff_files $file $names($name_lower)] } {
- puts "$file: Error: name is already used by existing file\n--> $names($name_lower)"
- } else {
- puts "$file: OK: already in the repository \n--> $names($name_lower)"
- continue
+ set found f
+ foreach other $names($name_lower) {
+ # avoid comparing the file with itself
+ if { [file normalize $file] == [file normalize $other] } {
+ continue
+ }
+ # compare content
+ if { [_diff_files $file $other] } {
+ puts "\n* $file: error\n name is already used by existing file\n --> $other"
+ } else {
+ puts "\n* $file: already present \n --> $other"
+ }
+ set found t
+ break
}
+ if { $found } { continue }
+ }
+
+ # get size of the file; if it is in DOS encoding and less than 1 MB,
+ # estimate also its size in UNIX encoding to be able to find same
+ # file if already present but in UNIX encoding
+ set sizeact [file size $file]
+ set sizeunx ""
+ set isdos [_check_dos_encoding $file]
+ if { $isdos && $sizeact < 10000000 } {
+ set fd [open $file r]
+ fconfigure $fd -translation crlf
+ set sizeunx [string length [read $fd]]
+ close $fd
}
# check if file with the same content exists
- set size [file size $file]
- if { [info exists sizes($size)] } {
- set found f
+ foreach size "$sizeact $sizeunx" {
+ if { [info exists sizes($size)] } {
foreach other $sizes($size) {
+ # avoid comparing the file with itself
+ if { [file normalize $file] == [file normalize $other] } {
+ continue
+ }
+ # compare content
if { ! [_diff_files $file $other] } {
- puts "$file: OK: the same file is already present under name [file tail $other]\n--> $other"
+ puts "\n* $file: duplicate \n already present under name [file tail $other]\n --> $other"
set found t
break
}
}
- if { $found } { continue }
+ if { $found } { break }
+ }
+ }
+ if { $found } { continue }
+
+ # file is not present yet, so to be analyzed
+ puts "\n* $file: new file"
+
+ # add the file to the registry as if it were added to the repository,
+ # to report possible duplicates among the currently processed files
+ lappend names($name_lower) $file
+ if { "$sizeunx" != "" } {
+ lappend sizes($sizeunx) $file
+ } else {
+ lappend sizes($sizeact) $file
+ }
+
+ # first of all, complain if it is in DOS encoding
+ if { $isdos } {
+ puts " Warning: DOS encoding detected, consider converting to"
+ puts " UNIX unless DOS line ends are needed for the test"
}
# try to read the file
set format [_check_file_format $file]
if { [catch {uplevel load_data_file $file $format a}] } {
- puts "$file: Error: Cannot read as $format file"
+ puts " Warning: Cannot read as $format file"
continue
}
+ # warn if shape contains triangulation
+ pload MODELING
+ if { "$format" != "STL" &&
+ [regexp {contains\s+([0-9]+)\s+triangles} [uplevel trinfo a] res nbtriangles] &&
+ $nbtriangles != 0 } {
+ puts " Warning: shape contains triangulation ($nbtriangles triangles),"
+ puts " consider removing them unless they are needed for the test!"
+ }
+
# get number of faces and edges
set edges 0
set faces 0
set dir public
} else {
set dir private
- # check if one of names of that file corresponds to typical name for
- # MDTV bugs or has extension .rle, this should be old model
- if { [regexp -nocase {.*(cts|ats|pro|buc|ger|fra|usa|uki)[0-9]+.*} $name] ||
- [regexp -nocase {[.]rle\y} $name] } {
- set dir old
- }
}
# add stats
- puts "$file: $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
+ puts " $format size=[expr $size / 1024] KiB, nbfaces=$faces, nbedges=$edges -> $dir"
set tmpdir [_get_temp_dir]
file mkdir $tmpdir/$dir
# make snapshot
pload AISV
uplevel vdisplay a
+ uplevel vsetdispmode 1
uplevel vfit
uplevel vzfit
uplevel vdump $tmpdir/$dir/[file rootname [file tail $file]].png
while {[llength $dir] != 0} {
set name [lindex $dir 0]
set dir [lrange $dir 1 end]
+
# skip directories starting with dot
- if { [regexp {^[.]} $name] } { continue }
+ set aTail [file tail $name]
+ if { [regexp {^[.]} $aTail] } { continue }
if { [file exists $name/$filename] } {
return [file normalize $name/$filename]
}
# Internal procedure to generate HTML page presenting log of the tests
# execution in tabular form, with links to reports on individual cases
-proc _log_html_summary {logdir log totals regressions improvements total_time} {
+proc _log_html_summary {logdir log totals regressions improvements skipped total_time} {
global _test_case_regexp
# create missing directories as needed
}
# print regressions and improvements
- foreach featured [list $regressions $improvements] {
+ foreach featured [list $regressions $improvements $skipped] {
if { [llength $featured] <= 1 } { continue }
set status [string trim [lindex $featured 0] { :}]
puts $fd "<h2>$status</h2>"
set totals {}
set improvements {Improvements:}
set regressions {Failed:}
+ set skipped {Skipped:}
if { [info exists stat] } {
foreach status [lsort [array names stat]] {
lappend totals [list [llength $stat($status)] $status]
- # separately count improvements (status starting with IMP) and regressions (all except IMP, OK, BAD, and SKIP)
+ # separately count improvements (status starting with IMP), skipped (status starting with SKIP) and regressions (all except IMP, OK, BAD, and SKIP)
if { [regexp -nocase {^IMP} $status] } {
eval lappend improvements $stat($status)
+ } elseif { [regexp -nocase {^SKIP} $status] } {
+ eval lappend skipped $stat($status)
} elseif { $status != "OK" && ! [regexp -nocase {^BAD} $status] && ! [regexp -nocase {^SKIP} $status] } {
eval lappend regressions $stat($status)
}
if { [llength $regressions] > 1 } {
_log_and_puts log [join $regressions "\n "]
}
+ if { [llength $skipped] > 1 } {
+ _log_and_puts log [join $skipped "\n "]
+ }
if { [llength $improvements] == 1 && [llength $regressions] == 1 } {
_log_and_puts log "No regressions"
}
# save log to files
if { $logdir != "" } {
- _log_html_summary $logdir $log $totals $regressions $improvements $total_time
+ _log_html_summary $logdir $log $totals $regressions $improvements $skipped $total_time
_log_save $logdir/tests.log [join $log "\n"] "Tests summary"
}
# auxiliary procedure to produce string comparing two values
proc _diff_show_ratio {value1 value2} {
- return "$value1 / $value2 \[[format "%+5.2f%%" [expr 100 * ($value1 - $value2) / double($value2)]]\]"
+ if {[expr double ($value2)] == 0.} {
+ return "$value1 / $value2"
+ } else {
+ return "$value1 / $value2 \[[format "%+5.2f%%" [expr 100 * ($value1 - $value2) / double($value2)]]\]"
+ }
}
# procedure to check cpu user time
puts $fd "<h2>Version A - $dir1</h2>"
puts $fd "<h2>Version B - $dir2</h2>"
- # print log body, trying to add HTML links to script files on lines like
- # "Executing <filename>..."
+ # add script for switching between images on click
+ puts $fd ""
+ puts $fd "<script type=\"text/javascript\">"
+ puts $fd " function diffimage_toggle(img,url1,url2)"
+ puts $fd " {"
+ puts $fd " if (img.show2nd) { img.src = url1; img.show2nd = false; }"
+ puts $fd " else { img.src = url2; img.show2nd = true; }"
+ puts $fd " }"
+ puts $fd " function diffimage_reset(img,url) { img.src = url; img.show2nd = true; }"
+ puts $fd "</script>"
+ puts $fd ""
+
+ # print log body
puts $fd "<pre>"
set logpath [file split [file normalize $file]]
foreach line $log {
# 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 aCaseName [lindex $case end]
+ set img1url [_make_url $file [file join $dir1 $gridpath $img]]
+ set img2url [_make_url $file [file join $dir2 $gridpath $img]]
+ set img1 "<a href=\"[_make_url $file [file join $dir1 $gridpath $aCaseName.html]]\"><img src=\"$img1url\"></a>"
+ set img2 "<a href=\"[_make_url $file [file join $dir2 $gridpath $aCaseName.html]]\"><img src=\"$img2url\"></a>"
set difffile [_diff_img_name $dir1 $dir2 $gridpath $img]
+ set imgdurl [_make_url $file $difffile]
if { [file exists $difffile] } {
- set imgd "<img src=\"[_make_url $file $difffile]\">"
+ set imgd "<img src=\"$imgdurl\" onmouseout=diffimage_reset(this,\"$imgdurl\") onclick=diffimage_toggle(this,\"$img1url\",\"$img2url\")>"
} else {
set imgd "N/A"
}
- puts $fd "<table><tr><th><abbr title=\"$dir1\">Version A</abbr></th><th><abbr title=\"$dir2\">Version B</abbr></th><th>Different pixels</th></tr>"
+ 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>"
puts $fd "<tr><td>$img1</td><td>$img2</td><td>$imgd</td></tr></table>"
}
}
DRAW { uplevel restore $file $shape }
IGES { pload XSDRAW; uplevel igesbrep $file $shape * }
STEP { pload XSDRAW; uplevel stepread $file __a *; uplevel renamevar __a_1 $shape }
- STL { pload XSDRAW; uplevel readstl $shape $file }
+ STL { pload XSDRAW; uplevel readstl $shape $file triangulation }
default { error "Cannot read $format file $file" }
}
}
projects / occt.git / blobdiff