dom.tcl

Linux下的MSN聊天程序源码

	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be \"dom::node removeChild token child\""
	    }
	    upvar #0 [lindex $args 0] oldChild
	    if {[string compare [namespace qualifiers [lindex $args 0]] [namespace qualifiers $token]]} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }

	    # Remove the child from the parent
	    upvar #0 $node(node:childNodes) myChildren
	    if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} {
		return -code error "node \"[lindex $args 0]\" is not a child"
	    }
	    set myChildren [lreplace $myChildren $idx $idx]

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

	    set result [lindex $args 0]

	    # Event propagation has a problem here:
	    # Nodes that until recently were ancestors may
	    # want to capture the event, but we've just removed
	    # the parentage information.  They get a DOMSubtreeModified
	    # instead.
	    event postMutationEvent [lindex $args 0] DOMNodeRemoved -relatedNode $token
	    FireNodeRemovedEvents [lindex $args 0]
	    event postMutationEvent $token DOMSubtreeModified

	}

	ap* {

	    # appendChild

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

	    # Add to new parent
	    node insertBefore $token [lindex $args 0]

	    set result [lindex $args 0]

	}

	hasChildNodes {
	    set result [Min 1 [llength [set $node(node:childNodes)]]]
	}

	isSameNode {
	    # Introduced in DOM Level 3
	    switch [llength $args] {
		1 {
		    return [expr {$token == [lindex $args 0]}]
		}
		default {
		    return -code error "wrong # args: should be \"dom::node isSameNode token ref\""
		}
	    }
	}

	cl* {
	    # cloneNode

	    # May need to pay closer attention to generation of events here

	    set deep 0
	    switch [llength $args] {
		0 {
		}
		2 {
		    foreach {opt value} $args {
			switch -- $opt {
			    -deep {
				set deep [Boolean $value]
			    }
			    default {
				return -code error "bad option \"$opt\""
			    }
			}
		    }
		}
		default {
		    return -code error "wrong # args: should be \"dom::node cloneNode token ?-deep boolean?\""
		}
	    }

	    switch $node(node:nodeType) {
		element {
		    set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -document [namespace qualifiers $token]::Document]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child -deep 1]
			}
		    }
		}
		textNode {
		    set result [CreateTextNode {} $node(node:nodeValue) -document [namespace qualifiers $token]::Document]
		}
		document {
		    set result [DOMImplementation create]
		    upvar #0 $result clonedDoc
		    array set clonedDoc [array get node document:doctype]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [document importNode $result $child -deep 1]
			}
		    }
		}
		documentFragment -
		default {
		    set result [CreateGeneric {} node:nodeType $node(node:nodeType) -document [namespace qualifiers $token]::Document]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child -deep 1]
			}
		    }
		}
	    }
	}

	ch* {
	    # children -- non-standard method

	    # If this is a textNode, then catch the error
	    set result {}
	    catch {set result [set $node(node:childNodes)]}

	}

	par* {
	    # parent -- non-standard method

	    return $node(node:parentNode)

	}

	pat* {
	    # path -- non-standard method

	    for {
		set ancestor $token
		upvar #0 $token ancestorNd
		set result {}
	    } {[string length $ancestorNd(node:parentNode)]} {
		set ancestor $ancestorNd(node:parentNode)
		upvar #0 $ancestor ancestorNd
	    } {
		set result [linsert $result 0 $ancestor]
	    }
	    # The last node is the document node
	    set result [linsert $result 0 $ancestor]

	}

	createNode {
	    # createNode -- non-standard method

	    # Creates node(s) in this document given an XPath expression.
	    # Relative location paths have this node as their initial context.

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

	    package require xpath

	    return [XPath:CreateNode $token [lindex $args 0]]
	}

	selectNode {
	    # selectNode -- non-standard method

	    # Returns nodeset in this document matching an XPath expression.
	    # Relative location paths have this node as their initial context.

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

	    package require xpath

	    return [XPath:SelectNode $token [lindex $args 0]]
	}

	stringValue {
	    # stringValue -- non-standard method
	    # Returns string value of a node, as defined by XPath Rec.

	    if {[llength $args] > 0} {
		return -code error "wrong # args: should be \"dom::node stringValue token\""
	    }

	    switch $node(node:nodeType) {
		document -
		documentFragment -
		element {
		    set value {}
		    foreach child [set $node(node:childNodes)] {
			switch [node cget $child -nodeType] {
			    element -
			    textNode {
				append value [node stringValue $child]
			    }
			    default {
				# Other nodes are not considered
			    }
			}
		    }
		    return $value
		}
		attribute -
		textNode -
		processingInstruction -
		comment {
		    return $node(node:nodeValue)
		}
		default {
		    return {}
		}
	    }

	}

	addEv* {
	    # addEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 1} {
		return -code error "wrong # args: should be \"dom::node addEventListener token type ?listener? ?option value...?\""
	    }

	    set type [lindex $args 0]
	    set args [lrange $args 1 end]
	    set listener [lindex $args 0]
	    if {[llength $args] == 1} {
		set args {}
	    } elseif {[llength $args] > 1} {
		if {[string match -* $listener]} {
		    set listener {}
		} else {
		    set args [lrange $args 1 end]
		}
	    }
	    array set opts {-usecapture 0}
	    if {[catch {array set opts $args}]} {
		return -code error "missing value for option \"[lindex $args end]\""
	    }
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    if {[string length $listener]} {
		if {![info exists node(event:$type:$listenerType)] || \
			[lsearch $node(event:$type:$listenerType) $listener] < 0} {
		    lappend node(event:$type:$listenerType) $listener
		}
		# else avoid registering same listener twice
	    } else {
		# List all listeners
		set result {}
		catch {set result $node(event:$type:$listenerType)}
		return $result
	    }
	}

	removeE* {
	    # removeEventListener -- introduced in DOM Level 2

	    if {[llength $args] < 2} {
		return -code error "wrong # args: should be \"dom::node removeEventListener token type listener ?option value...?\""
	    }

	    set type [lindex $args 0]
	    set listener [lindex $args 1]
	    array set opts {-usecapture 0}
	    array set opts [lrange $args 2 end]
	    set opts(-usecapture) [Boolean $opts(-usecapture)]
	    set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]

	    set idx [lsearch $node(event:$type:$listenerType) $listener]
	    if {$idx >= 0} {
		set node(event:$type:$listenerType) [lreplace $node(event:$type:$listenerType) $idx $idx]
	    }

	}

	disp* {
	    # dispatchEvent -- introduced in DOM Level 2

	    # This is where the fun happens!
	    # Check to see if there one or more event listener,
	    # if so trigger the listener(s).
	    # Then pass the event up to the ancestor.
	    # This may be modified by event capturing and bubbling.

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

	    set eventId [lindex $args 0]
	    upvar #0 $eventId event
	    set type $event(type)

	    if {![string length $event(eventPhase)]} {

		# This is the initial dispatch of the event.
		# First trigger any capturing event listeners
		# Starting from the root, proceed downward

		set event(eventPhase) capturing_phase
		set event(target) $token

		# DOM L2 specifies that the ancestors are determined
		# at the moment of event dispatch, so using a static
		# list is the correct thing to do

		foreach ancestor [lreplace [node path $token] end end] {
		    set event(currentNode) $ancestor

		    upvar #0 $ancestor ancNode

		    if {[info exists ancNode(event:$type:capturer)]} {
			foreach capturer $ancNode(event:$type:capturer) {
			    if {[catch {uplevel #0 $capturer [list $eventId]} capturerError]} {
				bgerror "error in capturer \"$capturerError\""
			    }
			}

			# A listener may stop propagation,
			# but we check here to let all of the
			# listeners at that level complete

			if {$event(cancelable) && $event(stopPropagation)} {
			    break
			}
		    }
		}

		# Prepare for next phase
		set event(eventPhase) at_target

	    }

	    set event(currentNode) $token

	    if {[info exists node(event:$type:listener)]} {
		foreach listener $node(event:$type:listener) {
		    if {[catch {uplevel #0 $listener [list $eventId]} listenerError]} {
			bgerror "error in listener \"$listenerError\""
		    }
		}
	    }

	    set event(eventPhase) bubbling_phase

	    # Now propagate the event
	    if {$event(cancelable) && $event(stopPropagation)} {
		# Event has been cancelled
	    } elseif {[llength $node(node:parentNode)]} {
		# Go ahead and propagate
		node dispatchEvent $node(node:parentNode) $eventId
	    }

	    set event(dispatched) 1
	}

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

    }

    return $result
}

# dom::tcl::Node:create --
#
#	Generic node creation.
#	See also CreateElement, CreateTextNode, CreateGeneric.
#
# Arguments:
#	pVar	array in caller which contains parent details
#	args	configuration options
#
# Results:
#	New child node created.

proc dom::tcl::Node:create {pVar args} {
    upvar #0 $pVar parent

    array set opts {-name {} -value {}}
    array set opts $args

    upvar #0 [namespace qualifiers $pVar]::Document document

    # Create new node
    if {![info exists opts(-id)]} {
	set opts(-id) node[incr document(counter)]
    }
    set child [namespace qualifiers $pVar]::$opts(-id)
    upvar #0 $child new
    array set new [list \
	    node:parentNode $opts(-parent)	\
	    node:childNodes ${child}var		\
	    node:nodeType $opts(-type)		\
	    node:nodeName $opts(-name)		\
	    node:nodeValue $opts(-value)	\
	    element:attributeList ${child}arr	\
    ]
    set ${child}var {}
    array set ${child}arr {}

    # Update parent node
    if {![info exists parent(document:documentElement)]} {
	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::Node:set --
#
#	Generic node update
#
# Arguments:
#	token	node token
#	args	configuration options
#
# Results:
#	Node modified.

proc dom::tcl::Node:set {token args} {
    upvar #0 $token node

    foreach {key value} $args {
	set node($key) $value
    }

    return {}
}

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

proc dom::tcl::Node:Delete {name old new op} {
    if {[catch {DOMImplementation destroy $name} ret]} {
	# Document has been deleted... namespace has been destroyed
    } else {
	return $ret
    }
}

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

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

    return {}