Implement hlistprop $path tclnames

Squashed commit of the following: commit 736f0f3da501ee39fb89735a1142fe6ff2b2c4dd Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 12:21:32 2014 +1000 Use hlistprop $path tclnames in hipadaba_configuration_common.tcl commit 428cac5ac8fe37f6998d3114c71ca01fc9446644 Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 12:11:47 2014 +1000 Use hlistprop $path tclnames in nxscripts_common_1.tcl commit 123cc63924e92a9453bfd1297a4ee6398b31bd1d Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:56:34 2014 +1000 Use hlistprop $path tclnames in gumxml.tcl commit e23f8befd36a2066ceaa32ce3d37d53bc462f870 Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:55:48 2014 +1000 Use hlistprop $path tclnames in testing commit a3587be0a8cc9a9452a75cb0e19572558d35a08a Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:55:01 2014 +1000 Implement hlistprop $path tclnames
2014-07-02 12:28:41 +10:00
parent 87bf34c7b1
commit 3224422d60
5 changed files with 66 additions and 56 deletions
--- a/sicshipadaba.c
+++ b/sicshipadaba.c
@@ -3597,6 +3597,8 @@ static int ListSICSHdbProperty(SConnection * pCon, SicsInterp * pSics,
      genTclList = 1;
    if (strncasecmp(argv[2], "tclesc", 6) == 0)
      genTclList |= 2;
+    if (strncasecmp(argv[2], "tclnam", 6) == 0)
+      genTclList |= 4;
  }
  targetNode = FindHdbNode(NULL, argv[1], pCon);
  if (targetNode == NULL) {
@@ -3614,6 +3616,8 @@ static int ListSICSHdbProperty(SConnection * pCon, SicsInterp * pSics,
    if (genTclList) {
      char *bp;
      DynStringConcatChar(data, ' ');
+      if (genTclList & 4)
+        continue;
      DynStringConcatChar(data, '{');
      for (bp = buffer; *bp; ++bp) {
        if (genTclList & 2 && (*bp == '{' || *bp == '}'))
--- a/site_ansto/instrument/TEST_SICS/unit_tests/test_suite.tcl
+++ b/site_ansto/instrument/TEST_SICS/unit_tests/test_suite.tcl
@@ -98,7 +98,7 @@ proc test_suite::make_nodes {path result indent} {
  foreach p [test_suite::property_elements $path $newIndent] {
    append result $p
  }
-  foreach x [hlist $path] {
+  foreach x [lsort [hlist $path]] {
    set result [test_suite::make_nodes [string map {// /} "$path/$x"] $result $newIndent]
  }
  append result  "$prefix</component>\n"
@@ -107,8 +107,8 @@ proc test_suite::make_nodes {path result indent} {

 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]
+  foreach {key} [lsort [hlistprop $path tclnames]] {
+    set value [test_suite::encode [hgetpropval $path $key]]
    lappend proplist "$prefix<property id=\"$key\">\n"
    lappend proplist "$prefix  <value>$value</value>\n"
    lappend proplist "$prefix</property>\n"
@@ -121,7 +121,7 @@ proc test_suite::getsicsxml {path} {
  append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"

  if {[string compare $path "/" ] == 0} {
-    foreach n [hlist $path] {
+    foreach n [lsort [hlist $path]] {
      set result [test_suite::make_nodes $n $result 2]
    }
  } else {
--- a/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl
+++ b/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl
@@ -403,7 +403,9 @@ proc ::hdb::add_subtree {hpath subtree {object @none} {type @none} {makenode @no
 proc ::hdb::add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
  set catch_status [ catch {
    set parent $basePath
-    array set prop_arr [hlistprop $basePath tcllist]
+    foreach {key} [hlistprop $basePath tclnames] {
+      array set prop_arr [list $key "[hgetpropval $basePath $key]"]
+    }
    foreach child [split $path /] {
      if {[lsearch [hlist $parent] $child] == -1} {
        hmake $parent/$child $priv $dtype $dlen
--- a/site_ansto/instrument/config/nexus/nxscripts_common_1.tcl
+++ b/site_ansto/instrument/config/nexus/nxscripts_common_1.tcl
@@ -645,7 +645,9 @@ proc ::nexus::savetree {hpath pt filestatus} {
  foreach child [hlist /$hpath] {
    if [ catch {
      array unset p_arr
-      array set p_arr [hlistprop /$hpath/$child tcllist]
+      foreach {key} [hlistprop /$hpath/$child tclnames] {
+        array set p_arr [list $key "[hgetpropval /$hpath/$child $key]"]
+      }
      if {([info exists p_arr(type)] == 0) || ($p_arr(type) != "nxvgroup")} {
        set data_type [lindex [split [hinfo /$hpath/$child] , ] 0]
          if {[info exists p_arr(data)] && ($p_arr(data) == true) && ($p_arr(nxsave) == true) } {
@@ -711,7 +713,10 @@ proc ::nexus::_gen_nxdict {hpath dictPath name nxc} {
          }
        }
      }
-      array set p_arr [hlistprop /$hpath tcllist]
+      array unset p_arr
+      foreach {key} [hlistprop /$hpath tclnames] {
+        array set p_arr [list $key "[hgetpropval /$hpath $key]"]
+      }
      set data_type [lindex [split [hinfo /$hpath] , ] 0]
      if {$data_type != "none" || $p_arr(type) == "nxvgroup"} {
        #XXX Do we need to check data_type here. This would skip NXVGROUP nodes
@@ -895,7 +900,10 @@ proc ::nexus::histmem::save {hm nxalias hpath data_type filestatus args} {

  if [catch {
    set point [lindex $args 1]
-    array set pa [hlistprop $hpath tcllist]
+    array unset pa
+    foreach {key}  [hlistprop /$hpath tclnames] {
+      array set pa [list $key "[hgetpropval /$hpath $key]"]
+    }
    foreach sdsname $pa(hmmdatname) rank $pa(hmmrank) dimstr $pa(hmmdimstr) hmmslabstart $pa(hmmslabstart) hmmslabend $pa(hmmslabend) hmmperiodsize $pa(hmmperiodsize) axes $pa(@axes) signal $pa(@signal) {
      nxscript updatedictvar pa_hmmdatname $sdsname
      if {$pa(mutable)} {
--- a/site_ansto/instrument/gumxml.tcl
+++ b/site_ansto/instrument/gumxml.tcl
@@ -46,20 +46,18 @@ proc encode {str} {
 }

 proc make_nodes {path result indent} {
+  if {[hpropexists $path "control"]} {
+    set value [hgetpropval $path "control"]
+    if {[string compare -nocase $value "false"] == 0} {
+      return $result
+    }
+  }
+
  set nodename [file tail $path];
  set type [getdataType $path]
  set prefix [string repeat " " $indent]
  set newIndent [expr $indent + 2]
-  set control "true"
-  foreach {key rvalue} [string map {= " "} [hlistprop $path tclescape]] {
-    set value [encode $rvalue]
-    if {[string compare -nocase $key "control"] == 0} {
-      if {[string compare -nocase $value "false"] == 0} {
-	set control "false"
-      }
-    }
-  }
-  if {"$control" == "true"} {
+
  append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
  if {[string compare -nocase $type "none"] != 0} {
    if [ catch {
@@ -72,19 +70,19 @@ proc make_nodes {path result indent} {
  foreach p [property_elements $path $newIndent] {
    append result $p
  }
-    foreach x [hlist $path] {
+  foreach x [lsort [hlist $path]] {
    set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
  }
  append result  "$prefix</component>\n"
-  }
+
  return $result
 }

 proc property_elements {path indent} {
  set prefix [string repeat " " $indent]
-  foreach {key rvalue} [string map {= " "} [hlistprop $path tclescape]] {
-    set value [encode $rvalue]
+  foreach {key} [lsort [hlistprop $path tclnames]] {
    if {[string compare -nocase $key "control"] == 0} {continue}
+    set value [encode [hgetpropval $path $key]]
    lappend proplist "$prefix<property id=\"$key\">\n"
    if {[string compare -nocase $key "help"] == 0} {
      lappend proplist "$prefix  <value>$value</value>\n"
@@ -103,7 +101,7 @@ proc getgumtreexml {path} {
  append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"

  if {[string compare $path "/" ] == 0} {
-    foreach n [hlist $path] {
+    foreach n [lsort [hlist $path]] {
      set result [make_nodes $n $result 2]
    }
  } else {
@@ -114,20 +112,18 @@ proc getgumtreexml {path} {
 }

 proc make_value_nodes {path result indent} {
+  if {[hpropexists $path "control"]} {
+    set value [hgetpropval $path "control"]
+    if {[string compare -nocase $value "false"] == 0} {
+      return $result
+    }
+  }
+
  set nodename [file tail $path];
  set type [getdataType $path]
  set prefix [string repeat " " $indent]
  set newIndent [expr $indent + 2]

-  set control "true"
-  if {[hpropexists $path "control"]} {
-    set value [encode [hgetpropval $path "control"]]
-    if {[string compare -nocase $value "false"] == 0} {
-      set control "false"
-    }
-  }
-
-  if {"$control" == "true"} {
  append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
  if {[string compare -nocase $type "none"] != 0} {
    if [ catch {
@@ -137,11 +133,11 @@ proc make_value_nodes {path result indent} {
    }
    append result "$prefix  <value>$value</value>\n"
  }
-    foreach x [hlist $path] {
+  foreach x [lsort [hlist $path]] {
    set result [make_value_nodes [string map {// /} "$path/$x"] $result $newIndent]
  }
  append result  "$prefix</component>\n"
-  }
+ 
  return $result
 }

@@ -150,7 +146,7 @@ proc getgumtreexmlvalues {path} {
  append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"

  if {[string compare $path "/" ] == 0} {
-    foreach n [hlist $path] {
+    foreach n [lsort [hlist $path]] {
      set result [make_value_nodes $n $result 2]
    }
  } else {