Updated SICS unit test infrastructure and test tests

site_ansto/instrument/TEST_SICS/unit_tests/test_suite.tcl

@@ -0,0 +1,122 @@
+# 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 {
+      "\""  {"}
+      {'}   {'}
+      {<}   {&lt;}
+      {>}   {&gt;}
+      {&}   {&amp;}
+      \u0   {}
+      \u1   {}
+      \u2   {}
+      \u3   {}
+      \u4   {}
+      \u5   {}
+      \u6   {}
+      \u7   {}
+      \u8   {}
+      \u9   {&#x09;}
+      \ua   {&#x0a;}
+      \ub   {}
+      \uc   {}
+      \ud   {&#x0d;}
+      \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} {
+    set value [test_suite::encode [hval $path]]
+    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"
+}
+