dom.tcl

Linux下的MSN聊天程序源码

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    return {}
}

namespace eval dom::tcl {
    foreach method {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} {
	proc $method args "eval [namespace current]::DOMImplementation $method \$args"
    }
}

# dom::tcl::Document:Delete --
#
#	Handle destruction of a document
#
# Arguments:
#	name	document token
#	old	)
#	new	) args added by trace command
#	op	)

proc dom::tcl::Document:Delete {name old new op} {
    DOMImplementation destroy $name
    return {}
}

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

namespace eval dom::tcl {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW actualEncoding|encoding|standalone|version
}

proc dom::tcl::document {method token args} {
    variable documentOptionsRO
    variable documentOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {
	cget {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::document method token ?args ...?\""
	    }
	    if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
		return $node(document:$option)
	    } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
		switch -- $option {
		    encoding -
		    version -
		    standalone {
			array set xmldecl $node(document:xmldecl)
			return $xmldecl($option)
		    }
		    default {
			return $node(document:$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)$} $documentOptionsRW] $option discard opt]} {
			switch -- $opt {
			    encoding {
				catch {unset xmldecl}
				array set xmldecl $node(document:xmldecl)
				set xmldecl(encoding) $value
				set node(document:xmldecl) [array get xmldecl]
			    }
			    standalone {
				if {[string is boolean $value]} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    if {[string is true $value]} {
					set xmldecl(standalone) yes
				    } else {
					set xmldecl(standalone) no
				    }
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\" - must be boolean"
				}
			    }
			    version {
				if {$value == "1.0"} {
				    catch {unset xmldecl}
				    array set xmldecl $node(document:xmldecl)
				    set xmldecl(version) $value
				    set node(document:xmldecl) [array get xmldecl]
				} else {
				    return -code error "unsupported value for option \"$option\""
				}
			    }
			    default {
				set node(document:$opt) $value
			    }
			}
		    } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "bad option \"$option\""
		    }
		}
	    }
	}

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

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

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 0] {}]

	}
	createDocumentFragment {
	    if {[llength $args]} {
		return -code error "wrong # args: should be \"document createDocumentFragment token\""
	    }

	    set result [CreateGeneric $token node:nodeType documentFragment node:nodeName #document-fragment node:nodeValue {}]
	}
	createTextNode {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createTextNode token text\""
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	}
	createComment {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createComment token data\""
	    }

	    set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
	}
	createCDATASection {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createCDATASection token data\""
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	    node configure $result -cdatasection 1
	}
	createProcessingInstruction {
	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be \"document createProcessingInstruction token target data\""
	    }

	    set result [CreateGeneric $token node:nodeType processingInstruction \
		    node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
	}
	createAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createAttributes token name\""
	    }

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

	    set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
	}
	createEntity {
	    set result [CreateGeneric $token node:nodeType entity]
	}
	createEntityReference {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createEntityReference token name\""
	    }
	    set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
	}

	importNode {
	    # Introduced in DOM Level 2

	    if {[llength $args] < 1} {
		return -code error "wrong # args: should be \"importNode token ?-deep boolean?\""
	    }
	    array set opts {
		-deep 1
	    }
	    array set opts [lrange $args 1 end]
	    set opts(-deep) [Boolean $opts(-deep)]

	    if {[namespace qualifiers [lindex $args 0]] == [namespace qualifiers $token]} {
		return -code error "source node \"[lindex $args 0]\" is in the same document"
	    }

	    switch [node cget [lindex $args 0] -nodeType] {
		document -
		documentType {
		    return -code error "node type \"[node cget [lindex $args 0] -type]\" cannot be imported"
		}
		documentFragment {
		    set result [document createDocumentFragment $token]
		    if {$opts(-deep)} {
			foreach child [node children [lindex $args 0]] {
			    $result appendChild [$token importNode $child -deep 1]
			}
		    }
		}
		element {
		    set result [CreateElement {} [node cget [lindex $args 0] -nodeName] [array get [node cget [lindex $args 0] -attributes]] -document $token]
		    if {$opts(-deep)} {
			foreach child [node children [lindex $args 0]] {
			    $result appendChild [$token importNode $child -deep 1]
			}
		    }
		}
		textNode {
		    set result [CreateTextNode {} [node cget [lindex $args 0] -nodeValue] -document $token]
		}
		attribute -
		processingInstruction -
		comment {
		    set result [CreateGeneric {} -document $token node:nodeType [node cget [lindex $args 0] -nodeType] node:nodeName [node cget [lindex $args 0] -nodeName] node:nodeValue [node cget [lindex $args 0] -nodeValue]]
		}
	    }
	}

	createElementNS {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be: \"createElementNS nsuri qualname\""
	    }

	    # Check that the qualified name is kosher
	    if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]]  break} err]} {
		return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\""
	    }

	    # Invoke internal factory function
	    set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname]
	}

	createAttributeNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsByTagNameNS {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	getElementsById {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createEvent {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"document createEvent token type\""
	    }

	    set result [CreateEvent $token [lindex $args 0]]

	}

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

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

	default {
	    return -code error "unknown method \"$method\""
	}

    }

    # Dispatch events

    # Node insertion events are generated here instead of the
    # internal factory procedures.  This is because the factory
    # procedures are meant to be mean-and-lean during the parsing
    # phase, and dispatching events at that time would be an
    # excessive overhead.  The factory methods here are pretty
    # heavyweight anyway.

    if {[string match create* $method] && [string compare $method "createEvent"]} {

	event postMutationEvent $result DOMNodeInserted -relatedNode $token
	event postMutationEvent $result DOMNodeInsertedIntoDocument
	event postMutationEvent $token DOMSubtreeModified

    }

    return $result
}

###	Factory methods
###
### These are lean-and-mean for fastest possible tree building

# dom::tcl::CreateElement --
#
#	Append an element to the given (parent) node (if any)
#
# Arguments:
#	token	parent node (if empty -document option is mandatory)
#	name	element name (no checking performed here)
#	aList	attribute list
#	args	configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateElement {token name aList args} {
    array set opts $args

    if {[string length $token]} {
	upvar #0 $token parent
	upvar #0 [namespace qualifiers $token]::Document document
	set child [namespace qualifiers $token]::node[incr document(counter)]
    } elseif {[info exists opts(-document)]} {
	upvar #0 $opts(-document) document
	set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
    } else {
	return -code error "no parent or document specified"
    }

    upvar #0 $child new

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    array set new [list \
	    node:parentNode $token		\
	    node:childNodes ${child}var		\
	    node:nodeType element		\
	    node:nodeName $name			\
	    node:namespaceURI {}		\
	    node:prefix {}			\
	    node:localName $name		\
	    node:nodeValue {}			\
	    element:attributeList ${child}arr	\
	    element:attributeNodes {}		\
    ]

    catch {set new(node:namespaceURI) $opts(-namespace)}
    catch {set new(node:localName) $opts(-localname)}
    catch {set new(node:prefix) $opts(-prefix)}

    # Initialise associated variables
    set ${child}var {}
    array set ${child}arr $aList
    catch {
	foreach {ns nsAttrList} $opts(-namespaceattributelists) {
	    foreach {attrName attrValue} $nsAttrList {
		array set ${child}arr [list $ns^$attrName $attrValue]
	    }
	}
    }

    # Update parent record

    # Does this element qualify as the document element?
    # If so, then has a document element already been set?

    if {[string length $token] && 
	[string equal $parent(node:nodeType) document]} {

	if {$token == $parent(documentFragment:masterDoc)} {
	    if {[info exists parent(document:documentElement)] && \
		    [string length $parent(document:documentElement)]} {
		# Do not attach to the tree
		set new(node:parentNode) {}
	    } else {

		# Check against document type decl
		if {[string length $parent(document:doctype)]} {
		    upvar #0 $parent(document:doctype) doctypedecl
		    if {[string compare $name $doctypedecl(doctype:name)]} {
			return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
		    }

		} else {
		    # Synthesize document type declaration
		    set doctype [CreateDocType $name {} {}]
		    set document(document:doctype) $doctype
		}

		set parent(document:documentElement) $child
		catch {lappend $parent(node:childNodes) $child}
	    }
	} else {
	    catch {lappend $parent(node:childNodes) $child}
	}
    } else {
	catch {lappend $parent(node:childNodes) $child}
    }

    proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

# dom::tcl::CreateTextNode --
#
#	Append a textNode node to the given (parent) node (if any).
#
#	This factory function can also be performed by
#	CreateGeneric, but text nodes are created so often
#	that this specific factory procedure speeds things up.
#
# Arguments:
#	token	parent node (if empty -document option is mandatory)
#	text	initial text
#	args	additional configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateTextNode {token text args} {
    array set opts $args

    if {[string length $token]} {
	upvar #0 $token parent
	upvar #0 [namespace qualifiers $token]::Document document
	set child [namespace qualifiers $token]::node[incr document(counter)]
    } elseif {[info exists opts(-document)]} {
	upvar #0 $opts(-document) document
	set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
    } else {
	return -code error "no parent or document specified"
    }

    upvar #0 $child new

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance

    # Text nodes never have children, so don't create a variable

    array set new [list \
	    node:parentNode $token		\
	    node:childNodes ${child}var		\
	    node:nodeType textNode		\
	    node:nodeValue $text		\
	    node:nodeName #text			\