dom.tcl

Linux下的MSN聊天程序源码

# dom.tcl --
#
#	This file implements the Tcl language binding for the DOM -
#	the Document Object Model.  Support for the core specification
#	is given here.  Layered support for specific languages, 
#	such as HTML, will be in separate modules.
#
# Copyright (c) 1998-2004 Zveno Pty Ltd
# http://www.zveno.com/
#
# See the file "LICENSE" in this distribution for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# $Id: dom.tcl 5914 2006-01-23 12:32:51Z tjikkun $

# We need the xml package, so that we get Name defined

package require xml 3.1

package provide dom::tcl 3.1

# Define generic constants

namespace eval dom {
    namespace export DOMImplementation
    namespace export hasFeature createDocument create createDocumentType
    namespace export createNode destroy isNode parse selectNode serialize
    namespace export trim

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export documenttype
    namespace export event

    variable maxSpecials
    if {![info exists maxSpecials]} {
	set maxSpecials 10
    }

    variable strictDOM 0

    # Default -indentspec value
    #	spaces-per-indent-level {collapse-re collapse-value}
    variable indentspec [list 2 [list {        } \t]]

    # The Namespace URI for XML Namespace declarations
    variable xmlnsURI http://www.w3.org/2000/xmlns/

    # DOM Level 2 Event defaults
    variable bubbles
    array set bubbles {
	DOMFocusIn 1
	DOMFocusOut 1
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 1
	mouseout 1
	DOMSubtreeModified 1
	DOMNodeInserted 1
	DOMNodeRemoved 1
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 1
	DOMAttrRemoved 1
	DOMCharacterDataModified 1
    }
    variable cancelable
    array set cancelable {
	DOMFocusIn 0
	DOMFocusOut 0
	DOMActivate 1
	click 1
	mousedown 1
	mouseup 1
	mouseover 1
	mousemove 0
	mouseout 1
	DOMSubtreeModified 0
	DOMNodeInserted 0
	DOMNodeRemoved 0
	DOMNodeInsertedIntoDocument 0
	DOMNodeRemovedFromDocument 0
	DOMAttrModified 0
	DOMAttrRemoved 0
	DOMCharacterDataModified 0
    }
}

namespace eval dom::tcl {
    namespace export DOMImplementation
    namespace export hasFeature createDocument create createDocumentType
    namespace export createNode destroy isNode parse selectNode serialize
    namespace export trim

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event
}

foreach p {DOMImplementation hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim document documentFragment node element textNode attribute processingInstruction event documenttype} {

    proc dom::$p args "return \[eval tcl::$p \$args\]"

}

# Data structures
#
# Documents are stored in a Tcl namespace within the ::dom namespace.
# The Document array variable stores data for the document itself.
# Each node has an array variable for its data.
#
# "Live" data objects are stored as a separate Tcl variable.
# Lists, such as child node lists, are Tcl list variables (ie scalar)
# and keyed-value lists, such as attribute lists, are Tcl array
# variables.  The accessor function returns the variable name,
# which the application should treat as a read-only object.
#
# A token is a FQ Tcl variable name.

# dom::tcl::DOMImplementation --
#
#	Implementation-dependent functions.
#	Most importantly, this command provides a function to
#	create a document instance.
#
# Arguments:
#	method	method to invoke
#	token	token for node
#	args	arguments for method
#
# Results:
#	Depends on method used.

namespace eval dom::tcl {
    variable DOMImplementationOptions {}
    variable DOMImplementationCounter
    if {![info exists DOMImplementationCounter]} {
	set DOMImplementationCounter 0
    }
}

proc dom::tcl::DOMImplementation {method args} {
    variable DOMImplementationOptions
    variable DOMImplementationCounter

    switch -- $method {

	hasFeature {

	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be dom::DOMImplementation method args..."
	    }

	    # Later on, could use Tcl package facility
	    if {[regexp {create|destroy|parse|query|serialize|trim|Events|UIEvents|isNode} [lindex $args 0]]} {
		if {![string compare [lindex $args 1] "1.0"]} {
		    return 1
		} else {
		    return 0
		}
	    } else {
		return 0
	    }

	}

	createDocument {
	    # createDocument introduced in DOM Level 2

	    if {[llength $args] != 3} {
		return -code error "wrong # args: should be DOMImplementation nsURI name doctype"
	    }

	    set doc [DOMImplementation create]

	    if {[string length [lindex $args 2]]} {
		array set $doc [list document:doctype [lindex $args 2]]
	    }

	    document createElementNS $doc [lindex $args 0] [lindex $args 1]

	    return $doc
	}

	create {

	    # Non-standard method (see createDocument)
	    # Bootstrap a document instance

	    if {[llength $args] > 0} {
		return -code error "wrong # args: should be DOMImplementation create"
	    }

	    # Allocate unique document array name
	    set ns [namespace current]::document[incr DOMImplementationCounter]
	    set name ${ns}::Document

	    # Create the Tcl namespace for this document
	    namespace eval $ns {
		namespace export Document
	    }

	    set varPrefix ${name}var
	    set arrayPrefix ${name}arr

	    array set $name [list counter 1 \
		node:nodeType document			\
		node:parentNode {}			\
		node:nodeName #document			\
		node:nodeValue {}			\
		node:childNodes ${varPrefix}1		\
		documentFragment:masterDoc $name	\
		document:implementation [namespace current]::DOMImplementation		\
		document:xmldecl {version 1.0}		\
		document:documentElement {}		\
		document:doctype {}			\
		]

	    # Initialise child node list
	    set $varPrefix {}

	    # Create a Tcl command for the document
	    proc $name {method args} "return \[eval [namespace current]::document \[list \$method\] $name \$args\]"

	    # Capture destruction of the document
	    trace add command $name delete [namespace code [list Document:Delete $name]]

	    # Return the new toplevel node
	    return $name
	}

	createDocumentType {
	    # Introduced in DOM Level 2

	    # Patch from c.l.t., Richard Calmbach ([e-mail] )

	    if {[llength $args] < 3 || [llength $args] > 4} {
		return -code error "wrong # args: should be: DOMImplementation createDocumentType qname publicid systemid ?internaldtd?"
	    }

	    return [eval CreateDocType $args]
	}

	createNode {
	    # Non-standard method
	    # Creates node(s) in the given document given an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be dom::DOMImplementation createNode xpath"
	    }

	    package require xpath

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

	destroy {

	    # Free all memory associated with a node

	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be dom::DOMImplementation destroy token"
	    }

	    if {[catch {upvar #0 [lindex $args 0] node}]} {
		# If the document is being destroyed then the Tcl namespace no longer exists
		return {}
	    }

	    switch $node(node:nodeType) {

		document -
		documentFragment {

		    if {[string length $node(node:parentNode)]} {
			unset $node(node:childNodes)

			# Dispatch events
			event postMutationEvent $node(node:parentNode) DOMSubtreeModified

			return {}
		    }

		    # else this is the root document node,
		    # and we can optimize the cleanup.
		    # No need to dispatch events.

		    # First remove all command traces
		    foreach nodecmd [info commands [namespace qualifiers [lindex $args 0]]::*] {
			trace remove command $nodecmd delete [namespace code [list Node:Delete $nodecmd]]
		    }

		    namespace delete [namespace qualifiers [lindex $args 0]]
		}

		documentType {
		    trace remove command [lindex $args 0] delete [namespace code [list DocumentType:Delete [lindex $args 0]]]
		    rename [lindex $args 0] {}
		    unset [lindex $args 0]
		}

		element {
		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset $node(node:childNodes)
		    unset $node(element:attributeList)
		    unset node
		    set name [lindex $args 0]
		    trace remove command $name delete [namespace code [list Node:Delete $name]]
		    rename $name {}

		    # Don't dispatch events here -
		    # already done by removeChild
		}

		event {
		    set name [lindex $args 0]
		    trace remove command $name delete [namespace code [list Node:Delete $name]]
		    rename $name {}
		    unset node
		}

		default {
		    # Store the parent for later
		    set parent $node(node:parentNode)

		    # First make sure the node is removed from the tree
		    if {[string length $node(node:parentNode)]} {
			node removeChild $node(node:parentNode) [lindex $args 0]
		    }
		    unset node
		    set name [lindex $args 0]
		    trace remove command $name delete [namespace code [list Node:Delete $name]]
		    rename $name {}

		    # Dispatch events
		    event postMutationEvent $parent DOMSubtreeModified

		}

	    }

	    return {}

	}

	isNode {
	    # isNode - non-standard method
	    # Sometimes it is useful to check if an arbitrary string
	    # refers to a DOM node

	    upvar #0 [lindex $args 0] node

	    if {![info exists node]} {
		return 0
	    } elseif {[info exists node(node:nodeType)]} {
		return 1
	    } else {
		return 0
	    }
	}

	parse {

	    # This implementation uses TclXML version 2.0.
	    # TclXML can choose the best installed parser.

	    if {[llength $args] < 1} {
		return -code error "wrong # args: should be dom::DOMImplementation parse xml ?args...?"
	    }

	    array set opts {-parser {} -progresscommand {} -chunksize 8196}
	    if {[catch {array set opts [lrange $args 1 end]}]} {
		return -code error "bad configuration options"
	    }

	    # Create a state array for this parse session
	    set state [namespace current]::parse[incr DOMImplementationCounter]
	    array set $state [array get opts -*]
	    array set $state [list progCounter 0]
	    set errorCleanup {}

	    if {[string length $opts(-parser)]} {
		set parserOpt [list -parser $opts(-parser)]
	    } else {
		set parserOpt {}
	    }
	    if {[catch {package require xml} version]} {
		eval $errorCleanup
		return -code error "unable to load XML parsing package"
	    }
	    set parser [eval xml::parser $parserOpt]

	    $parser configure \
		-elementstartcommand [namespace code [list ParseElementStart $state]]	\
		-elementendcommand [namespace code [list ParseElementEnd $state]]	\
		-characterdatacommand [namespace code [list ParseCharacterData $state]] \
		-processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \
		-commentcommand [namespace code [list ParseComment $state]] \
		-entityreferencecommand [namespace code [list ParseEntityReference $state]] \
		-xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \
		-doctypecommand [namespace code [list ParseDocType $state]] \
		-final 1

	    # Create top-level document
	    array set $state [list docNode [DOMImplementation create]]
	    array set $state [list current [lindex [array get $state docNode] 1]]

	    # Parse data
	    # Bug in TclExpat - doesn't handle non-final inputs
	    if {0 && [string length $opts(-progresscommand)]} {
		$parser configure -final false
		while {[string length [lindex $args 0]]} {
		    $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)]
		    set args [lreplace $args 0 0 \
			[string range [lindex $args 0] $opts(-chunksize) end]]
		    uplevel #0 $opts(-progresscommand)
		}
		$parser configure -final true
	    } elseif {[catch {$parser parse [lindex $args 0]} err]} {
		catch {rename $parser {}}
		catch {unset $state}
		return -code error $err
	    }

	    # Free data structures which are no longer required
	    $parser free
	    catch {rename $parser {}}

	    set doc [lindex [array get $state docNode] 1]
	    unset $state
	    return $doc

	}

	selectNode {
	    # Non-standard method
	    # Returns nodeset in the given document matching an XPath expression

	    if {[llength $args] != 2} {
		return -code error "wrong # args: should be dom::DOMImplementation selectNode token xpath"
	    }

	    package require xpath

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

	serialize {

	    if {[llength $args] < 1} {
		return -code error "wrong # args: should be dom::DOMImplementation serialize token"
	    }

	    upvar #0 [lindex $args 0] node

	    return [eval [list Serialize:$node(node:nodeType)] $args]

	}

	trim {

	    # Removes textNodes that only contain white space

	    if {[llength $args] != 1} {
		return -code error "wrong # args: should be dom::DOMImplementation trim token"
	    }

	    Trim [lindex $args 0]

	    # Dispatch DOMSubtreeModified event once here?

	    return {}

	}