145 lines
4.1 KiB
Tcl
145 lines
4.1 KiB
Tcl
# Commands to generate xml tags for instrument description file
|
|
package require tdom;
|
|
|
|
# To add a new element in the instrument xml file do the following,
|
|
# 1. Add the element name to the tags list
|
|
# 2. Modify the hdbMakeXML procedures that should use the new element
|
|
|
|
# This is a list of the xml tags in an instrument xml file.
|
|
set tags [list part device property val];
|
|
foreach tag $tags {dom createNodeCmd elementNode $tag}
|
|
dom createNodeCmd textNode text_node;
|
|
|
|
# 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 argument
|
|
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;
|
|
}
|
|
|
|
# This code is shared by Motor and ConfigurableVirtualMotor objects.
|
|
set hdbMakeAnyMotorXML {
|
|
set node [hpathNode $hpath];
|
|
if {$node == ""} {
|
|
clientput "$hpath doesn't exist" error;
|
|
return 1;
|
|
}
|
|
$node appendFromScript {
|
|
foreach {ppName ppPriv ppType ppValue} $primaryProperty {}
|
|
device id $treename deviceType $deviceType primaryProperty $ppName {
|
|
property privilege $ppPriv dataType $ppType id $ppName {
|
|
foreach v $ppValue { val {text_node $v}}
|
|
}
|
|
foreach {name priv type value} $parList {
|
|
property privilege $priv dataType $type id $name {
|
|
foreach v $value { val {text_node $v}}
|
|
}
|
|
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc ::deviceType::Motor::hdbMakeXML {hpath treename sicsname} {
|
|
variable parList;
|
|
variable deviceType;
|
|
variable primaryProperty;
|
|
global hdbMakeAnyMotorXML;
|
|
eval $hdbMakeAnyMotorXML;
|
|
}
|
|
|
|
proc ::deviceType::ConfigurableVirtualMotor::hdbMakeXML {hpath treename sicsname} {
|
|
variable parList;
|
|
variable deviceType;
|
|
variable primaryProperty;
|
|
global hdbMakeAnyMotorXML;
|
|
eval $hdbMakeAnyMotorXML;
|
|
}
|
|
|
|
proc ::deviceType::SingleCounter::hdbMakeXML {hpath treename sicsname} {
|
|
variable parList;
|
|
variable deviceType;
|
|
variable primaryProperty;
|
|
set node [hpathNode $hpath];
|
|
if {$node == ""} {
|
|
clientput "$hpath doesn't exist" error;
|
|
return 1;
|
|
}
|
|
$node appendFromScript {
|
|
foreach {ppName ppPriv ppType ppValue} $primaryProperty {}
|
|
device id $treename deviceType $deviceType primaryProperty $ppName {
|
|
property privilege $ppPriv dataType $ppType id $ppName {
|
|
foreach v $ppValue { val {text_node $v}}
|
|
}
|
|
foreach {name priv type value} $parList {
|
|
property privilege $priv dataType $type id $name {
|
|
foreach v $value { val {text_node $v}}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc makeHdbMotor {hpath treename sicsname} {
|
|
::deviceType::Motor::hdbMakeXML $hpath $treename $sicsname;
|
|
}
|
|
|
|
proc makeHdbVirtMotor {hpath treename sicsname} {
|
|
::deviceType::ConfigurableVirtualMotor::hdbMakeXML $hpath $treename $sicsname;
|
|
}
|
|
|
|
proc makeHdbCounter {hpath treename sicsname} {
|
|
::deviceType::SingleCounter::hdbMakeXML $hpath $treename $sicsname;
|
|
}
|
|
|
|
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 value} $hmParList {
|
|
property privilege $priv dataType $type id $name {
|
|
foreach v $value { val {text_node $v}}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|