- Fixed bugs in tcl code
This commit is contained in:
koennecke
239
tcl/gumxml.tcl
239
tcl/gumxml.tcl
@ -1,181 +1,80 @@
|
|||||||
#-------------------------------------------------------------------------------
|
proc getdataType {path} {
|
||||||
# This file contains the implementation of the routines which generate the
|
return [lindex [split [hinfo $path] ,] 0]
|
||||||
# XML file as required by GumTree from a SICS Hipadaba.
|
|
||||||
#
|
|
||||||
# Mark Koennecke, Tony Lam, Ferdi Franceccini, January 2007
|
|
||||||
#------------------------------------------------------------------------------
|
|
||||||
proc makeGumHeader {} {
|
|
||||||
return "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
|
|
||||||
}
|
|
||||||
#---------------------------------------------------------------------------
|
|
||||||
proc sicssplit {txt} {
|
|
||||||
set l [split $txt =]
|
|
||||||
return [string trim [lindex $l 1]]
|
|
||||||
}
|
}
|
||||||
#---------------------------------------------------------------------------
|
|
||||||
proc getNodePriv {nodepath} {
|
|
||||||
set status [catch {hgetprop $nodepath priv} msg]
|
proc make_nodes {path result indent} {
|
||||||
if {$status != 0} {
|
set nodename [file tail $path];
|
||||||
set priv user
|
set type [getdataType $path]
|
||||||
} else {
|
set prefix [string repeat " " $indent]
|
||||||
set priv [sicssplit $msg]
|
set newIndent [expr $indent + 2]
|
||||||
|
#array set prop_list [ string trim [join [split [hlistprop $path] =]] ]
|
||||||
|
set prop_list(control) true
|
||||||
|
set we_have_control [info exists prop_list(control)]
|
||||||
|
if {$we_have_control == 0 || $we_have_control && $prop_list(control) == "true"} {
|
||||||
|
append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
|
||||||
|
foreach p [property_elements $path $newIndent] {
|
||||||
|
append result $p
|
||||||
}
|
}
|
||||||
if {[string length $priv] < 2} {
|
foreach x [hlist $path] {
|
||||||
set priv user
|
set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
|
||||||
}
|
}
|
||||||
set priv [string toupper $priv]
|
append result "$prefix</component>\n"
|
||||||
if {[string compare $priv INTERNAL] == 0} {
|
}
|
||||||
set priv READ_ONLY
|
return $result
|
||||||
}
|
|
||||||
return $priv
|
|
||||||
}
|
}
|
||||||
#--------------------------------------------------------------------------
|
|
||||||
proc getNodeNumType {nodepath} {
|
proc property_elements_old {path indent} {
|
||||||
set txt [hinfo $nodepath]
|
set prefix [string repeat " " $indent]
|
||||||
set l [split $txt ,]
|
foreach {key value} [string map {= " "} [hlistprop $path]] {
|
||||||
set numtype [lindex $l 0]
|
if {[string compare -nocase $key "control"] == 0} {continue}
|
||||||
set numType [string totitle $numtype]
|
lappend proplist "$prefix<property id=\"$key\">\n"
|
||||||
return $numType
|
# foreach v [split $value ,] {
|
||||||
|
# lappend proplist "$prefix$prefix<value>$v</value>\n"
|
||||||
|
# }
|
||||||
|
lappend proplist "$prefix$prefix<value>$value</value>\n"
|
||||||
|
lappend proplist "$prefix</property>\n"
|
||||||
|
}
|
||||||
|
if [info exists proplist] {return $proplist}
|
||||||
}
|
}
|
||||||
#----------------------------------------------------------------------------
|
|
||||||
proc makeXMLHeader {nodepath indent} {
|
proc property_elements {path indent} {
|
||||||
set status [catch {hgetprop $nodepath type} msg]
|
set prefix [string repeat " " $indent]
|
||||||
if {$status != 0} {
|
set data [hlistprop $path]
|
||||||
set nodetype UNSPECIFIED
|
set propList [split $data \n]
|
||||||
} else {
|
foreach prop $propList {
|
||||||
set nodetype [string tolower [sicssplit $msg]]
|
set pl [split $prop =]
|
||||||
|
set key [string trim [lindex $pl 0]]
|
||||||
|
set value [string trim [lindex $pl 1]]
|
||||||
|
if {[string length $key] < 1} {
|
||||||
|
continue
|
||||||
}
|
}
|
||||||
set nodename [file tail $nodepath]
|
lappend proplist "$prefix<property id=\"$key\">\n"
|
||||||
set prefix [string repeat " " $indent]
|
lappend proplist "$prefix$prefix<value>$value</value>\n"
|
||||||
switch $nodetype {
|
lappend proplist "$prefix</property>\n"
|
||||||
instrument {
|
}
|
||||||
append result "$prefix <Instrument xmlns:hipadaba=\"http://www.psi.ch/hipadaba\" label=\""
|
if [info exists proplist] {return $proplist}
|
||||||
append result "$nodename\">\n"
|
|
||||||
}
|
|
||||||
part {
|
|
||||||
set numtype [getNodeNumType $nodepath]
|
|
||||||
if {[string compare $numtype None] == 0} {
|
|
||||||
append result "$prefix<part id=\"$nodename\">\n"
|
|
||||||
} else {
|
|
||||||
set priv [getNodePriv $nodepath]
|
|
||||||
append result "$prefix<part id=\"$nodename\" dataType=\"$numtype\" privilege=\"$priv\">\n"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
motor {
|
|
||||||
set priv [getNodePriv $nodepath]
|
|
||||||
append result "$prefix<device id=\"$nodename\" "
|
|
||||||
append result "deviceType=\"Motor\" dataType=\"Float\" privilege=\"$priv\">\n"
|
|
||||||
}
|
|
||||||
drivable {
|
|
||||||
set priv [getNodePriv $nodepath]
|
|
||||||
append result "$prefix<device id=\"$nodename\" "
|
|
||||||
append result "deviceType=\"Drivable\" dataType=\"Float\" privilege=\"$priv\">\n"
|
|
||||||
}
|
|
||||||
graphset {
|
|
||||||
append result "$prefix <Graphics label=\""
|
|
||||||
append result "$nodename\">\n"
|
|
||||||
}
|
|
||||||
commandset {
|
|
||||||
append result "$prefix <Commands label=\""
|
|
||||||
append result "$nodename\">\n"
|
|
||||||
}
|
|
||||||
graphdata {
|
|
||||||
set status [catch {hgetprop $nodepath viewer} msg]
|
|
||||||
if {$status == 0} {
|
|
||||||
set view [sicssplit $msg]
|
|
||||||
append result "$prefix<graphdata id=\"$nodename\" viewer=\"$view\">\n"
|
|
||||||
} else {
|
|
||||||
append result "$prefix<graphdata id=\"$nodename\">\n"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
command {
|
|
||||||
set priv [getNodePriv $nodepath]
|
|
||||||
append result "$prefix<command id=\"$nodename\" privilege=\"$priv\">\n"
|
|
||||||
}
|
|
||||||
axis {
|
|
||||||
set status [catch {hgetprop $nodepath dim} msg]
|
|
||||||
if {$status == 0} {
|
|
||||||
set dim [sicssplit $msg]
|
|
||||||
} else {
|
|
||||||
set dim 0
|
|
||||||
}
|
|
||||||
set numtype [getNodeNumType $nodepath]
|
|
||||||
append result "$prefix<axis privilege=\"READ_ONLY\" dataType=\"$numtype\" "
|
|
||||||
append result "id=\"$nodename\" dim=\"$dim\"/>\n"
|
|
||||||
}
|
|
||||||
data {
|
|
||||||
set numtype [getNodeNumType $nodepath]
|
|
||||||
append result "$prefix<data privilege=\"READ_ONLY\" "
|
|
||||||
append result "dataType=\"$numtype\" id=\"$nodename\"/>\n"
|
|
||||||
}
|
|
||||||
default {
|
|
||||||
set numtype [getNodeNumType $nodepath]
|
|
||||||
set priv [getNodePriv $nodepath]
|
|
||||||
append result "$prefix<property privilege=\"$priv\" dataType=\"$numtype\" id=\"$nodename\"/>\n"
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return $result
|
|
||||||
}
|
}
|
||||||
#----------------------------------------------------------------------------
|
|
||||||
proc makeXMLClose {nodepath indent} {
|
proc getgumtreexml {path} {
|
||||||
set status [catch {hgetprop $nodepath type} msg]
|
append result "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
|
||||||
if {$status != 0} {
|
append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"
|
||||||
set nodetype UNSPECIFIED
|
|
||||||
} else {
|
if {[string compare $path "/" ] == 0} {
|
||||||
set nodetype [string tolower [sicssplit $msg]]
|
foreach n [hlist $path] {
|
||||||
|
set result [make_nodes $n $result 2]
|
||||||
}
|
}
|
||||||
set nodename [file tail $nodepath]
|
} else {
|
||||||
set prefix [string repeat " " $indent]
|
# set result [make_nodes $path $result 2]
|
||||||
switch $nodetype {
|
foreach n [hlist $path] {
|
||||||
instrument {
|
set result [make_nodes $path/$n $result 2]
|
||||||
append result "$prefix</Instrument>\n"
|
|
||||||
}
|
|
||||||
part {
|
|
||||||
append result "$prefix</part>\n"
|
|
||||||
}
|
|
||||||
drivable -
|
|
||||||
motor {
|
|
||||||
append result "$prefix</device>\n"
|
|
||||||
}
|
|
||||||
graphset {
|
|
||||||
append result "$prefix</Graphics>\n"
|
|
||||||
}
|
|
||||||
commandset {
|
|
||||||
append result "$prefix</Commands>\n"
|
|
||||||
}
|
|
||||||
graphdata {
|
|
||||||
append result "$prefix</graphdata>\n"
|
|
||||||
}
|
|
||||||
command {
|
|
||||||
append result "$prefix</command>\n"
|
|
||||||
}
|
|
||||||
default {
|
|
||||||
append result ""
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
return $result
|
}
|
||||||
|
|
||||||
|
append result "</hipadaba:SICS>\n"
|
||||||
}
|
}
|
||||||
#-----------------------------------------------------------------------------
|
|
||||||
proc scanHdbDir {path indent} {
|
if {[info exists guminit] == 0} {
|
||||||
set txl [hlist $path]
|
set guminit 1
|
||||||
if {[string compare $path "/"] == 0} {
|
Publish getgumtreexml Spy
|
||||||
set path ""
|
|
||||||
}
|
|
||||||
set nodelist [split $txl \n]
|
|
||||||
set result ""
|
|
||||||
foreach node $nodelist {
|
|
||||||
if {[string length $node] < 1} {
|
|
||||||
continue
|
|
||||||
}
|
|
||||||
set nodepath $path/$node
|
|
||||||
append result [makeXMLHeader $nodepath $indent]
|
|
||||||
append result [scanHdbDir $nodepath [expr $indent + 2]]
|
|
||||||
append result [makeXMLClose $nodepath $indent]
|
|
||||||
}
|
|
||||||
return $result
|
|
||||||
}
|
|
||||||
#-----------------------------------------------------------------------------
|
|
||||||
proc getgumtreexml {path } {
|
|
||||||
append result [makeGumHeader]
|
|
||||||
append result [scanHdbDir $path 0]
|
|
||||||
}
|
}
|
||||||
|
|||||||
@ -7,20 +7,50 @@
|
|||||||
# Thus is should be possible to debug SICS Tcl scripts in a normal
|
# Thus is should be possible to debug SICS Tcl scripts in a normal
|
||||||
# standalone interpreter without the overhead of restarting SICS
|
# standalone interpreter without the overhead of restarting SICS
|
||||||
# all the time. It may even be possible to use one of the normal
|
# all the time. It may even be possible to use one of the normal
|
||||||
# Tcl debugfgers then....
|
# Tcl debuggers then....
|
||||||
#
|
#
|
||||||
# Mark Koennecke, February 2006
|
# Mark Koennecke, February 2006
|
||||||
|
#
|
||||||
|
# Revamped for use in testing SICS instruments.
|
||||||
|
# Mark Koennecke, November 2006
|
||||||
#------------------------------------------------------------------
|
#------------------------------------------------------------------
|
||||||
|
set host(amor) amor.psi.ch
|
||||||
set socke [socket localhost 2911]
|
set host(dmc) dmc.psi.ch
|
||||||
gets $socke
|
set host(focus) focus.psi.ch
|
||||||
puts $socke "Spy 007"
|
set host(hrpt) hrpt.psi.ch
|
||||||
flush $socke
|
set host(mars) mars.psi.ch
|
||||||
gets $socke
|
set host(morpheus) morpheus.psi.ch
|
||||||
|
set host(narziss) narziss.psi.ch
|
||||||
|
set host(poldi) poldi.psi.ch
|
||||||
|
set host(rita2) rita2.psi.ch
|
||||||
|
set host(sans) sans.psi.ch
|
||||||
|
set host(sansli) sans2.psi.ch
|
||||||
|
set host(tasp) tasp.psi.ch
|
||||||
|
set host(trics) trics.psi.ch
|
||||||
|
set host(local) localhost
|
||||||
|
|
||||||
|
#-------------------------------------------------------------------
|
||||||
|
# initialize the socket before debugging. If local == 1, then a
|
||||||
|
# connection to localhost is built
|
||||||
#------------------------------------------------------------------
|
#------------------------------------------------------------------
|
||||||
proc unknown args {
|
proc initSicsDebug {instrument} {
|
||||||
global socke
|
global socke host
|
||||||
append com "transact " [join $args]
|
catch {close $socke}
|
||||||
|
set status [catch {set compi $host($instrument)} msg]
|
||||||
|
if {$status != 0} {
|
||||||
|
error "Host for $instrument not found"
|
||||||
|
}
|
||||||
|
set socke [socket $compi 2911]
|
||||||
|
gets $socke
|
||||||
|
puts $socke "Spy 007"
|
||||||
|
flush $socke
|
||||||
|
gets $socke
|
||||||
|
}
|
||||||
|
#----------------------------------------------------------------
|
||||||
|
proc sicscommand args {
|
||||||
|
global socke
|
||||||
|
append com "transact " [join $args]
|
||||||
|
puts stdout "Sending: $com"
|
||||||
puts $socke $com
|
puts $socke $com
|
||||||
flush $socke
|
flush $socke
|
||||||
set reply ""
|
set reply ""
|
||||||
@ -29,14 +59,16 @@ proc unknown args {
|
|||||||
if {[string first TRANSACTIONFINISHED $line] >= 0} {
|
if {[string first TRANSACTIONFINISHED $line] >= 0} {
|
||||||
return $reply
|
return $reply
|
||||||
} else {
|
} else {
|
||||||
append reply $line
|
append reply $line "\n"
|
||||||
if {[string first "\n" $line] < 0} {
|
|
||||||
append reply \n
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
#------------------------------------------------------------------
|
#------------------------------------------------------------------
|
||||||
|
proc unknown args {
|
||||||
|
return [sicscommand $args]
|
||||||
|
}
|
||||||
|
#------------------------------------------------------------------
|
||||||
proc clientput args {
|
proc clientput args {
|
||||||
puts stdout [join $args]
|
puts stdout [join $args]
|
||||||
}
|
}
|
||||||
|
#------------------------------------------------------------------
|
||||||
|
|||||||
Reference in New Issue
Block a user