hipadaba prototype support files.

They generate hipadaba paths for devices along with the xml description.

r1236 | ffr | 2006-11-07 08:34:20 +1100 (Tue, 07 Nov 2006) | 3 lines

site_ansto/instrument/hipadaba/ParList.tcl

@@ -0,0 +1,49 @@
+set countParList [list \
+      setpreset USER Float\
+      getpreset READ_ONLY Float\
+      setexponent USER Float\
+      getexponent READ_ONLY Float\
+      setmode USER Float\
+      getmode READ_ONLY Float\
+      setexponent USER Float\
+      getcounts READ_ONLY Float\
+      getmonitor READ_ONLY Float\
+      count USER Float\
+      status READ_ONLY Text\
+      gettime READ_ONLY Float\
+      getthreshold READ_ONLY Float\
+      setthreshold USER Float\
+      send MANAGER Text\
+]
+
+set motParList [list \
+      position USER Float\
+      accesscode MANAGER Float\
+      failafter MANAGER Float\
+      fixed USER Float\
+      hardlowerlim MANAGER Float\
+      hardupperlim MANAGER Float\
+      ignorefault MANAGER Float\
+      interruptmode MANAGER Float\
+      maxretry MANAGER Float\
+      movecount MANAGER Float\
+      precision MANAGER Float\
+      sign MANAGER Float\
+      softlowerlim USER Float\
+      softupperlim USER Float\
+      softzero USER Float\
+      accel USER Float\
+      decel USER Float\
+      home MANAGER Float\
+      maxaccel READ_ONLY Float\
+      maxdecel READ_ONLY Float\
+      maxspeed READ_ONLY Float\
+      speed USER Float\
+]
+
+set virtmotParList [list \
+      position USER Float\
+]
+
+set hmParList [list \
+]

site_ansto/instrument/hipadaba/gen_hipadaba.tcl

@@ -0,0 +1,20 @@
+# $Revision: 1.1 $
+# $Date: 2006-11-06 21:34:20 $
+# Author: Ferdi Franceschini (ffr@ansto.gov.au)
+# Last revision by: $Author: ffr $
+
+source hipadaba_support.tcl
+#-------------------------------------------------------------------------
+#  Install the SICS Hipadaba
+#-------------------------------------------------------------------------
+InstallHdb
+source hipadaba_configuration.tcl
+
+proc xhlist {opt args} {
+set fh [open InstXML.tcl];
+set InstXML [read $fh];
+close $fh;
+clientput  $InstXML "value"
+}
+publish xhlist spy
+

site_ansto/instrument/hipadaba/gen_hpdbxml.tcl

@@ -0,0 +1,25 @@
+#!/usr/bin/tclsh
+
+set instName [lindex $argv 0];
+
+proc clientput {msg code} {puts $msg}
+source hipadaba/ParList.tcl
+source hipadaba/hpdbxml.tcl
+array set accesscode [list 0 READ_ONLY 1 MANAGER 2 USER 3 SPY ];
+
+proc genXML {instrument} {
+  global doc;
+  array set instPath [list Echidna hrpd Wombat hipd];
+
+  instrumentXML $instrument;
+  source $instPath($instrument)/hipadaba_configuration.tcl;
+  set fh [open $instPath($instrument)/InstXML.tcl w];
+  puts -nonewline $fh "<?xml version = '1.0' encoding = 'UTF-8'?>";
+  puts -nonewline $fh [$doc asXML -indent none];
+  close $fh;
+}
+
+
+if {$tcl_interactive==0} {
+  genXML $instName;
+}

site_ansto/instrument/hipadaba/hipadaba_support.tcl

@@ -0,0 +1,34 @@
+# Makes hipadaba scripts for sics devices.
+source ParList.tcl
+
+proc makeHdbCounter {hpath treename sicsname} {
+	global countParList;
+	append Name $hpath "/" $treename
+	eval hmake $Name spy none
+	foreach {name priv type} $countParList {
+		set parName [format "%s/%s" $Name $name]
+		eval hmakescript $parName \"$sicsname $name\" \"$sicsname $name\" float
+	} 
+}
+proc makeHdbMotor {hpath treename sicsname} {
+	global motParList;
+	append motName $hpath "/" $treename
+	eval hmake $motName spy none
+	eval hmakescript "$motName/position" \"$sicsname\" \"run $sicsname\" float
+	foreach {name priv type} $motParList {
+		set parName [format "%s/%s" $motName $name]
+		eval hmakescript $parName \"$sicsname $name\" \"$sicsname $name\" float
+	} 
+}
+proc makeHdbVirtMotor {hpath treename sicsname} {
+	append motName $hpath "/" $treename
+	eval hmake $motName spy none
+	eval hmakescript "$motName/position" \"$sicsname\" \"run $sicsname\" float
+}
+#FIXME implement makeHdbHM
+proc makeHdbHM {hpath treename sicsname} {
+}
+#------------------------------------------------------------------------
+proc hdbReadOnly {} {
+	error "Parameter is READ ONLY"
+} 

site_ansto/instrument/hipadaba/hpdbxml.tcl

@@ -0,0 +1,90 @@
+package require tdom;
+set tags [list part device property];
+foreach tag $tags {dom createNodeCmd elementNode $tag}
+
+# hmake path priv dataType [length]
+proc hmake {hpath priv dataType args} {
+  global doc root part;
+  set parent $root;
+  foreach pid [split [string trimleft $hpath /] /] {
+    set node [eval "$parent selectNodes {//part\[@id='$pid'\]}"];
+    if {$node == ""} {
+      set child [$doc createElement part];
+      $child setAttribute id $pid;
+      $parent appendChild $child;
+      set parent $child;
+    } else {
+      set parent $node;
+    }
+  }
+}
+
+proc instrumentXML {instrument} {
+  global doc root
+  set doc [dom createDocumentNS commonj.sdo sdo:datagraph];
+  set root [$doc createElementNS http://www.psi.ch/sics/hipadaba hipadaba:Instrument];
+  $root setAttribute label $instrument;
+  [$doc documentElement] appendChild $root;
+}
+
+# Return node corresponding to hpath
+proc hpathNode {hpath} {
+  global root;
+  set partsList [split [string trimleft $hpath /] /];
+# make selectNodes argumet
+  set snarg "{/";
+  foreach pid $partsList {
+    set p [subst -nocommand {/part[@id='$pid']}];
+    set snarg [append snarg $p];
+  }
+  set snarg [append snarg "}"];
+  set node [eval "$root selectNodes $snarg"];
+  return $node;
+}
+proc makeHdbMotor {hpath treename sicsname} {
+  global motParList;
+  set node [hpathNode $hpath];
+  if {$node == ""} {
+    clientput "$hpath doesn't exist" error;
+    return 1;
+  }
+  $node appendFromScript {
+    device id $treename {
+      foreach {name priv type} $motParList {
+        property privilege $priv dataType $type id $name;
+      }
+    }
+  }
+}
+
+proc makeHdbVirtMotor {hpath treename sicsname} {
+  global virtmotParList;
+  set node [hpathNode $hpath];
+  if {$node == ""} {
+    clientput "$hpath doesn't exist" error;
+    return 1;
+  }
+  $node appendFromScript {
+    device id $treename {
+      foreach {name priv type} $virtmotParList {
+        property privilege $priv dataType $type id $name;
+      }
+    }
+  }
+}
+
+proc makeHdbHM {hpath treename sicsname} {
+  global hmParList;
+  set node [hpathNode $hpath];
+  if {$node == ""} {
+    clientput "$hpath doesn't exist" error;
+    return 1;
+  }
+  $node appendFromScript {
+    device id $treename {
+      foreach {name priv type} $hmParList {
+        property privilege $priv dataType $type id $name;
+      }
+    }
+  }
+}