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/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;
+      }
+    }
+  }
+}