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