From 9e170b66d37af0410cb6e3822cafcf897d9e3c28 Mon Sep 17 00:00:00 2001
From: Ferdi Franceschini <ffr@ansto.gov.au>
Date: Wed, 26 Sep 2007 16:17:51 +1000
Subject: [PATCH] Removed 'event' and 'ilist' kind for SICS objects.

r2162 | ffr | 2007-09-26 16:17:51 +1000 (Wed, 26 Sep 2007) | 2 lines
---
 .../hipadaba_configuration_common.tcl         | 220 ++++++++++--------
 .../hipadaba/instdict_specification.tcl       |   5 +-
 2 files changed, 127 insertions(+), 98 deletions(-)

diff --git a/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl b/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl
index 7049481e..f3820565 100644
--- a/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl
+++ b/site_ansto/instrument/config/hipadaba/hipadaba_configuration_common.tcl
@@ -13,19 +13,19 @@ source $cfPath(hipadaba)/common_instrument_dictionary.tcl
 
 InstallHdb 
 
-# TODO only use add_node to add hpaths and nodes,
-#   eg add_node / path beam_monitor_scan prop_list {data true ...}
-
-# eventid=source/type, type={parameter feedback graphics} eg hdb_bmonscan/feedback
-proc update_node {name eventid access} {
-  global nodeindex
-  upvar $name signal
-  hset $nodeindex($eventid) $signal($eventid)
+namespace eval ::hdb {
+namespace export buildHDB attlist
 }
 
-proc add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
-
-
+##
+# @brief Add an hdb path to the hdb tree at the given basePath
+#
+# @param basePath This is the parent for the new hdb path
+# @param path Add this path to the basePath
+# @param priv This is the access privilege for the new hdb path
+# @param dtype The new hdb node will have this type
+# @param dlen Array length if the hdb node represents array data
+proc ::hdb::add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
   set parent $basePath
   array set prop_arr [::utility::hlistplainprop $basePath]
   foreach child [split $path /] {
@@ -38,7 +38,7 @@ proc add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
         hsetprop $parent/$child klass @none
         hsetprop $parent/$child type $prop_arr(type)
       }
-    } 
+    }
     if {$parent == "/"} {
       set parent /$child
     } else {
@@ -48,26 +48,29 @@ proc add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
   return $parent
 }
 
-proc add_cmd_par {hpath sobj name} {
+##
+# @brief Attach a command parameter node to the given hdb "command path"
+#
+# @param hpath hdb "command path", this will be the parent for the parameter node
+# @param sobj name of SICS variable which corresponds to a command parameter
+# @param name The hdb node name that the variable will be added under
+# @see command
+proc ::hdb::add_cmd_par {hpath sobj name} {
   hattach $hpath $sobj $name
-  #array set property [attlist $sobj]
-#  hsetprop $hpath/$name argtype $property(argtype)
   foreach {prop pval} [attlist $sobj] {
     hsetprop $hpath/$name $prop $pval
   }
   hsetprop $hpath/$name data false
-#  if {[info exists property(values)]} {
-#    hsetprop $hpath/$name values $property(values)
-#  }
-#  if {[info exists property(min)]} {
-#    hsetprop $hpath/$name min $property(min)
-#  }
-#  if {[info exists property(max)]} {
-#    hsetprop $hpath/$name max $property(max)
-#  }
 }
 
-proc add_feedback {hpath sobj name} {
+##
+# @brief Attach a feedback node to the given hdb "command path"
+#
+# @param hpath hdb "command path", this will be the parent for the feedback node
+# @param sobj name of the SICS variable which corresponds to a command feedback value
+# @param name The hdb node name that the variable will be added under
+# @see command
+proc ::hdb::add_feedback {hpath sobj name} {
   hattach $hpath $sobj $name
   foreach {prop pval} [attlist $sobj] {
     hsetprop $hpath/$name $prop $pval
@@ -75,9 +78,13 @@ proc add_feedback {hpath sobj name} {
   hsetprop $hpath/$name privilege READ_ONLY
 }
 
-# args is an optional set of properties as name/value pairs.
-# need node kind 
-proc add_node {basePath args} {
+##
+# @brief Adds a hdb path to the given base path with the given properties
+#
+# @param args a list of name value pairs which provide the node properties\n
+#\targs can just be "path a/b/c prop_list {kind xxx long_name junk ..}"\n
+#\tor "node nnn kind kkk long_name junk prop_list {propA aaa propB bbb ...}"
+proc ::hdb::add_node {basePath args} {
   global nodeindex
   array unset arg_array
   array set arg_array $args;
@@ -120,7 +127,7 @@ proc add_node {basePath args} {
         if {[string length [info procs ${command}_parameters]] > 0} {
           ${command}_parameters add_node $cmd_path
         } else {
-          $command -map param add_cmd_par $cmd_path 
+          $command -map param ::hdb::add_cmd_par $cmd_path 
         }
         if {[string length [info procs ${command}_feedback]] > 0} {
           add_hpath $cmd_path feedback
@@ -129,15 +136,9 @@ proc add_node {basePath args} {
         } else {
           add_hpath $cmd_path feedback
           hsetprop $cmd_path/feedback type part
-          $command -map feedback add_feedback $cmd_path/feedback 
+          $command -map feedback ::hdb::add_feedback $cmd_path/feedback 
         }
       }
-      event {
-        # An event is a data array, node= a node path 
-        add_hpath $basePath $node_name $arg_array(priv) $arg_array(dtype) $arg_array(dlen)
-        set node_path $basePath/$node_name
-        set nodeindex($arg_array(eventid),$arg_array(node)) $node_path
-      }
       hobj {
         hattach $basePath $node_name $arg_array(long_name)
         set node_path $basePath/$arg_array(long_name)
@@ -152,11 +153,6 @@ proc add_node {basePath args} {
           hsetprop $node_path/$child klass   [getatt $node_name klass]
         }
       }
-      ilist {
-        set node_path $basePath
-        set ilist_proc $node_name
-        $ilist_proc add_node $node_path
-      }
       script {
         # A r/w pair of scripts, node = a node path
         set node_path $basePath/[getatt $node_name long_name]
@@ -186,12 +182,16 @@ proc add_node {basePath args} {
         hsetprop $node_path $prop $pval
       }
     }
+    sicslist setatt $node_name hdb_path $node_path
     return $node_path
   }
 }
 
-# Add command
-proc add_command {basePath command} {
+##
+# @brief Add a "command" node to basePath for the gumtree control interface.
+# @param basePath parent for new command node
+# @param command name of the command procedure
+proc ::hdb::add_command {basePath command} {
   array unset cmd_atts
   array set cmd_atts [attlist $command]
   if 0 {
@@ -202,10 +202,6 @@ proc add_command {basePath command} {
   }
   }
   hcommand $basePath/$cmd_atts(long_name) $command
-  set cmd_ns [namespace qualifiers $command]
-  if {[llength [trace info variable ::${cmd_ns}::event]] == 0} {
-    trace add variable ::${cmd_ns}::event write update_node
-  }
   set cmd_path $basePath/$cmd_atts(long_name)
   hsetprop $cmd_path privilege $cmd_atts(privilege)
   hsetprop $cmd_path type $cmd_atts(kind)
@@ -216,17 +212,26 @@ proc add_command {basePath command} {
   return $cmd_path
 } 
 
-# attlist <sicsobj> 
-# return a list of name value pairs for the sicsobj attributes
-proc attlist {sicsobj} {
+##
+# @brief Retrieve the list of attributes for the given sics object
+#
+# @param sicsobj SICS object name
+# @return a list of name value pairs for the sicsobj attributes
+proc ::hdb::attlist {sicsobj} {
   foreach att [tolower_sicslist $sicsobj] {
     lappend atts [split [string range $att 0 end-1] =]
   }
   return [join $atts] 
 }
 
-# List sics objects with the given sics type, klass and group
-proc sobjlist {atype aklass} {
+
+##
+# @brief List sics objects with the given sics type, klass and group
+#
+# @param atype one of the types given in instdict_specification.tcl
+# @param aklass one of the klasses given in instdict_specification.tcl
+# @return A Tcl list of SICS objects.
+proc ::hdb::sobjlist {atype aklass} {
   global sobj_sicstype_list
 
   switch $atype {
@@ -248,15 +253,25 @@ proc sobjlist {atype aklass} {
   }
 }
 
-proc getsobjatt {sicsobj attribute} {
+##
+# @brief Get the named attribute from the given SICS object
+#
+# @param sicsobj a SICS object name
+# @param attribute name of the attribute to be fetched
+# @return the plain attribute value
+proc ::hdb::getsobjatt {sicsobj attribute} {
   string trim [lindex [join [split [tolower_sicslist $sicsobj $attribute] =]] 1]
 }
 
-
-# Add the given sics object (sobj) of sobjtype to the
-# given hipadaba path hpath.
-# hpath must exist.
-proc sobjadd {hpath sobj args} {
+##
+# @brief Add the given sics object of sobjtype to the given hipadaba path (hpath must exist)
+#
+# @param hpath parent for new hdb node
+# @param sobj SICS object name
+# @param args Hmmm this doesn't get used, do we need it?
+proc ::hdb::sobjadd {hpath sobj args} {
+# TODO Check if args parameter needs to be here, it might be there in case the function is called
+# with more than two arguments.
   array unset sobjatt
   array set sobjatt [attlist $sobj]
   sicslist setatt $sobj id $sobj
@@ -350,6 +365,9 @@ proc sobjadd {hpath sobj args} {
         if {[catch { hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
         if {[catch { hsetprop $node_path nxalias $sobjatt(nxalias)} err]} {clientput $err error}
         if {[catch { hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
+        hmakescript $node_path/target "$sobj target" hdbReadOnly float
+        hsetprop $node_path/target data false
+        hsetprop $node_path/target control true
       } else {
         clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
       } 
@@ -357,10 +375,16 @@ proc sobjadd {hpath sobj args} {
   } 
 }
 
-# sobjtypeadd <hpath> <sobjtype>
-# Traverses list of sics objects of given type and attaches the matching sics objects to the given hpath
-# Hipadaba node properties are constructed from the sobj attribute list.
-proc sobjtypeadd {hpath sobjtype given_klass} {
+##
+# @brief Attaches the SICS objects of the given type and klass to the given hdb path
+#
+# The hipadaba node properties are constructed from the SICS object attribute list.
+#
+# @param hpath parent for the new SICS object nodes
+# @param sobjtype One of the types in instdict_specification.tcl
+# @param given_klass A klass in instdict_specification.tcl
+# @see sobjadd
+proc ::hdb::sobjtypeadd {hpath sobjtype given_klass} {
   foreach {sobj} [sobjlist $sobjtype $given_klass] {
     sobjadd $hpath $sobj
   }
@@ -374,7 +398,7 @@ proc sobjtypeadd {hpath sobjtype given_klass} {
 #
 # Nodes which have no child nodes and no associated sics objects for the
 # current instrument are removed.
-proc prune {instdict} {
+proc ::hdb::prune {instdict} {
   upvar $instdict dict
   array set dictarr $dict
   set candidates [array names dictarr]
@@ -410,16 +434,17 @@ proc prune {instdict} {
   set dict [array get dictarr]
   return
 }
-# 
-#TODO add data control nxsave nxtyp properties
+
 ##
 # @brief Traverse the instrument dictionary and construct the hipadaba database.
 #
+# This command prunes the dictionary before building it.
+#
 # @param instDict name of the instrument dictionary structure
 #
-# This command prunes the dictionary before building it.
 # @see prune
-proc buildHDB {instDict} {
+proc ::hdb::buildHDB {instDict} {
+#TODO add data control nxsave nxtyp properties
 upvar #0 $instDict dictionary
 prune dictionary
   foreach {n v} $dictionary {
@@ -436,33 +461,40 @@ prune dictionary
   }
 }
 
-namespace eval ::hdb {
-  proc set_save {hpath mode {top true}} {
-    if {$hpath != "/"} {
-      set hnode $hpath
-    } else {
-      foreach hp [hlist /] {
-        ::hdb::set_save /$hp $mode
-      }
-      return
-    }
-    if {[::utility::hgetplainprop $hnode data] == "false"} {
-      return
-    }
-    foreach hp [hlist $hnode] {
-      set_save $hnode/$hp $mode false
-    }
-    if {$top == "true"} { 
-      hsetprop $hnode nxsave $mode
-      if {$mode == "true"} {
-        set hp ""
-        foreach ps [lrange [split [string trim $hnode /] /] 0 end-1] {
-          set hp $hp/$ps
-          hsetprop $hp nxsave true
-        } 
-      }
-    } else {
-      hsetprop $hnode nxsave $mode
+##
+# @brief Set the save state for the given subtree
+#
+# @param hpath The save state of the nodes below this path will be set
+# @param mode true or false
+# @param top This is just here to make the recursion work from the top level, You don't need 
+# to set this
+proc ::hdb::set_save {hpath mode {top true}} {
+  if {$hpath != "/"} {
+    set hnode $hpath
+  } else {
+    foreach hp [hlist /] {
+    ::hdb::set_save /$hp $mode
+  }
+    return
+  }
+  if {[::utility::hgetplainprop $hnode data] == "false"} {
+    return
+  }
+  foreach hp [hlist $hnode] {
+    set_save $hnode/$hp $mode false
+  }
+  if {$top == "true"} {
+    hsetprop $hnode nxsave $mode
+    if {$mode == "true"} {
+      set hp ""
+      foreach ps [lrange [split [string trim $hnode /] /] 0 end-1] {
+        set hp $hp/$ps
+        hsetprop $hp nxsave true
+      } 
     }
+  } else {
+    hsetprop $hnode nxsave $mode
   }
 }
+
+namespace import ::hdb::*
diff --git a/site_ansto/instrument/config/hipadaba/instdict_specification.tcl b/site_ansto/instrument/config/hipadaba/instdict_specification.tcl
index 3ff40d52..3e3d8cc2 100644
--- a/site_ansto/instrument/config/hipadaba/instdict_specification.tcl
+++ b/site_ansto/instrument/config/hipadaba/instdict_specification.tcl
@@ -16,12 +16,9 @@ set sobj_sicstype_list {environment_controller sicsvariable macro motor configur
 # Different kinds of things are added to the hdb in different ways.
 # command: This is something a client can run with hset /a/b/c start, it may have parameters and feedback.
 #          Parameters and feedback should be made available in 'ilists' named after the command.
-# ilist: An intelligent list, it's like a list comprehension that takes a closure as the mapping function.
-# event: This is an associative array which can be watched for modifications. You can use the array index
-#        to choose an action.
 # script: Supplies an rscript and a wscript to attach to a node for hgets and hsets.
 # hobj: Something that can be hattached to a node. {motor sicsvariable histmem}.
-set sobj_kind_list {command event hobj ilist script}
+set sobj_kind_list {command hobj script}
 set sobj_interfacelist [subst {drivable {$boolean} countable {$boolean} callback {$boolean} environment {$boolean} }]
 
 set privilege_list {spy user manager read_only internal}