dom.tcl

Linux下的MSN聊天程序源码

	    node:cdatasection 0			\
    ]

    set ${child}var {}

    # Update parent record
    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::CreateGeneric --
#
#	This is a template used for type-specific factory procedures
#
# Arguments:
#	token	parent node (if empty -document option is mandatory)
#	args	optional values
#
# Results:
#	New node created, parent modified

proc dom::tcl::CreateGeneric {token 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 [eval list [list \
	    node:parentNode $token	\
	    node:childNodes ${child}var	] \
	    $args			\
    ]
    set ${child}var {}

    switch -glob -- [string length $token],$opts(node:nodeType) {
	0,* -
	*,attribute -
	*,namespace {
	    # These type of nodes are not children of their parent
	}

	default {
	    # Update parent record
	    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
}

### Specials

# dom::tcl::CreateDocType --
#
#	Create a Document Type Declaration node.
#
# Arguments:
#	name	root element type
#	publicid	public identifier
#	systemid	system identifier
#	internaldtd	internal DTD subset
#
# Results:
#	Returns node id of the newly created node.

proc dom::tcl::CreateDocType {name publicid systemid {internaldtd {}}} {
    if {![regexp ^$::xml::QName\$ $name]} {
	return -code error "invalid QName \"$name\""
    }

    set nodename [namespace current]::$name
    upvar #0 $nodename doctype
    if {[info exists doctype]} {
	return $nodename
    }

    if {[llength $internaldtd] == 1 && [string length [lindex $internaldtd 0]] == 0} {
	set dtd {}
    }

    array set doctype [list \
	    node:childNodes {} \
	    node:nodeType documentType \
	    node:nodeName $name \
	    node:nodeValue {} \
	    doctype:name $name \
	    doctype:entities {} \
	    doctype:notations {} \
	    doctype:publicId $publicid \
	    doctype:systemId $systemid \
	    doctype:internalSubset $internaldtd \
    ]

    proc $nodename {method args} "return \[eval [namespace current]::documenttype \[list \$method\] $nodename \$args\]"
    trace add command $nodename delete [namespace code [list DocumentType:Delete $nodename]]

    return $nodename
}

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

namespace eval dom::tcl {
    variable documenttypeOptionsRO name|entities|notations|publicId|systemId|internalSubset
    variable documenttypeOptionsRW {}
}

proc dom::tcl::documenttype {method token args} {
    variable documenttypeOptionsRO
    variable documenttypeOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {
	cget {
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::documenttype method token ?args ...?\""
	    }
	    if {[regexp [format {^-(%s)$} $documenttypeOptionsRO] [lindex $args 0] discard option]} {
		switch -- $option {
		    name {
			return $node(node:nodeName)
		    }
		    default {
			return $node(doctype:$option)
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRW] [lindex $args 0] discard option]} {
		return $node(doctype:$option)
	    } else {
		return -code error "bad option \"[lindex $args 0]\""
	    }
	}
	configure {
	    if {[llength $args] == 1} {
		return [documenttype 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)$} $documenttypeOptionsRW] $option discard opt]} {
			switch -- $opt {
			    default {
				set node(doctype:$opt) $value
			    }
			}
		    } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "bad option \"$option\""
		    }
		}
	    }
	}
    }

    return $result
}

# dom::tcl::DocumentType:Delete --
#
#	Handle node destruction
#
# Arguments:
#	name	node token
#	old	)
#	new	) arguments appended by trace command
#	op	)
#
# Results:
#	Node is destroyed

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

# dom::tcl::node --
#
#	Functions for a general node.
#
#	Implements EventTarget Interface - introduced in DOM Level 2
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument
    variable nodeOptionsRW nodeValue|cdatasection

    # Allowing nodeName to be rw is not standard DOM.
    # A validating implementation would have to be very careful
    # in allowing this feature
    if {$::dom::strictDOM} {
	append nodeOptionsRO |nodeName
    } else {
	append nodeOptionsRW |nodeName
    }
}
# NB. cdatasection is not a standard DOM option

proc dom::tcl::node {method token args} {
    variable nodeOptionsRO
    variable nodeOptionsRW

    upvar #0 $token node

    set result {}

    switch -glob -- $method {
	cg* {
	    # cget

	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::node cget token option\""
	    }
	    if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
		switch $option {
		    nodeName {
			set result $node(node:nodeName)
			switch $node(node:nodeType) {
			    textNode {
				catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]}
			    }
			    default {
			    }
			}
		    }
		    childNodes {
			# How are we going to handle documentElement?
			set result $node(node:childNodes)
		    }
		    firstChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    document {
				set result [lindex $children 0]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children 0]
			    }
			}
		    }
		    lastChild {
			upvar #0 $node(node:childNodes) children
			switch $node(node:nodeType) {
			    document {
				set result [lindex $children end]
				catch {set result $node(document:documentElement)}
			    }
			    default {
				set result [lindex $children end]
			    }
			}
		    }
		    previousSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			upvar #0 $node(node:parentNode) parent
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx -1]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    nextSibling {
			# BUG: must take documentElement into account
			# Find the parent node
			upvar #0 $node(node:parentNode) parent
			upvar #0 $parent(node:childNodes) children
			set idx [lsearch $children $token]
			if {$idx >= 0} {
			    set sib [lindex $children [incr idx]]
			    if {[llength $sib]} {
				set result $sib
			    } else {
				set result {}
			    }
			} else {
			    set result {}
			}
		    }
		    attributes {
			if {[string compare $node(node:nodeType) element]} {
			    set result {}
			} else {
			    set result $node(element:attributeList)
			}
		    }
		    ownerDocument {
			if {[string compare $node(node:parentNode) {}]} {
			    return [namespace qualifiers $token]::Document
			} else {
			    return $token
			}
		    }
		    default {
			return [GetField node(node:$option)]
		    }
		}
	    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
		return [GetField node(node:$option)]
	    } else {
		return -code error "unknown option \"[lindex $args 0]\""
	    }
	}
	co* {
	    # configure

	    if {[llength $args] == 1} {
		return [node cget $token [lindex $args 0]]
	    } elseif {[expr [llength $args] % 2]} {
		return -code error "wrong \# args: should be \"::dom::node configure node option\""
	    } else {
		foreach {option value} $args {
		    if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {

			switch $opt,$node(node:nodeType) {
			    nodeValue,textNode -
			    nodeValue,processingInstruction {
				# Dispatch event
				set evid [CreateEvent $token DOMCharacterDataModified]
				event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {} {}
				set node(node:nodeValue) $value
				node dispatchEvent $token $evid
				DOMImplementation destroy $evid
			    }
			    default {
				set node(node:$opt) $value
			    }
			}

		    } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
			return -code error "attribute \"$option\" is read-only"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	in* {

	    # insertBefore

	    # Previous and next sibling relationships are OK, 
	    # because they are dynamically determined

	    if {[llength $args] < 1 || [llength $args] > 2} {
		return -code error "wrong # args: should be \"dom::node insertBefore token new ?ref?\""
	    }

	    upvar #0 [lindex $args 0] newChild
	    if {[string compare [namespace qualifiers [lindex $args 0]] [namespace qualifiers $token]]} {
		return -code error "new node must be in the same document"
	    }

	    switch [llength $args] {
		1 {
		    # Append as the last node
		    if {[string length $newChild(node:parentNode)]} {
			node removeChild $newChild(node:parentNode) [lindex $args 0]
		    }
		    lappend $node(node:childNodes) [lindex $args 0]
		    set newChild(node:parentNode) $token
		}
		2 {
		    upvar #0 [lindex $args 1] refChild

		    if {[string compare [namespace qualifiers [lindex $args 1]] [namespace qualifiers [lindex $args 0]]]} {
			return -code error "nodes must be in the same document"
		    }
		    set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
		    if {$idx < 0} {
			return -code error "no such reference child"
		    } else {

			# Remove from previous parent
			if {[string length $newChild(node:parentNode)]} {
			    node removeChild $newChild(node:parentNode) [lindex $args 0]
			}

			# Insert into new node
			set $node(node:childNodes) \
				[linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
			set newChild(node:parentNode) $token
		    }
		}
	    }

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	    set result [lindex $args 0]

	}

	rep* {

	    # replaceChild

	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be \"dom::node replaceChild token new old\""
	    }

	    upvar #0 [lindex $args 0] newChild
	    upvar #0 [lindex $args 1] oldChild
	    upvar #0 $node(node:childNodes) children

	    # Find where to insert new child
	    set idx [lsearch $children [lindex $args 1]]
	    if {$idx < 0} {
		return -code error "no such old child"
	    }

	    # Remove new child from current parent
	    if {[string length $newChild(node:parentNode)]} {
		node removeChild $newChild(node:parentNode) [lindex $args 0]
	    }

	    set children \
		[lreplace $children $idx $idx [lindex $args 0]]
	    set newChild(node:parentNode) $token

	    # Update old child to reflect lack of parentage
	    set oldChild(node:parentNode) {}

	    set result [lindex $args 1]

	    event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
	    FireNodeInsertedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	removeC* {

	    # removeChild