diff --git a/tcl/gumxml.tcl b/tcl/gumxml.tcl
index a19125b6..bb9e538b 100644
--- a/tcl/gumxml.tcl
+++ b/tcl/gumxml.tcl
@@ -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 "\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\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\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\n"
+# foreach v [split $value ,] {
+# lappend proplist "$prefix$prefix$v\n"
+# }
+ lappend proplist "$prefix$prefix$value\n"
+ lappend proplist "$prefix\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 \n"
- }
- part {
- set numtype [getNodeNumType $nodepath]
- if {[string compare $numtype None] == 0} {
- append result "$prefix\n"
- } else {
- set priv [getNodePriv $nodepath]
- append result "$prefix\n"
- }
- }
- motor {
- set priv [getNodePriv $nodepath]
- append result "$prefix\n"
- }
- drivable {
- set priv [getNodePriv $nodepath]
- append result "$prefix\n"
- }
- graphset {
- append result "$prefix \n"
- }
- commandset {
- append result "$prefix \n"
- }
- graphdata {
- set status [catch {hgetprop $nodepath viewer} msg]
- if {$status == 0} {
- set view [sicssplit $msg]
- append result "$prefix\n"
- } else {
- append result "$prefix\n"
- }
- }
- command {
- set priv [getNodePriv $nodepath]
- append result "$prefix\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\n"
- }
- data {
- set numtype [getNodeNumType $nodepath]
- append result "$prefix\n"
- }
- default {
- set numtype [getNodeNumType $nodepath]
- set priv [getNodePriv $nodepath]
- append result "$prefix\n"
- }
- }
- return $result
+ lappend proplist "$prefix\n"
+ lappend proplist "$prefix$prefix$value\n"
+ lappend proplist "$prefix\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 "\n"
+ append result "\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\n"
- }
- part {
- append result "$prefix\n"
- }
- drivable -
- motor {
- append result "$prefix\n"
- }
- graphset {
- append result "$prefix\n"
- }
- commandset {
- append result "$prefix\n"
- }
- graphdata {
- append result "$prefix\n"
- }
- command {
- append result "$prefix\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 "\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
}
diff --git a/tcl/sicstcldebug.tcl b/tcl/sicstcldebug.tcl
index e9e6df97..1139e8fc 100644
--- a/tcl/sicstcldebug.tcl
+++ b/tcl/sicstcldebug.tcl
@@ -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]
}
+#------------------------------------------------------------------