##
# @file hipadaba_configuration_common.tcl
# @brief Commands for building the hdb tree from sics object properties and an instrument dictionary.
#
# hobj policy: data=false control=parent nxsave=false klass=parent
# subtree/group_path policy:  data=parent control=parent nxsave=parent klass=parent
# type=macro & klass=command -> kind=command
# type=macro & klass!=command -> kind=script
# kind=script must have access property (read_only, read_write) and dtype and dlen

source $cfPath(hipadaba)/instdict_specification.tcl
source $cfPath(hipadaba)/common_instrument_dictionary.tcl

namespace eval ::hdb {
namespace export buildHDB attlist

set sobjadd_state(depends) false

set NXlog_template {
  NXlog {
    $name {
      $paramarr(time)
      $paramarr(value)
      $paramarr(raw_value)
      $paramarr(description)
      $paramarr(average_value)
      $paramarr(average_value_error)
      $paramarr(minimum_value)
      $paramarr(maximum_value)
      $paramarr(duration)
    }
  }
}

set NXnote_template {
  NXnote {
    $name {
      $paramarr(author)
      $paramarr(date)
      $paramarr(type)
      $paramarr(file_name)
      $paramarr(description)
      $paramarr(data)
    }
  }
}

set NXbeam_template {
  $name {
    $paramarr(distance)
    $paramarr(incident_energy)
    $paramarr(final_energy)
    $paramarr(energy_transfer)
    $paramarr(incident_wavelength)
    $paramarr(incident_wavelength_spread)
    $paramarr(incident_beam_divergence)
    $paramarr(final_wavelength)
    $paramarr(incident_polarization)
    $paramarr(final_polarization)
    $paramarr(final_wavelength_spread)
    $paramarr(final_beam_divergence)
    $paramarr(flux)
  }
}

# NOTE: paramarr(offset) was added for Quokka's DetPosYOffsetmm parameter
set NXgeometry_template {
  NXgeometry {
    geometry {
      sobjlist {$paramarr(geomdescription)}
      NXshape {
        shape {
          sobjlist {$paramarr(shape) $paramarr(size)}
        }
      }
      NXtranslation {
        position {
          sobjlist {$paramarr(position) $paramarr(offset) $paramarr(coordinate_scheme)}
          NXgeometry {
            geometry {
              link {
                target {$paramarr(refpos)}
                nxalias {$paramarr(position)}
              }
            }
          }
        }
      }
      NXorientation {
        orientation {
          sobjlist {$paramarr(orientation)}
        }
      }
    }
  }
}

set NXaperture_template [subst -novariables {
  NXaperture {
    $name {
      sobjlist {$paramarr(material) $paramarr(description)}
      [ set NXgeometry_template ]
    }
  }
} ]

set NXvelocity_selector_template [subst -novariables {
  NXvelocity_selector {
    $name {
      sobjlist {
        $paramarr(type)
        $paramarr(rotation_speed)
        $paramarr(radius)
        $paramarr(spwidth)
        $paramarr(length)
        $paramarr(num)
        $paramarr(twist)
        $paramarr(table)
        $paramarr(height)
        $paramarr(width)
        $paramarr(wavelength)
        $paramarr(wavelength_spread)
      }
      [ set NXgeometry_template ]
    }
  }
} ]
}

proc ::hdb::MakeLog {name klass paramlist} {
  variable NXlog_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXlog_template
  ::hdb::subtree_macro $name $klass $newtable
}
proc ::hdb::MakeNote {name klass paramlist} {
  variable NXnote_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXnote_template
  ::hdb::subtree_macro $name $klass $newtable
}
proc ::hdb::MakeBeam {name klass paramlist} {
  variable NXbeam_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXbeam_template
  ::hdb::subtree_macro $name $klass $newtable
}

proc ::hdb:MakeEnvironment {name klass paramlist} {
  variable NXenvironment_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXenvironment_template
  ::hdb::subtree_macro $name $klass $newtable
}

proc ::hdb::MakeGeometry {name klass paramlist} {
  variable NXgeometry_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXgeometry_template
  ::hdb::subtree_macro $name $klass $newtable
}

##
# @brief Generates an hdb subtree macro from a named list of SICS objects.
#
# NOTE: Currently the only SICS objects supported are 'sicsvariable' and 'macro'.
# @param name, This is the name of the aperture.
# @paramlist, A name value list of aperture parameters. All parameters are optional.
proc ::hdb::MakeAperture {name paramlist} {
  array set paramarr $paramlist
  variable NXaperture_template
  set newtable [list]
  prune_NX newtable $NXaperture_template
  ::hdb::subtree_macro $name instrument $newtable
}

proc ::hdb::MakeVelocity_Selector {name paramlist} {
  variable NXvelocity_selector_template
  array set paramarr $paramlist
  set newtable [list]
  prune_NX newtable $NXvelocity_selector_template
  ::hdb::subtree_macro $name instrument $newtable
}

##
# @brief This simplifies a NeXus-class template by removing unnecessary branches.
# A NeXus-class template is a keyed-list which has Tcl variables for some of the nodes,
# if the Tcl variables aren't defined for some branch then that branch is removed.
# All other variables are expanded in place, also all 'sobjlists' are split up into type
# specific lists.  This is intended as a helper function for commands which generate
# NeXus-class keyed lists from a simple set of optional parameters.
#
# @param NXklist, This is a keyed list representation of the NeXus class which will be augmented
# with the pruned nx_template. Note this can just be an empty list.
# @param nx_template, The NeXus-class template which will be pruned.
# @param path, (optional, default="") Parent path in recursive calls.
# @param node, (optional, default="") Current node in recursive calls.
# @param level, (optional,default=1) The location of the template parameters in the callstack.
proc prune_NX {NXklist nx_template {path ""} {node ""} {level 1}} {
  upvar $NXklist newtable
  if {$path == ""} {
    set currpath $node
  } else {
    set currpath $path/$node
  }
  foreach {n v} $nx_template {
    switch $n {
      "sobjlist" {
        set has_sobj 0
        foreach var $v {
          if {[string index $var 0] == "$"} {
          set vn [string range $var 1 end]
          upvar $level $vn lvar
          if [info exists lvar] {
            foreach sobj $lvar {
              lappend [getatt $sobj type]_list $sobj
            }
            set has_sobj 1
          }
          } else {
            foreach sobj $var {
              lappend [getatt $sobj type]_list $sobj
            }
            set has_sobj 1
          }
        }
        if {$has_sobj} {
          if [info exists sicsvariable_list] {
          ::utility::tabset newtable $currpath/sicsvariable [subst {{$sicsvariable_list}}]
          }
          if [info exists macro_list] {
          ::utility::tabset newtable $currpath/macro [subst {{$macro_list}}]
          }
        } else {
        }
      }
      "link" {
        set linktarget ""
        array set linkinfo $v
        if {[string index $linkinfo(target) 0] == "$"} {
          set vn [string range $linkinfo(target) 1 end]
          upvar $level $vn lvar
          if [info exists lvar] {
            set linktarget $lvar
          }
        } else {
            set linktarget $linkinfo(target)
        }
        if {[string index $linkinfo(nxalias) 0] == "$"} {
          set vn [string range $linkinfo(nxalias) 1 end]
          upvar $level $vn avar
        if [info exists avar] {
          set linkname $avar
        }
        } else {
          set linkname $linkinfo(nxalias)
        }
        if {$linktarget != ""} {
          ::utility::tabset newtable $currpath/link/target [subst {{$linktarget}}]
          ::utility::tabset newtable $currpath/link/nxalias [subst {{$linkname}}]
        }
      }
      default {
        if {[string range $n 0 1] == "NX"} {
          set node $n
        } elseif {[string index $n 0] == "$"} {
          set vn [string range $n 1 end]
          upvar $level $vn lvar
          if [info exists lvar] {
            set node $lvar
          } else {
          }
        } else {
          set node $n
        }
        prune_NX newtable $v $currpath $node [expr $level+1]
      }
    }
  }
}

##
# @brief Make an aperture
#
# @param args optional name and description variables
#proc MakeAperture {apname nxgeometry args} {
#  set nxaperture [::hdb::NXaperture $apname $nxgeometry $args]
#  ::hdb::subtree_macro $apname instrument $nxaperture
#}

##
# @brief Generate a subtree macro procedure
#
# @param Name of the subtree macro
# @klass Category which the macro belongs to (usually a NeXus class)
# @klist A keyed list which describes the subtree.
proc ::hdb::subtree_macro {name klass klist} {
  set st_macroname ${name}_subtree_macro
  proc ::hdb::$st_macroname {} "return [list $klist]"
  ::hdb::set_subtree_props ::hdb::$st_macroname $klass
}

##
# @brief Publish an hdb_subtree macro and initialise it's property list
#
# @param st_name The name of the hdb_subtree macro
# @param klass Where should the subtree be placed in the hdb heirarchy
# @param control (optional, default=true) Add it to the control interface?
# @param privilege (optional, default=user) Modification privilege.
proc ::hdb::set_subtree_props {st_name klass {control "true"} {privilege "user"} } {
  publish $st_name mugger
  sicslist setatt $st_name klass $klass
  sicslist setatt $st_name control $control
  sicslist setatt $st_name privilege $privilege
  sicslist setatt $st_name kind "hdb_subtree"
  sicslist setatt $st_name long_name "@none"
  sicslist setatt $st_name data "true"
  sicslist setatt $st_name nxsave "true"
}

# @brief Add a subtree to a given hipadaba path.
#
# @param hpath, Basepath for subtree
# @param object, SICS object name
# @param subtree, A nested Tcl list which represents the subtree
# @param type, the SICS object type if we are adding SICS object node. Optional, default = @none.
# @param makenode, type of node to make. Optional, default = @none.
proc ::hdb::add_subtree {hpath subtree {object @none} {type @none} {makenode @none}} {
  set ::errorInfo ""
  set SICStypes {sicsvariable macro}
  if [catch {
    switch $makenode {
      "@none" {
        foreach {n v} $subtree {
          if {[lsearch -exact $::nexus_classes $n] >= 0} {
            add_subtree $hpath $v $object $n NXclass
          } elseif {[lsearch -exact $SICStypes $n] >= 0} {
            add_subtree $hpath $v $object $n sicsobject
          } elseif {$n=="link"} {
            add_subtree $hpath $v $object $n link
          } else {
            error "ERROR:Unknown type, '$n'"
          }
        }
      }
      "NXclass" {
        foreach {item val} $subtree {
          add_hpath $hpath $item
          hsetprop $hpath/$item klass $type
          add_subtree $hpath/$item $val $object
        }
      }
      "sicsobject" {
        foreach item $subtree {
          if {$item==$object} {
            error "ERROR: Infinite recursion, cannot add $item as a node to it's own hdb subtree"
          }
          set objtype [getatt $item type]
          if {$type != $objtype} {
            error "ERROR: Specified type of '$type' doesn't match actual type, '$objtype', for $item"
          }
          sobjadd $hpath $item
        }
      }
      "link" {
        set target [::utility::tabget subtree target]
        set nxalias [::utility::tabget subtree nxalias]
        foreach l $nxalias t $target {
          set refname [normalgetatt $t long_name]
          ::hdb::add_hpath $hpath $refname
          hsetprop $hpath/$refname data "true"
          hsetprop $hpath/$refname nxsave "false"
          hsetprop $hpath/$refname control "false"

          hsetprop $hpath/$refname link $t
          hsetprop $hpath/$refname nxalias ${l}_link
          hsetprop $hpath/$refname type nxvgroup
          hsetprop $hpath/$refname klass @none
        }
      }
      default {
        error "ERROR: Unknown node type, $makenode"
      }
    }
  } message ] {
    if {$::errorCode=="NONE"} {return $hpath}
    return -code error $message
  }
}
##
# @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 catch_status [ catch {
    set parent $basePath
    array set prop_arr [hlistprop $basePath tcllist]
    foreach child [split $path /] {
      if {[lsearch [hlist $parent] $child] == -1} {
        hmake $parent/$child $priv $dtype $dlen
        if {$basePath != "/"} {
          hsetprop $parent/$child data $prop_arr(data)
          hsetprop $parent/$child control $prop_arr(control)
          hsetprop $parent/$child nxsave $prop_arr(nxsave)
          hsetprop $parent/$child klass @none
          hsetprop $parent/$child type $prop_arr(type)
        }
      }
      if {$parent == "/"} {
        set parent /$child
      } else {
        set parent $parent/$child
      }
    }
    return $parent
  } message ]
  handle_exception $catch_status $message
}

##
# @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
  foreach {prop pval} [::utility::normalattlist $sobj] {
    hsetprop $hpath/$name $prop $pval
  }
  hsetprop $hpath/$name data false
}

##
# @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
  }
  hsetprop $hpath/$name privilege READ_ONLY
}

##
# @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
  variable sobjadd_state

  array unset arg_array
  set catch_status [ catch {
    array set arg_array $args
    if {[info exists arg_array(path)] && [info exists arg_array(prop_list)]} {
      add_hpath $basePath $arg_array(path)
      if {$basePath == "/"} {
        set node_path /$arg_array(path)
      } else {
        set node_path $basePath/$arg_array(path)
      }
    #  if {[info exists arg_array(prop_list)]} {
        foreach {prop pval} $arg_array(prop_list) {
          hsetprop $node_path $prop $pval
        }
    #  }
      return $node_path
    }

    if {![info exists arg_array(dlen)]} {
      set arg_array(dlen) ""
    }
    set gp_path [file dirname $arg_array(node)]
    set node_name [file tail $arg_array(node)]
    if {$gp_path != "."} {
      add_hpath $basePath $gp_path
      set basePath $basePath/$gp_path
      hsetprop $basePath type part
    }
    if {[lsearch [hlist $basePath] $node_name] == -1} {
    #TODO allow hdb nodes of type drivable countable environment
      array set attribute [::utility::normalattlist $node_name]
      switch $arg_array(kind) {
        command {
          # A command is a macro, node=macro name
          set command $node_name
          set cmd_path [add_command $basePath $command]
          set node_path $cmd_path
          # The extra arguments for add_node are supplied by the command parameters
          # and command feedback procedures.
          if {[string length [info procs ${command}_parameters]] > 0} {
            ${command}_parameters add_node $cmd_path
          } else {
            $command -map param ::hdb::add_cmd_par $cmd_path
          }
          if {[string length [info procs ${command}_feedback]] > 0} {
            add_hpath $cmd_path feedback
            hsetprop $cmd_path/feedback type part
            ${command}_feedback add_node $cmd_path/feedback
          } else {
            add_hpath $cmd_path feedback
            hsetprop $cmd_path/feedback type part
            $command -map feedback ::hdb::add_feedback $cmd_path/feedback
          }
        }
        hobj {
          set hobj_long_name [normalgetatt $node_name long_name]
          hattach $basePath $node_name $hobj_long_name
          set node_path $basePath/$hobj_long_name
          hsetprop $node_path data    [getatt $node_name data]
          hsetprop $node_path control [getatt $node_name control]
          hsetprop $node_path nxsave  [getatt $node_name nxsave]
          hsetprop $node_path mutable  [getatt $node_name mutable]
          hsetprop $node_path klass   [getatt $node_name klass]
          if [info exists attribute(hdbchain)] {
            foreach pmot [split $attribute(hdbchain) ,] {
              hchain $node_path [lindex [split [getatt $pmot hdb_path] ,] 0]
            }
          }
          foreach child [hlist $node_path] {
            hsetprop $node_path/$child data    false
            hsetprop $node_path/$child control [getatt $node_name control]
            hsetprop $node_path/$child nxsave  false
            hsetprop $node_path/$child klass   [getatt $node_name klass]
          }
        }
        script - getset {
          # A r/w pair of scripts, node = a node path
          set node_path $basePath/[normalgetatt $node_name long_name]
          set data_type [getatt $node_name dtype]
          set data_length [getatt $node_name dlen]
           if {[getatt $node_name access] == "read_only"} {
             hmakescript $node_path $node_name hdbReadOnly $data_type $data_length
           } else {
             hmakescript $node_path $node_name $node_name $data_type $data_length
           }
           hsetprop $node_path sicsdev $node_name
           hsetprop $node_path nxalias $node_name
           hsetprop $node_path data [getatt $node_name data]
           hsetprop $node_path control [getatt $node_name control]
           hsetprop $node_path klass [getatt $node_name klass]
           hsetprop $node_path sdsinfo [getatt $node_name sdsinfo]
           hsetprop $node_path savecmd [getatt $node_name savecmd]
          #hmakescript $node_path $arg_array(rscript) $arg_array(wscript) $arg_array(dtype) $arg_array(dlen)
        }
      }
      if {[info exists attribute(units)]} {
        hsetprop $node_path units [normalgetatt $node_name units]
      }
      if {[info exists arg_array(prop_list)]} {
        foreach {prop pval} $arg_array(prop_list) {
          hsetprop $node_path $prop $pval
        }
      }
      if {[info exists attribute(depends)]} {
        foreach dep [split [normalgetatt $node_name depends] , ] {
          set sobjadd_state(depends) true
          ::hdb::sobjadd $node_path $dep
          set sobjadd_state(depends) false
        }
      }
      if { $sobjadd_state(depends) == false && [info exists attribute(hdb_path)] } {
        sicslist setatt $node_name hdb_path $attribute(hdb_path),$node_path
      } else {
        sicslist setatt $node_name hdb_path $node_path
      }
      return $node_path
    }
  } message ]
    handle_exception $catch_status $message
}

##
# @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 {
  if {[info exists cmd_atts(group)]} {
    add_hpath $basePath $cmd_atts(group)
    set basePath $basePath/$cmd_atts(group)
    hsetprop $basePath type part
  }
  }
  set hcom_long_name [normalgetatt $command long_name]
  hcommand $basePath/$hcom_long_name $command
  set cmd_path $basePath/$hcom_long_name
  hsetprop $cmd_path privilege $cmd_atts(privilege)
  hsetprop $cmd_path type $cmd_atts(kind)
  hsetprop $cmd_path data $cmd_atts(data)
  hsetprop $cmd_path control $cmd_atts(control)
  hsetprop $cmd_path klass $cmd_atts(klass)
  hsetprop $cmd_path nxsave $cmd_atts(nxsave)
  hsetprop $cmd_path sicsdev $cmd_atts(id)
  return $cmd_path
}

##
# @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} {
  if [ catch {
    foreach att [tolower_sicslist $sicsobj] {
      lappend atts [split [string range $att 0 end-1] =]
    }
    return [join $atts]
  } message ] {
    if {$::errorCode=="NONE"} {return $message}
    return -code error $message
  }
}


##
# @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 {
    command,macro {
      return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind command]]
    }
    script,macro {
      return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind script]]
    }
    "@any" {
      foreach st $sobj_sicstype_list {
        lappend sobjects [tolower_sicslist type $st]
      }
      return [intersection [join $sobjects] [tolower_sicslist klass $aklass]]
    }
    default {
      return [intersection [tolower_sicslist type $atype] [tolower_sicslist klass $aklass]]
    }
  }
}

##
# @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]
}

##
# @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
  set catch_status [ catch {
    array set sobjatt [attlist $sobj]
    if {[sicslist exists $sobj id] == false} {
      sicslist setatt $sobj id $sobj
    }
    switch $sobjatt(type) {
      motor - configurablevirtualmotor - tasmot {
        if {[info exists sobjatt(group)]} {
          set hpath [add_hpath $hpath $sobjatt(group)]
          if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
        }
        if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
        set node_path [add_node $hpath node $sobj long_name [normalgetatt $sobj long_name] kind $sobjatt(kind)]
        if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
        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}
        } else {
          clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
        }
      }
      macro {
      # access attribute = ro,rw
        if {[info exists sobjatt(group)]} {
          set hpath [add_hpath $hpath $sobjatt(group)]
          if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
        }
        if {[lsearch [hlist $hpath] $sobjatt(long_name)] >= 0} {
          clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
        } elseif {$sobjatt(kind) == "hdb_subtree"} {
          add_subtree $hpath [$sobj]
        } else {
          set node_path [add_node $hpath kind $sobjatt(kind) node $sobj priv $sobjatt(privilege) ]
          if [info exists sobjatt(mutable)] {
            if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
          }
        }
      }
      sicsvariable {
        if {[info exists sobjatt(group)]} {
          set hpath [add_hpath $hpath $sobjatt(group)]
          if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
        }
        if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
          set node_path [add_node $hpath node $sobj long_name [normalgetatt $sobj long_name] kind $sobjatt(kind)]
          if {[catch {hsetprop $node_path sicsdev $sobj} err]} {clientput $err error}
          if {[catch {hsetprop $node_path nxalias $sobj} err]} {clientput $err error}
          if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
          if {[catch {hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
          if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
          if {[catch {hsetprop $node_path privilege $sobjatt(privilege)} err]} {clientput $err error}
        } else {
          clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
        }
      }
      node {
      }
      singlecounter {
  # TODO
        todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      }
      histmem {
        if {[info exists sobjatt(group)]} {
          set hpath [add_hpath $hpath $sobjatt(group)]
          if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
        }
        if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
          set node_path [add_node $hpath node $sobj long_name [normalgetatt $sobj long_name] kind $sobjatt(kind)]
          if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
          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}
          if {[catch {hsetprop $node_path sicsdev $sobj} err]} {clientput $err error}
        } else {
          clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
        }
      }
      chopperadapter {
        if {[info exists sobjatt(group)]} {
          set hpath [add_hpath $hpath $sobjatt(group)]
          hsetprop $hpath type part
        }
        if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
          set node_path [add_node $hpath node $sobj long_name [normalgetatt $sobj long_name] kind $sobjatt(kind)]
          hsetprop $node_path sicsdev $sobj
          hsetprop $node_path nxalias $sobj
          hsetprop $node_path savecmd $sobjatt(savecmd)
          hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
          hsetprop $node_path mutable $sobjatt(mutable)
          hsetprop $node_path privilege $sobjatt(privilege)
        } else {
          clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
        }
      }
      nxscript {
  # TODO
        todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      }
      sicsdata  {
  # TODO
        todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      }
      scanobject {
  # TODO
        todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      }
      # TODO Can this be replaced with a sct_* glob?
      sct_object {
        set node_name [normalgetatt $sobj long_name]
        set node_path $hpath/$node_name
        hfactory $node_path link $sobj
        hsetprop $node_path type $sobjatt(type)
        sicslist setatt $sobj hdb_path $node_path
      }
      environment_controller {
        todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      }
      default {
        error "ERROR: Unknown sics object type $sobjatt(type)"
      }
    }
  } message ]
  handle_exception $catch_status $message
}
proc ::hdb::write_poll {pollnode val} {
  hsetprop $pollnode poll_interval $val
  sicspoll intervall $pollnode $val
}
proc ::hdb::read_poll {pollnode} {
  return [getatt $pollnode]
}

##
# @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} {
  set catch_status [ catch {
    foreach {sobj} [sobjlist $sobjtype $given_klass] {
      array unset sobjatt
      array set sobjatt [attlist $sobj]
      if {[info exists sobjatt(privilege)] && $sobjatt(privilege) != "internal"} {
        sobjadd $hpath $sobj
      }
    }
  } message ]
  handle_exception $catch_status $message
}


##
# @brief Remove empty instrument dictionary nodes
#
# @param instdict name of the instrument dictionary structure
#
# Nodes which have no child nodes and no associated sics objects for the
# current instrument are removed.
proc ::hdb::prune {instdict} {
  upvar $instdict dict
  array set dictarr $dict
  foreach {n v} $dict {
    lappend candidates $n
  }
  # While there are candidates for removal remove the childless ones
  # which have an empty sobj list
  while {[expr [llength $candidates]] > 0} {
    set new_candidates ""
    foreach name $candidates {
      array unset dictval
      array set dictval $dictarr($name)
      if {[lsearch $dictval(property) nxvgroup] >= 0} {
        # Link targets are not candidates for pruning
        continue
      }
      set sobjects ""
      if {[info exists dictval(sobj)]} {
        foreach {t k} $dictval(sobj) {
          lappend sobjects [sobjlist $t $k]
        }
      }
      if { [llength [join $sobjects]] == 0 } {
        if {[llength [array get dictarr $name/*]] == 0} {
          array unset dictarr $name
          set tempdict ""
          foreach {n v} $dict {
            if {$n != $name} {
              lappend tempdict $n
              lappend tempdict $v
            }
          }
          set dict $tempdict
        } else {
          if {[lsearch $candidates $name/*] >= 0} {
            lappend new_candidates $name
          }
        }
      }
    }
    set candidates $new_candidates
  }
  return
}

proc ::hdb::alias {parent linkpath NXtarget name } {
  set catch_status [ catch {
    if {$NXtarget != "data_set"} {
      return -code error "Unhandled target alias $NXtarget"
    }
    hfactory $parent/$name alias $linkpath
  } message ]
  handle_exception $catch_status $message
}

##
# @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
#
# @see prune
proc ::hdb::buildHDB {instDict} {
#TODO add data control nxsave nxtyp properties
upvar #0 $instDict dictionary
  set catch_status [ catch {
    prune dictionary
    foreach {n v} $dictionary {
      array unset varr
      array set varr $v
      array unset property_array
      array set property_array $varr(property)
      add_node / path $n prop_list $varr(property)
      if {[info exists varr(sobj)]} {
        foreach {sicstype sobj_klass} $varr(sobj) {
        sobjtypeadd /$n $sicstype $sobj_klass
        }
      }
    }
    foreach node [hmatchprop / permlink *] {
      set plink [hgetpropval $node permlink]
      if {[llength $plink] > 1} {
        set target [lindex $plink 0]
        if {$target == "data_set" && [hgetpropval $node control]} {
          ::hdb::alias "/control" $node {*}$plink
        }
      }
    }
  } message ]
  handle_exception $catch_status $message
}

##
# @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 [ catch {
    if {$hpath != "/"} {
      set hnode $hpath
      if {[hpropexists $hnode data] && [hgetpropval $hnode data] != "false"} {
        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
        }
      }
    } else {
      foreach hp [hlist /] {
        ::hdb::set_save /$hp $mode
      }
    }
} message ] {
  return -code error "([info level 0]) $message"
}
}

namespace import ::hdb::*