sics/site_ansto/instrument/hipadaba/hpdbxml.tcl

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