dom.tcl

Linux下的MSN聊天程序源码

}

# dom::tcl::FireNodeRemovedEvents --
#
#	Recursively descend the tree triggering DOMNodeRemoved
#	events as we go.
#
# Arguments:
#	nodeid	Node ID
#
# Results:
#	DOM L2 DOMNodeRemoved events posted

proc dom::tcl::FireNodeRemovedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeRemovedFromDocument
    foreach child [node children $nodeid] {
	FireNodeRemovedEvents $child
    }

    return {}
}

# dom::tcl::element --
#
#	Functions for an element.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable elementOptionsRO tagName|empty
    variable elementOptionsRW {}
}

proc dom::tcl::element {method token args} {
    variable elementOptionsRO
    variable elementOptionsRW

    upvar #0 $token node

    if {[string compare $node(node:nodeType) "element"]} {
	return -code error "malformed node token \"$token\""
    }
    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::element cget token option\""
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    tagName {
			set result [lindex $node(node:nodeName) 0]
		    }
		    empty {
			if {![info exists node(element:empty)]} {
			    return 0
			} else {
			    return $node(element:empty)
			}
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		return $node(node:$option)
	    } else {
		return -code error "bad option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
			return -code error "option \"$option\" cannot be modified"
		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
			return -code error "not implemented"
		    } else {
			return -code error "bad option \"$option\""
		    }
		}
	    }
	}

	getAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::element getAttribute token name\""
	    }

	    set result {}

	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0])}

	    return $result

	}

	setAttribute {
	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be \"dom::element setAttribute token name value\""
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
		return -code error "invalid attribute name \"[lindex $args 0]\""
	    }

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0])}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0] [expr {[info exists attrList([lindex $args 0])] ? "modification" : "addition"}]
	    set result [set attrList([lindex $args 0]) [lindex $args 1]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::element removeAttribute token name\""
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0] -attrChange removal

	}

	getAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be \"dom::element getAttributeNS token ns name\""
	    }

	    set result {}
	    upvar #0 $node(element:attributeList) attrList
	    catch {set result $attrList([lindex $args 0]^[lindex $args 1])}

	    return $result

	}

	setAttributeNS {
	    if {[llength $args] != 3} {
		return -code error "wrong # args: should be \"dom::element setAttributeNS token ns attr value\""
	    }

	    # Check that the attribute name is kosher
	    if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} {
		return -code error "invalid qualified attribute name \"[lindex $args 1]\""
	    }

	    # BUG: At the moment the prefix is ignored

	    upvar #0 $node(element:attributeList) attrList
	    set evid [CreateEvent $token DOMAttrModified]
	    set oldValue {}
	    catch {set oldValue $attrList([lindex $args 0]^$localName)}
	    event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName [expr {[info exists attrList([lindex $args 0]^$localName)] ? "modification" : "addition"}]
	    set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]]
	    node dispatchEvent $token $evid
	    DOMImplementation destroy $evid

	}

	removeAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be \"dom::element removeAttributeNS token ns name\""
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0]^[lindex $args 1])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1] -attrChange removal

	}

	getAttributeNode {
	    array set tmp [array get $node(element:attributeList)]
	    if {![info exists tmp([lindex $args 0])]} {
		return {}
	    }

	    # Synthesize an attribute node if one doesn't already exist
	    array set attrNodes $node(element:attributeNodes)
	    if {[catch {set result $attrNodes([lindex $args 0])}]} {
		set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])]
		lappend node(element:attributeNodes) [lindex $args 0] $result
	    }
	}

	setAttributeNode -
	removeAttributeNode -
	getAttributeNodeNS -
	setAttributeNodeNS -
	removeAttributeNodeNS {
	    return -code error "not yet implemented"
	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong # args: should be \"dom::element getElementsByTagName token name\""
	    }

	    return [eval Element:GetByTagName [list $token [lindex $args 0]] \
		    [lrange $args 1 end]]
	}

	normalize {
	    if {[llength $args]} {
		return -code error "wrong # args: should be dom::element normalize token"
	    }

	    Element:Normalize node [set $node(node:childNodes)]
	}

	default {
	    return -code error "bad method \"$method\": should be cget, configure, getAttribute, setAttribute, removeAttribute, getAttributeNS, setAttributeNS, removeAttributeNS, getAttributeNode, setAttributeNode, removeAttributeNode, getAttributeNodeNS, setAttributeNodeNS, removeAttributeNodeNS, getElementsByTagName or normalize"
	}

    }

    return $result
}

# dom::tcl::Element:GetByTagName --
#
#	Search for (child) elements
#
#	This used to be non-recursive, but then I read the DOM spec
#	properly and discovered that it should recurse.  The -deep
#	option allows for backward-compatibility, and defaults to the
#	DOM-specified value of true.
#
# Arguments:
#	token	parent node
#	name	element type to search for
#	args	configuration options
#
# Results:
#	The name of the variable containing the list of matching node tokens

proc dom::tcl::Element:GetByTagName {token name args} {
    upvar #0 $token node
    upvar #0 [namespace qualifiers $token]::Document document

    array set cfg {-deep 1}
    array set cfg $args
    set cfg(-deep) [Boolean $cfg(-deep)]

    # Guard against arbitrary glob characters
    # Checking that name is a legal XML Name does this
    # However, '*' is permitted
    if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} {
	return -code error "invalid element name"
    }

    # Allocate variable name for this search
    set searchVar ${token}search[incr document(counter)]
    upvar \#0 $searchVar search

    # Make list live by interposing on variable reads
    # I don't think we need to interpose on unsets,
    # and writing to this variable by the application is
    # not permitted.

    trace variable $searchVar w [namespace code Element:GetByTagName:Error]

    if {[string compare $node(node:nodeType) "document"]} {
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]]
    } elseif {[llength $node(document:documentElement)]} {
	# Document Element must exist and must be an element type node
	trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]]
    }

    return $searchVar
}

# dom::tcl::Element:GetByTagName:Search --
#
#	Search for elements.  This does the real work.
#	Because this procedure is invoked everytime
#	the variable is read, it returns the live list.
#
# Arguments:
#	tokens	nodes to search (inclusive)
#	name	element type to search for
#	deep	whether to search recursively
#	name1	\
#	name2	 > appended by trace command
#	op	/
#
# Results:
#	List of matching node tokens

proc dom::tcl::Element:GetByTagName:Search {tokens name deep name1 name2 op} {
    set result {}

    foreach tok $tokens {
	upvar #0 $tok nodeInfo
	switch -- $nodeInfo(node:nodeType) {
	    element {
		if {[string match $name [GetField nodeInfo(node:nodeName)]]} {
		    lappend result $tok
		}
		if {$deep} {
		    set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}]
		    if {[llength $childResult]} {
			eval lappend result $childResult
		    }
		}
	    }
	}
    }

    if {[string length $name1]} {
	set $name1 $result
	return {}
    } else {
	return $result
    }
}

# dom::tcl::Element:GetByTagName:Error --
#
#	Complain about the application writing to a variable
#	that this package maintains.
#
# Arguments:
#	name1	\
#	name2	 > appended by trace command
#	op	/
#
# Results:
#	Error code returned.

proc dom::tcl::Element:GetByTagName:Error {name1 name2 op} {
    return -code error "dom: Read-only variable"
}

# dom::tcl::Element:Normalize --
#
#	Normalize the text nodes
#
# Arguments:
#	pVar	parent array variable in caller
#	nodes	list of node tokens
#
# Results:
#	Adjacent text nodes are coalesced

proc dom::tcl::Element:Normalize {pVar nodes} {
    upvar #0 $pVar parent

    set textNode {}

    foreach n $nodes {
	upvar #0 $n child
	set cleanup {}

	switch $child(node:nodeType) {
	    textNode {
		if {[llength $textNode]} {

		    # Coalesce into previous node
		    set evid [CreateEvent $n DOMCharacterDataModified]
		    event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {} {}
		    append text(node:nodeValue) $child(node:nodeValue)
		    node dispatchEvent $n $evid
		    DOMImplementation destroy $evid

		    # Remove this child
		    upvar #0 $parent(node:childNodes) childNodes
		    set idx [lsearch $childNodes $n]
		    set childNodes [lreplace $childNodes $idx $idx]
		    unset $n
		    set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified]
		    event postMutationEvent $n DOMNodeRemoved

		    set $textNode [array get text]
		} else {
		    set textNode $n
		    catch {unset text}
		    array set text [array get child]
		}
	    }
	    element -
	    document -
	    documentFragment {
		set textNode {}
		Element:Normalize child [set $child(node:childNodes)]
	    }
	    default {
		set textNode {}
	    }
	}

	eval $cleanup
    }

    return {}
}

# dom::tcl::processinginstruction --
#
#	Functions for a processing intruction.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable piOptionsRO target
    variable piOptionsRW data
}

proc dom::tcl::processinginstruction {method token args} {
    variable piOptionsRO
    variable piOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {

	cget {
	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    target {
			set result [lindex $node(node:nodeName) 0]
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
		switch $option {
		    data {
			return $node(node:nodeValue)
		    }
		    default {
			return $node(node:$option)
		    }
		}
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [document cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "no value specified for option \"[lindex $args end]\""
	    } else {
		foreach {option valu