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