- Fixed bugs in tcl code

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 "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
+proc getdataType {path} {
+  return [lindex [split [hinfo $path] ,] 0]
 }
-#---------------------------------------------------------------------------
-proc sicssplit {txt} {
-    set l [split $txt =]
-    return [string trim [lindex $l 1]]
-}
-#---------------------------------------------------------------------------
-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
-    }
-    set priv [string toupper $priv]
-    if {[string compare $priv INTERNAL] == 0} {
-	set priv READ_ONLY
-    }
-    return $priv    
-}
-#--------------------------------------------------------------------------
-proc getNodeNumType {nodepath} {
-    set txt [hinfo $nodepath]
-    set l [split $txt ,]
-    set numtype [lindex $l 0]
-    set numType [string totitle $numtype]
-    return $numType
-}
-#----------------------------------------------------------------------------
-proc makeXMLHeader {nodepath indent} {
-    set status [catch {hgetprop $nodepath type} msg]
-    if {$status != 0} {
-      set nodetype UNSPECIFIED
-    } else {
-	set nodetype [string tolower [sicssplit $msg]]	
-    }
-    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"
+    foreach x [hlist $path] {
+      set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
     }
+    append result  "$prefix</component>\n"
   }
   return $result
 }
-#----------------------------------------------------------------------------
-proc makeXMLClose {nodepath indent} {
-    set status [catch {hgetprop $nodepath type} msg]
-    if {$status != 0} {
-      set nodetype UNSPECIFIED
-    } else {
-	set nodetype [string tolower [sicssplit $msg]]	
-    }
-    set nodename [file tail $nodepath]
+
+proc property_elements_old {path indent} {
   set prefix [string repeat " " $indent]
-    switch $nodetype {
-	instrument {
-	    append result "$prefix</Instrument>\n"
+  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"
   }
-        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
+  if [info exists proplist] {return $proplist}
 }
-#-----------------------------------------------------------------------------
-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} {
+
+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 nodepath $path/$node
-	append result [makeXMLHeader $nodepath $indent]
-	append result [scanHdbDir $nodepath [expr $indent + 2]]
-        append result [makeXMLClose $nodepath $indent]
+    lappend proplist "$prefix<property id=\"$key\">\n"
+    lappend proplist "$prefix$prefix<value>$value</value>\n"  
+    lappend proplist "$prefix</property>\n"
   }
-    return $result
+  if [info exists proplist] {return $proplist}
 }
-#-----------------------------------------------------------------------------
-proc getgumtreexml {path } {
-    append result [makeGumHeader]
-    append result [scanHdbDir $path 0]
+
+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]
+    }
+  } else {
+#    set result [make_nodes $path $result 2]
+    foreach n [hlist $path] {
+      set result [make_nodes $path/$n $result 2]
+    }
+  }
+
+  append result "</hipadaba:SICS>\n"
+}
+
+if {[info exists guminit] == 0} {
+  set guminit 1
+  Publish getgumtreexml Spy
 }

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 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
  
-set socke [socket localhost 2911]
-gets $socke
-puts $socke "Spy 007"
-flush $socke
-gets $socke
+#-------------------------------------------------------------------
+# initialize the socket before debugging. If local == 1, then a 
+# connection to localhost is built
 #------------------------------------------------------------------
-proc unknown 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]
 }
+#------------------------------------------------------------------