sics/tcl/gumxml.tcl

#-------------------------------------------------------------------------------
# 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 getNodePriv {nodepath} {
    set status [catch {hgetprop $nodepath priv} msg]
    if {$status != 0} {
	set priv user
    } else {
	set priv [sicssplit $msg]
    }
    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"
        }
    }
    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]
    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 ""
        }
    }
    return $result
}
#-----------------------------------------------------------------------------
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]
}