linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Fixed bugs in tcl code

Browse Source
This commit is contained in:
koennecke
2008-03-05 09:52:03 +00:00
parent 06d75601a8
commit d3f7404543
2 changed files with 115 additions and 184 deletions
Download Patch File Download Diff File Expand all files Collapse all files

239
tcl/gumxml.tcl
View File

@ -1,181 +1,80 @@
#-------------------------------------------------------------------------------
# This file contains the implementation of the routines which generate the
# 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 getdataType {path} {
return [lindex [split [hinfo $path] ,] 0]
}
#---------------------------------------------------------------------------
proc getNodePriv {nodepath} {
set status [catch {hgetprop $nodepath priv} msg]
if {$status != 0} {
set priv user
} else {
set priv [sicssplit $msg]
proc make_nodes {path result indent} {
set nodename [file tail $path];
set type [getdataType $path]
set prefix [string repeat " " $indent]
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} {
set priv user
foreach x [hlist $path] {
set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
}
set priv [string toupper $priv]
if {[string compare $priv INTERNAL] == 0} {
set priv READ_ONLY
}
return $priv
append result "$prefix</component>\n"
}
return $result
}
#--------------------------------------------------------------------------
proc getNodeNumType {nodepath} {
set txt [hinfo $nodepath]
set l [split $txt ,]
set numtype [lindex $l 0]
set numType [string totitle $numtype]
return $numType
proc property_elements_old {path indent} {
set prefix [string repeat " " $indent]
foreach {key value} [string map {= " "} [hlistprop $path]] {
if {[string compare -nocase $key "control"] == 0} {continue}
lappend proplist "$prefix<property id=\"$key\">\n"
# 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} {
set status [catch {hgetprop $nodepath type} msg]
if {$status != 0} {
set nodetype UNSPECIFIED
} else {
set nodetype [string tolower [sicssplit $msg]]
proc property_elements {path indent} {
set prefix [string repeat " " $indent]
set data [hlistprop $path]
set propList [split $data \n]
foreach prop $propList {
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]
set prefix [string repeat " " $indent]
switch $nodetype {
instrument {
append result "$prefix <Instrument xmlns:hipadaba=\"http://www.psi.ch/hipadaba\" label=\""
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
lappend proplist "$prefix<property id=\"$key\">\n"
lappend proplist "$prefix$prefix<value>$value</value>\n"
lappend proplist "$prefix</property>\n"
}
if [info exists proplist] {return $proplist}
}
#----------------------------------------------------------------------------
proc makeXMLClose {nodepath indent} {
set status [catch {hgetprop $nodepath type} msg]
if {$status != 0} {
set nodetype UNSPECIFIED
} else {
set nodetype [string tolower [sicssplit $msg]]
proc getgumtreexml {path} {
append result "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"
if {[string compare $path "/" ] == 0} {
foreach n [hlist $path] {
set result [make_nodes $n $result 2]
}
set nodename [file tail $nodepath]
set prefix [string repeat " " $indent]
switch $nodetype {
instrument {
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 ""
}
} else {
# set result [make_nodes $path $result 2]
foreach n [hlist $path] {
set result [make_nodes $path/$n $result 2]
}
return $result
}
append result "</hipadaba:SICS>\n"
}
#-----------------------------------------------------------------------------
proc scanHdbDir {path indent} {
set txl [hlist $path]
if {[string compare $path "/"] == 0} {
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]
if {[info exists guminit] == 0} {
set guminit 1
Publish getgumtreexml Spy
}

60
tcl/sicstcldebug.tcl
View File

@ -7,20 +7,50 @@
# Thus is should be possible to debug SICS Tcl scripts in a normal
# standalone interpreter without the overhead of restarting SICS
# all the time. It may even be possible to use one of the normal
# Tcl debugfgers then....
# Tcl debuggers then....
#
# Mark Koennecke, February 2006
#
# Revamped for use in testing SICS instruments.
# Mark Koennecke, November 2006
#------------------------------------------------------------------
set socke [socket localhost 2911]
gets $socke
puts $socke "Spy 007"
flush $socke
gets $socke
set host(amor) amor.psi.ch
set host(dmc) dmc.psi.ch
set host(focus) focus.psi.ch
set host(hrpt) hrpt.psi.ch
set host(mars) mars.psi.ch
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 {
global socke
append com "transact " [join $args]
proc initSicsDebug {instrument} {
global socke host
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
flush $socke
set reply ""
@ -29,14 +59,16 @@ proc unknown args {
if {[string first TRANSACTIONFINISHED $line] >= 0} {
return $reply
} else {
append reply $line
if {[string first "\n" $line] < 0} {
append reply \n
}
append reply $line "\n"
}
}
}
#------------------------------------------------------------------
proc unknown args {
return [sicscommand $args]
}
#------------------------------------------------------------------
proc clientput args {
puts stdout [join $args]
}
#------------------------------------------------------------------