127 lines
3.1 KiB
Tcl
127 lines
3.1 KiB
Tcl
# vim: ft=tcl ts=8 sts=2 sw=2
|
|
# Author Douglas Clowes (dcl@ansto.gov.au) 2014
|
|
#
|
|
# TCL utility functions for the SICS Unit Test Suite
|
|
#
|
|
namespace eval test_suite {
|
|
variable version 1.0
|
|
}
|
|
|
|
# Send the config dictionary as an ini file image
|
|
#
|
|
proc test_suite::show_config {the_dict} {
|
|
upvar 1 $the_dict my_dict
|
|
foreach s [config_reader::get_sections my_dict] {
|
|
set section "$s"
|
|
clientput "\n\[$section\]"
|
|
foreach n [config_reader::get_variables my_dict $s] {
|
|
set name "$n"
|
|
set value "[config_reader::get_var my_dict $section $n]"
|
|
clientput "$name = $value"
|
|
}
|
|
}
|
|
}
|
|
|
|
# Send the hipadaba tree as an XML image
|
|
#
|
|
# Like getgumtreexml except it does the whole tree and does not split values
|
|
#
|
|
proc test_suite::getdataType {path} {
|
|
return [lindex [split [hinfo $path] ,] 0]
|
|
}
|
|
|
|
proc test_suite::encode {str} {
|
|
set result [string map -nocase {
|
|
"\"" {"}
|
|
{'} {'}
|
|
{<} {<}
|
|
{>} {>}
|
|
{&} {&}
|
|
\u0 {}
|
|
\u1 {}
|
|
\u2 {}
|
|
\u3 {}
|
|
\u4 {}
|
|
\u5 {}
|
|
\u6 {}
|
|
\u7 {}
|
|
\u8 {}
|
|
\u9 {	}
|
|
\ua {
}
|
|
\ub {}
|
|
\uc {}
|
|
\ud {
}
|
|
\ue {}
|
|
\uf {}
|
|
\u10 {}
|
|
\u11 {}
|
|
\u12 {}
|
|
\u13 {}
|
|
\u14 {}
|
|
\u15 {}
|
|
\u16 {}
|
|
\u17 {}
|
|
\u18 {}
|
|
\u19 {}
|
|
\u1a {}
|
|
\u1b {}
|
|
\u1c {}
|
|
\u1d {}
|
|
\u1e {}
|
|
\u1f {}
|
|
} $str]
|
|
return $result
|
|
}
|
|
|
|
proc test_suite::make_nodes {path result indent} {
|
|
set nodename [file tail $path];
|
|
set type [test_suite::getdataType $path]
|
|
set prefix [string repeat " " $indent]
|
|
set newIndent [expr $indent + 2]
|
|
|
|
append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
|
|
if {[string compare -nocase $type "none"] != 0} {
|
|
if [ catch {
|
|
set value [test_suite::encode [hval $path]]
|
|
} message ] {
|
|
set value "HVAL_ERROR:${message}"
|
|
}
|
|
append result "$prefix <value>$value</value>\n"
|
|
}
|
|
foreach p [test_suite::property_elements $path $newIndent] {
|
|
append result $p
|
|
}
|
|
foreach x [hlist $path] {
|
|
set result [test_suite::make_nodes [string map {// /} "$path/$x"] $result $newIndent]
|
|
}
|
|
append result "$prefix</component>\n"
|
|
return $result
|
|
}
|
|
|
|
proc test_suite::property_elements {path indent} {
|
|
set prefix [string repeat " " $indent]
|
|
foreach {key rvalue} [string map {= " "} [hlistprop $path tcl]] {
|
|
set value [test_suite::encode $rvalue]
|
|
lappend proplist "$prefix<property id=\"$key\">\n"
|
|
lappend proplist "$prefix <value>$value</value>\n"
|
|
lappend proplist "$prefix</property>\n"
|
|
}
|
|
if [info exists proplist] {return $proplist}
|
|
}
|
|
|
|
proc test_suite::getsicsxml {path} {
|
|
append result "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
|
|
append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"
|
|
|
|
if {[string compare $path "/" ] == 0} {
|
|
foreach n [hlist $path] {
|
|
set result [test_suite::make_nodes $n $result 2]
|
|
}
|
|
} else {
|
|
set result [test_suite::make_nodes $path $result 2]
|
|
}
|
|
|
|
append result "</hipadaba:SICS>\n"
|
|
}
|
|
|