Merge commit '55c7ed6e4d159cebe06999bf61e668284a89cd69' as 'tclxml'

3 files changed, 4919 insertions, 0 deletions

diff --git a/tclxml/tcldom-tcl/dom.tcl b/tclxml/tcldom-tcl/dom.tcl
new file mode 100644
index 0000000..b3edc99
--- /dev/null
+++ b/tclxml/tcldom-tcl/dom.tcl
@@ -0,0 +1,4291 @@
+# 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,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+# We need the xml package, so that we get Name defined
+
+package require xml 3.0
+
+package provide dom::tcl 3.0
+
+# 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 (rc@hnc.com )
+
+	    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 {}
+
+	}
+
+	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			\
+	    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
+
+	    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 {}
+}
+
+# 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 value} $args {
+		    if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
+			return -code error "attribute \"$option\" is read-only"
+		    } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
+			switch $opt {
+			    data {
+				set evid [CreateEvent $token DOMCharacterDataModified]
+				event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {} {}
+				set node(node:nodeValue) $value
+				node dispatchEvent $token $evid
+				DOMImplementation destroy $evid
+			    }
+			    default {
+				set node(node:$opt) $value
+			    }
+			}
+		    } else {
+			return -code error "unknown option \"$option\""
+		    }
+		}
+	    }
+	}
+
+	default {
+	    return -code error "unknown method \"$method\""
+	}
+
+    }
+
+    return $result
+}
+
+#################################################
+#
+# DOM Level 2 Interfaces
+#
+#################################################
+
+# dom::tcl::event --
+#
+#	Implements Event Interface
+#
+#	Subclassed Interfaces are also defined here,
+#	such as UIEvents.
+#
+# Arguments:
+#	method	method to invoke
+#	token	token for event
+#	args	arguments for method
+#
+# Results:
+#	Depends on method used.
+
+namespace eval dom::tcl {
+    variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName|attrChange
+    variable eventOptionsRW {}
+
+    # Issue: should the attributes belonging to the subclassed Interface
+    # be separated out?
+
+    variable uieventOptionsRO detail|view
+    variable uieventOptionsRW {}
+
+    variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode
+    variable mouseeventOptionsRW {}
+
+    variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName
+    variable mutationeventOptionsRW {}
+}
+
+proc dom::tcl::event {method token args} {
+    variable eventOptionsRO
+    variable eventOptionsRW
+
+    upvar #0 $token event
+
+    set result {}
+
+    switch -glob -- $method {
+
+	cg* {
+	    # cget
+
+	    if {[llength $args] != 1} {
+		return -code error "too many arguments"
+	    }
+	    if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} {
+		return $event($option)
+	    } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} {
+		return $event($option)
+	    } else {
+		return -code error "unknown option \"[lindex $args 0]\""
+	    }
+	}
+
+	co* {
+	    # configure
+
+	    if {[llength $args] == 1} {
+		return [event 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)$} $eventOptionsRW] $option discard opt]} {
+			set event($opt) $value
+		    } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} {
+			return -code error "attribute \"$option\" is read-only"
+		    } else {
+			return -code error "unknown option \"$option\""
+		    }
+		}
+	    }
+
+	}
+
+	st* {
+	    # stopPropagation
+
+	    set event(stopPropagation) 1
+	}
+
+	pr* {
+	    # preventDefault
+
+	    set event(preventDefault) 1
+	}
+
+	initE* {
+	    # initEvent
+
+	    if {[llength $args] != 3} {
+		return -code error "wrong # args: should be dom::event initEvent token type bubbles cancelable"
+	    }
+
+	    if {$event(dispatched)} {
+		return -code error "event has been dispatched"
+	    }
+
+	    foreach {event(type) event(bubbles) event(cancelable)} $args break
+	}
+
+	initU* {
+	    # initUIEvent
+
+	    if {[llength $args] < 4 || [llength $args] > 5} {
+		return -code error "wrong # args: should be dom::event initUIEvent token type bubbles cancelable view detail"
+	    }
+
+	    if {$event(dispatched)} {
+		return -code error "event has been dispatched"
+	    }
+
+	    set event(detail) 0
+	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break
+	}
+
+	initMo* {
+	    # initMouseEvent
+
+	    if {[llength $args] != 15} {
+		return -code error "wrong # args: should be dom::event initMouseEvent token type bubbles cancelable view detail screenX screenY clientX clientY ctrlKey altKey shiftKey metaKey button relatedNode"
+	    }
+
+	    if {$event(dispatched)} {
+		return -code error "event has been dispatched"
+	    }
+
+	    set event(detail) 1
+	    foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail) event(screenX) event(screenY) event(clientX) event(clientY) event(ctrlKey) event(altKey) event(shiftKey) event(metaKey) event(button) event(relatedNode)} $args break
+	}
+
+	initMu* {
+	    # initMutationEvent
+
+	    if {[llength $args] != 8} {
+		return -code error "wrong # args: should be dom::event initMutationEvent token type bubbles cancelable relatedNode prevValue newValue attrName attrChange"
+	    }
+
+	    if {$event(dispatched)} {
+		return -code error "event has been dispatched"
+	    }
+
+	    foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName) event(attrChange)} $args break
+	}
+
+	postUI* {
+	    # postUIEvent, non-standard convenience method
+
+	    set evType [lindex $args 0]
+	    array set evOpts [list \
+		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)	\
+		    -view {}			\
+		    -detail {}			\
+	    ]
+	    array set evOpts [lrange $args 1 end]
+
+	    set evid [CreateEvent $token $evType]
+	    event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail)
+	    node dispatchEvent $token $evid
+	    DOMImplementation destroy $evid
+
+	}
+
+	postMo* {
+	    # postMouseEvent, non-standard convenience method
+
+	    set evType [lindex $args 0]
+	    array set evOpts [list \
+		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)	\
+		    -view {}			\
+		    -detail {}			\
+		    -screenX {}			\
+		    -screenY {}			\
+		    -clientX {}			\
+		    -clientY {}			\
+		    -ctrlKey {}			\
+		    -altKey {}			\
+		    -shiftKey {}		\
+		    -metaKey {}			\
+		    -button {}			\
+		    -relatedNode {}		\
+	    ]
+	    array set evOpts [lrange $args 1 end]
+
+	    set evid [CreateEvent $token $evType]
+	    event initMouseEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) $evOpts(-screenX) $evOpts(-screenY) $evOpts(-clientX) $evOpts(-clientY) $evOpts(-ctrlKey) $evOpts(-altKey) $evOpts(-shiftKey) $evOpts(-metaKey) $evOpts(-button) $evOpts(-relatedNode)
+	    node dispatchEvent $token $evid
+	    DOMImplementation destroy $evid
+
+	}
+
+	postMu* {
+	    # postMutationEvent, non-standard convenience method
+
+	    set evType [lindex $args 0]
+	    array set evOpts [list \
+		    -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)	\
+		    -relatedNode {}			\
+		    -prevValue {} -newValue {}		\
+		    -attrName {} -attrChange {}		\
+	    ]
+	    array set evOpts [lrange $args 1 end]
+
+	    set evid [CreateEvent $token $evType]
+	    event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName) $evOpts(-attrChange)
+	    node dispatchEvent $token $evid
+	    DOMImplementation destroy $evid
+
+	}
+
+	default {
+	    return -code error "unknown method \"$method\""
+	}
+    }
+
+    return $result
+}
+
+# dom::tcl::CreateEvent --
+#
+#	Create an event object
+#
+# Arguments:
+#	token	parent node
+#	type	event type
+#	args	configuration options
+#
+# Results:
+#	Returns event token
+
+proc dom::tcl::CreateEvent {token type 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]::event[incr document(counter)]
+    } elseif {[info exists $opts(-document)]} {
+	upvar #0 $opts(-document) document
+	set child [namespace qualifiers $opts(-document)]::event[incr document(counter)]
+    }
+
+    upvar #0 $child event
+
+    # Create the event
+    array set event [list \
+	    node:nodeType event	\
+	    type $type		\
+	    target {}		\
+	    currentNode {}	\
+	    cancelable 1	\
+	    stopPropagation 0	\
+	    preventDefault 0	\
+	    dispatched 0	\
+	    bubbles 1		\
+	    eventPhase {}	\
+	    timeStamp [clock clicks -milliseconds]	\
+	    ]
+
+    proc $child {method args} "return \[eval [namespace current]::event \[list \$method\] $child \$args\]"
+    trace add command $child delete [namespace code [list Node:Delete $child]]
+
+    return $child
+}
+
+#################################################
+#
+# Serialisation
+#
+#################################################
+
+# dom::tcl::Serialize:documentFragment --
+#
+#	Produce text for documentFragment.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:documentFragment {token args} {
+    upvar #0 $token node
+
+    if {[string compare "Document" [namespace tail $token]]} {
+	return [eval [list Serialize:node $token] $args]
+    } else {
+	if {[string compare {} [GetField node(document:documentElement)]]} {
+	    return [eval Serialize:document [list $token] $args]
+	} else {
+	    return -code error "document has no document element"
+	}
+    }
+
+}
+
+# dom::tcl::Serialize:document --
+#
+#	Produce text for document.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:document {token args} {
+    upvar #0 $token node
+    array set opts {
+	-showxmldecl 1
+	-showdoctypedecl 1
+    }
+    array set opts $args
+
+    set result {}
+
+    if {[string length $node(document:doctype)]} {
+
+	upvar #0 $node(document:doctype) doctype
+
+	# Bug fix: can't use Serialize:attributeList for XML declaration,
+	# since attributes must occur in a given order (XML 2.8 [23])
+
+	set result {}
+
+	if {$opts(-showxmldecl)} {
+	    append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n
+	}
+	if {$opts(-showdoctypedecl)} {
+	    # Is document element in an XML Namespace?
+	    # If so then include prefix in doctype decl
+	    foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break
+	    if {![string length $prefix]} {
+		# The prefix may not have been allocated yet
+		upvar #0 $node(document:documentElement) docel
+		if {[info exists docel(node:namespaceURI)] && \
+			[string length $docel(node:namespaceURI)]} {
+		    set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)]
+		    set docelName $declPrefix:$doctype(doctype:name)
+		} else {
+		    set docelName $doctype(doctype:name)
+		}
+	    } else {
+		set docelName $doctype(doctype:name)
+	    }
+	    # Applied patch by Marco Gonnelli, bug #590914
+	    append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:publicId) $doctype(doctype:systemId)][expr {[string length $doctype(doctype:internalSubset)] ? " \[[string trim $doctype(doctype:internalSubset) \{\} ]\]" : {}}]>\n
+	}
+    }
+
+    # BUG #525505: Want to serialize all children including the
+    # document element.
+
+    if {[info exists $node(node:childNodes)]} {
+	foreach child [set $node(node:childNodes)] {
+	    append result [eval Serialize:[node cget $child -nodeType] [list $child] $args]
+	}
+    }
+
+    return $result
+}
+
+# dom::tcl::Serialize:ExternalID --
+#
+#	Returned appropriately quoted external identifiers
+#
+# Arguments:
+#	publicid	public identifier
+#	systemid	system identifier
+#
+# Results:
+#	text
+
+proc dom::tcl::Serialize:ExternalID {publicid systemid} {
+
+    switch -glob -- [string length $publicid],[string length $systemid] {
+	0,0 {
+	    return {}
+	}
+	0,* {
+	    return " SYSTEM \"$systemid\""
+	}
+	*,* {
+	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
+	    return " PUBLIC \"$publicid\" \"$systemid\""
+	}
+    }
+
+    return {}
+}
+
+# dom::tcl::Serialize:XMLDecl --
+#
+#	Produce text for XML Declaration attribute.
+#	Order is determine by document serialisation procedure.
+#
+# Arguments:
+#	attr	required attribute
+#	attList	attribute list
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:XMLDecl {attr attrList} {
+    array set data $attrList
+    if {![info exists data($attr)]} {
+	return {}
+    } elseif {[string length $data($attr)]} {
+	return " $attr='$data($attr)'"
+    } else {
+	return {}
+    }
+}
+
+# dom::tcl::Serialize:node --
+#
+#	Produce text for an arbitrary node.
+#	This simply serializes the child nodes of the node.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:node {token args} {
+    upvar #0 $token node
+    array set opts $args
+
+    if {[info exists opts(-indent)]} {
+	# NB. 0|1 cannot be used as booleans - mention this in docn
+	if {[regexp {^false|no|off$} $opts(-indent)]} {
+	    # No action required
+	} elseif {[regexp {^true|yes|on$} $opts(-indent)]} {
+	    set opts(-indent) 1
+	} else {
+	    incr opts(-indent)
+	}
+    }
+
+    set result {}
+    foreach childToken [set $node(node:childNodes)] {
+	upvar #0 $childToken child
+	append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]]
+    }
+
+    return $result
+}
+
+# dom::tcl::Serialize:element --
+#
+#	Produce text for an element.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:element {token args} {
+    upvar #0 $token node
+    array set opts {-newline {}}
+    array set opts $args
+
+    set result {}
+    set newline {}
+    if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
+	append result \n
+	set newline \n
+    }
+    append result [eval Serialize:Indent [array get opts]]
+    switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] {
+
+	1,1 {
+	    # XML Namespace is in scope, prefix supplied
+	    if {[string length $node(node:prefix)]} {
+		# Make sure that there's a declaration for this XML Namespace
+		set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)]
+		# ASSERTION: $declPrefix == $node(node:prefix)
+		set nsPrefix $node(node:prefix):
+	    } elseif {[string length $node(node:namespaceURI)]} {
+		set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
+	    } else {
+		set nsPrefix {}
+	    }
+	}
+
+	1,0 {
+	    # XML Namespace is in scope, no prefix
+	    set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
+	    if {![string compare $nsPrefix :]} {
+		set nsPrefix {}
+	    }
+	}
+
+	0,1 {
+	    # Internal error
+	    set nsPrefix {}
+	}
+
+	0,0 -
+	default {
+	    # No XML Namespace is in scope
+	    set nsPrefix {}
+	}
+    }
+    append result <$nsPrefix$node(node:localName)
+
+    append result [Serialize:attributeList [array get $node(element:attributeList)]]
+
+    if {![llength [set $node(node:childNodes)]]} {
+
+	append result />$newline
+
+    } else {
+
+	append result >$newline
+
+	# Do the children
+	if {[hasmixedcontent $token]} {
+	    set opts(-indent) no
+	}
+	append result [eval Serialize:node [list $token] [array get opts]]
+
+	append result [eval Serialize:Indent [array get opts]]
+	append result "$newline</$nsPrefix$node(node:localName)>$newline"
+
+    }
+
+    return $result
+}
+
+# dom::tcl::GetNamespacePrefix --
+#
+#	Determine the XML Namespace prefix for a Namespace URI
+#
+# Arguments:
+#	token	node token
+#	nsuri	XML Namespace URI
+#	args	configuration options
+#
+# Results:
+#	Returns prefix.
+#	May add prefix information to node
+
+proc dom::tcl::GetNamespacePrefix {token nsuri args} {
+    upvar #0 $token node
+    array set options $args
+
+    GetNamespaceDecl $token $nsuri declNode prefix
+
+    if {[llength $declNode]} {
+	# A declaration was found for this Namespace URI
+	return $prefix
+    } else {
+	# No declaration found.  Allocate a prefix
+	# and add XML Namespace declaration
+	set prefix {}
+	catch {set prefix $options(-prefix)}
+	if {![string compare $prefix {}]} {
+	    upvar #0 [namespace qualifiers $token]::Document document
+	    set prefix ns[incr document(counter)]
+	}
+	set node(node:prefix) $prefix
+	upvar \#0 $node(element:attributeList) attrs
+	set attrs(${::dom::xmlnsURI}^$prefix) $nsuri
+
+	return $prefix
+    }
+}
+
+# dom::tcl::GetNamespaceDecl --
+#
+#	Find the XML Namespace declaration.
+#
+# Arguments:
+#	token	node token
+#	nsuri	XML Namespace URI
+#	nodeVar	Variable name for declaration
+#	prefVar Variable for prefix
+#
+# Results:
+#	If the declaration is found returns node and prefix
+
+proc dom::tcl::GetNamespaceDecl {token nsuri nodeVar prefVar} {
+    upvar #0 $token node
+    upvar $nodeVar declNode
+    upvar $prefVar prefix
+
+    while {[string length $node(node:parentNode)]} {
+
+	# Check this node's XML Namespace declarations
+	catch {unset attrs}
+	array set attrs [array get $node(element:attributeList)]
+	foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] {
+	    if {![string compare $decluri $nsuri]} {
+		regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix
+		set declNode $token
+		return
+	    }
+	}
+
+	# Move up to parent
+	set token $node(node:parentNode)
+	upvar #0 $token node
+    }
+
+    # Got to Document node and didn't find XML NS decl
+    set prefix {}
+    set declNode {}
+}
+
+# dom::tcl::Serialize:textNode --
+#
+#	Produce text for a text node.  This procedure may
+#	return a CDATA section where appropriate.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:textNode {token args} {
+    upvar #0 $token node
+
+    if {$node(node:cdatasection)} {
+	return [Serialize:CDATASection $node(node:nodeValue)]
+    } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} {
+	return [Serialize:CDATASection $node(node:nodeValue)]
+    } else {
+	return [Encode $node(node:nodeValue)]
+    }
+}
+
+# dom::tcl::Serialize:ExceedsThreshold --
+#
+#	Applies heuristic(s) to determine whether a text node
+#	should be formatted as a CDATA section.
+#
+# Arguments:
+#	text	node text
+#
+# Results:
+#	Boolean.
+
+proc dom::tcl::Serialize:ExceedsThreshold {text} {
+    return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}]
+}
+
+# dom::tcl::Serialize:CDATASection --
+#
+#	Formats a CDATA section.
+#
+# Arguments:
+#	text	node text
+#
+# Results:
+#	XML text.
+
+proc dom::tcl::Serialize:CDATASection {text} {
+    set result {}
+    while {[regexp {(.*)]]>(.*)} $text discard text trailing]} {
+	set result \]\]&gt\;<!\[CDATA\[$trailing\]\]>$result
+    }
+    return <!\[CDATA\[$text\]\]>$result
+}
+
+# dom::tcl::Serialize:processingInstruction --
+#
+#	Produce text for a PI node.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:processingInstruction {token args} {
+    upvar #0 $token node
+
+    return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>"
+}
+
+# dom::tcl::Serialize:comment --
+#
+#	Produce text for a comment node.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:comment {token args} {
+    upvar #0 $token node
+
+    return [eval Serialize:Indent $args]<!--$node(node:nodeValue)-->
+}
+
+# dom::tcl::Serialize:entityReference --
+#
+#	Produce text for an entity reference.
+#
+# Arguments:
+#	token	node token
+#	args	configuration options
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:entityReference {token args} {
+    upvar #0 $token node
+
+    return &$node(node:nodeName)\;
+}
+
+# dom::tcl::Encode --
+#
+#	Encode special characters
+#
+# Arguments:
+#	value	text value
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Encode value {
+    array set Entity {
+	$ $
+	< &lt;
+	> &gt;
+	& &amp;
+	\" &quot;
+	' &apos;
+    }
+
+    regsub -all {([$<>&"'])} $value {$Entity(\1)} value
+
+    return [subst -nocommand -nobackslash $value]
+}
+
+# dom::tcl::Serialize:attributeList --
+#
+#	Produce text for an attribute list.
+#
+# Arguments:
+#	l	name/value paired list
+#
+# Results:
+#	XML format text.
+
+proc dom::tcl::Serialize:attributeList {l} {
+
+    set result {}
+    foreach {name value} $l {
+
+	if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} {
+	    if {[string compare $nsuri $::dom::xmlnsURI]} {
+		# Need the node token to resolve the Namespace URI
+		append result { } ?:$prefix =
+	    } else {
+		# A Namespace declaration
+		append result { } xmlns:$prefix =
+	    }
+	} else {
+	    append result { } $name =
+	}
+
+	# Handle special characters
+	regsub -all & $value {\&amp;} value
+	regsub -all < $value {\&lt;} value
+
+	if {![string match *\"* $value]} {
+	    append result \"$value\"
+	} elseif {![string match *'* $value]} {
+	    append result '$value'
+	} else {
+	    regsub -all \" $value {\&quot;} value
+	    append result \"$value\"
+	}
+
+    }
+
+    return $result
+}
+
+# dom::tcl::Serialize:Indent --
+#
+#	Calculate the indentation required, if any
+#
+# Arguments:
+#	args	configuration options, which may specify -indent
+#
+# Results:
+#	May return white space
+
+proc dom::tcl::Serialize:Indent args {
+    array set opts [list -indentspec $::dom::indentspec]
+    array set opts $args
+
+    if {![info exists opts(-indent)] || \
+	    [regexp {^false|no|off$} $opts(-indent)]} {
+	return {}
+    }
+
+    if {[regexp {^true|yes|on$} $opts(-indent)]} {
+	# Default indent level is 0
+	return \n
+    }
+
+    if {!$opts(-indent)} {
+	return \n
+    }
+
+    set ws [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }]
+    regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws
+
+    return $ws
+
+}
+
+#################################################
+#
+# Parsing
+#
+#################################################
+
+# dom::tcl::ParseElementStart --
+#
+#	Push a new element onto the stack.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	name		element name
+#	attrList	attribute list
+#	args		configuration options
+#
+# Results:
+#	An element is created within the currently open element.
+
+proc dom::tcl::ParseElementStart {stateVar name attrList args} {
+
+    upvar #0 $stateVar state
+    array set opts $args
+
+    # Push namespace declarations
+    # We need to be able to map namespaceURI's back to prefixes
+    set nsattrlists {}
+    catch {
+	foreach {namespaceURI prefix} $opts(-namespacedecls) {
+	    lappend state(NS:$namespaceURI) $prefix
+
+	    # Also, synthesize namespace declaration attributes
+	    # TclXML is a little too clever when it parses them away!
+
+	    lappend nsattrlists $prefix $namespaceURI
+	}
+	lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists
+
+    }
+
+    set nsarg {}
+    catch {
+	lappend nsarg -namespace $opts(-namespace)
+	lappend nsarg -localname $name
+	lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end]
+    }
+
+    lappend state(current) \
+	[eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]]
+
+    if {[info exists opts(-empty)] && $opts(-empty)} {
+	# Flag this node as being an empty element
+	upvar #0 [lindex $state(current) end] node
+	set node(element:empty) 1
+    }
+
+    # Temporary: implement -progresscommand here, because of broken parser
+    if {[string length $state(-progresscommand)]} {
+	if {!([incr state(progCounter)] % $state(-chunksize))} {
+	    uplevel #0 $state(-progresscommand)
+	}
+    }
+}
+
+# dom::tcl::ParseElementEnd --
+#
+#	Pop an element from the stack.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	name		element name
+#	args		configuration options
+#
+# Results:
+#	Currently open element is closed.
+
+proc dom::tcl::ParseElementEnd {stateVar name args} {
+    upvar #0 $stateVar state
+
+    set state(current) [lreplace $state(current) end end]
+}
+
+# dom::tcl::ParseCharacterData --
+#
+#	Add a textNode to the currently open element.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	data		character data
+#
+# Results:
+#	A textNode is created.
+
+proc dom::tcl::ParseCharacterData {stateVar data} {
+    upvar #0 $stateVar state
+
+    CreateTextNode [lindex $state(current) end] $data
+}
+
+# dom::tcl::ParseProcessingInstruction --
+#
+#	Add a PI to the currently open element.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	name		PI name
+#	target		PI target
+#
+# Results:
+#	A processingInstruction node is created.
+
+proc dom::tcl::ParseProcessingInstruction {stateVar name target} {
+    upvar #0 $stateVar state
+
+    CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
+}
+
+# dom::tcl::ParseXMLDeclaration --
+#
+#	Add information from the XML Declaration to the document.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	version		version identifier
+#	encoding	character encoding
+#	standalone	standalone document declaration
+#
+# Results:
+#	Document node modified.
+
+proc dom::tcl::ParseXMLDeclaration {stateVar version encoding standalone} {
+    upvar #0 $stateVar state
+
+    upvar #0 $state(docNode) document
+    array set xmldecl $document(document:xmldecl)
+
+    array set xmldecl [list version $version	\
+	    standalone $standalone		\
+	    encoding $encoding			\
+    ]
+
+    set document(document:xmldecl) [array get xmldecl]
+
+    return {}
+}
+
+# dom::tcl::ParseDocType --
+#
+#	Add a Document Type Declaration node to the document.
+#
+# Arguments:
+#	stateVar	global state array variable
+#	root		root element type
+#	publit		public identifier literal
+#	systemlist	system identifier literal
+#	dtd		internal DTD subset
+#
+# Results:
+#	DocType node added
+
+proc dom::tcl::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}} args} {
+    upvar #0 $stateVar state
+    upvar #0 $state(docNode) document
+
+    set document(document:doctype) [CreateDocType $state(docNode) $publit $systemlit $dtd]
+
+    return {}
+}
+
+# dom::tcl::ParseComment --
+#
+#	Parse comment
+#
+# Arguments:
+#	stateVar	state array
+#	data		comment data
+#
+# Results:
+#	Comment node added to DOM tree
+
+proc dom::tcl::ParseComment {stateVar data} {
+    upvar #0 $stateVar state
+
+    CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data
+
+    return {}
+}
+
+# dom::tcl::ParseEntityReference --
+#
+#	Parse an entity reference
+#
+# Arguments:
+#	stateVar	state variable
+#	ref		entity
+#
+# Results:
+#	Entity reference node added to DOM tree
+
+proc dom::tcl::ParseEntityReference {stateVar ref} {
+    upvar #0 $stateVar state
+
+    CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref
+
+    return {}
+}
+
+#################################################
+#
+# Trim white space
+#
+#################################################
+
+# dom::tcl::Trim --
+#
+#	Remove textNodes that only contain white space
+#
+# Arguments:
+#	nodeid	node to trim
+#
+# Results:
+#	textNode nodes may be removed (from descendants)
+
+proc dom::tcl::Trim nodeid {
+    upvar #0 $nodeid node
+
+    switch $node(node:nodeType) {
+
+	textNode {
+	    if {![string length [string trim $node(node:nodeValue)]]} {
+		node removeChild $node(node:parentNode) $nodeid
+	    }
+	}
+
+	default {
+	    # Some nodes have no child list.  Reported by Jim Hollister <jhollister@objectspace.com>
+	    set children {}
+	    catch {set children [set $node(node:childNodes)]}
+	    foreach child $children {
+		Trim $child
+	    }
+	}
+
+    }
+
+    return {}
+}
+
+#################################################
+#
+# XPath support
+#
+#################################################
+
+# dom::tcl::XPath:CreateNode --
+#
+#	Given an XPath expression, create the node
+#	referred to by the expression.  Nodes required
+#	as steps of the path are created if they do
+#	not exist.
+#
+# Arguments:
+#	node	context node
+#	path	location path
+#
+# Results:
+#	Node(s) created in the DOM tree.
+#	Returns token for deepest node in the expression.
+
+proc dom::tcl::XPath:CreateNode {node path} {
+
+    set root [::dom::node cget $node -ownerDocument]
+
+    set spath [::xpath::split $path]
+
+    if {[llength $spath] <= 1} {
+	# / - do nothing
+	return $root
+    }
+
+    if {![llength [lindex $spath 0]]} {
+	# Absolute location path
+	set context $root
+	set spath [lrange $spath 1 end]
+	set contexttype document
+    } else {
+	set context $node
+	set contexttype [::dom::node cget $node -nodeType]
+    }
+
+    foreach step $spath {
+
+	# Sanity check on path
+	switch $contexttype {
+	    document -
+	    documentFragment -
+	    element {}
+	    default {
+		return -code error "node type \"$contexttype\" have no children"
+	    }
+	}
+
+	switch [lindex $step 0] {
+
+	    child {
+		if {[llength [lindex $step 1]] > 1} {
+		    foreach {nodetype discard} [lindex $step 1] break
+
+		    switch -- $nodetype {
+			text {
+			    set posn [CreateNode:FindPosition [lindex $step 2]]
+
+			    set count 0
+			    set targetNode {}
+			    foreach child [::dom::node children $context] {
+				switch [::dom::node cget $child -nodeType] {
+				    textNode {
+					incr count
+					if {$count == $posn} {
+					    set targetNode $child
+					    break
+					}
+				    }
+				    default {}
+				}
+			    }
+
+			    if {[string length $targetNode]} {
+				set context $targetNode
+			    } else {
+				# Creating sequential textNodes doesn't make sense
+				set context [::dom::document createTextNode $context {}]
+			    }
+			    set contexttype textNode
+			}
+			default {
+			    return -code error "node type test \"${nodetype}()\" not supported"
+			}
+		    }
+		} else {
+		    # Find the child element
+		    set posn [CreateNode:FindPosition [lindex $step 2]]
+
+		    set count 0
+		    set targetNode {}
+		    foreach child [::dom::node children $context] {
+			switch [node cget $child -nodeType] {
+			    element {
+				if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} {
+				    incr count
+				    if {$count == $posn} {
+					set targetNode $child
+					break
+				    }
+				}
+			    }
+			    default {}
+			}
+		    }
+
+		    if {[string length $targetNode]} {
+			set context $targetNode
+		    } else {
+			# Didn't find it so create required elements
+			while {$count < $posn} {
+			    set child [::dom::document createElement $context [lindex $step 1]]
+			    incr count
+			}
+			set context $child
+		    }
+		    set contexttype element
+
+		}
+	    }
+
+	    default {
+		return -code error "axis \"[lindex $step 0]\" is not supported"
+	    }
+	}
+    }
+
+    return $context
+}
+
+# dom::tcl::CreateNode:FindPosition --
+
+proc dom::tcl::CreateNode:FindPosition predicates {
+    switch [llength $predicates] {
+	0 {
+	    return 1
+	}
+	1 {
+	    # Fall-through
+	}
+	default {
+	    return -code error "multiple predicates not yet supported"
+	}
+    }
+    set predicate [lindex $predicates 0]
+
+    switch -- [lindex [lindex $predicate 0] 0] {
+	function {
+	    switch -- [lindex [lindex $predicate 0] 1] {
+		position {
+		    if {[lindex $predicate 1] == "="} {
+			if {[string compare [lindex [lindex $predicate 2] 0] "number"]} {
+			    return -code error "operand must be a number"
+			} else {
+			    set posn [lindex [lindex $predicate 2] 1]
+			}
+		    } else {
+			return -code error "operator must be \"=\""
+		    }
+		}
+		default {
+		    return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported"
+		}
+	    }
+	}
+	default {
+	    return -code error "predicate must be position() function"
+	}
+    }
+
+    return $posn
+}
+
+# dom::tcl::XPath:SelectNode --
+#
+#	Match nodes with an XPath location path
+#
+# Arguments:
+#	ctxt	context - Tcl list
+#	path	location path
+#
+# Results:
+#	Returns Tcl list of matching nodes
+
+proc dom::tcl::XPath:SelectNode {ctxt path} {
+
+    if {![llength $ctxt]} {
+	return {}
+    }
+
+    set spath [xpath::split $path]
+
+    if {[string length [node parent [lindex $ctxt 0]]]} {
+	set root [namespace qualifiers [lindex $ctxt 0]]::Document
+    } else {
+	set root [lindex $ctxt 0]
+    }
+
+    if {[llength $spath] == 0} {
+	return $root
+    }
+    if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} {
+	return $root
+    }
+
+    if {![llength [lindex $spath 0]]} {
+	set ctxt $root
+	set spath [lrange $spath 1 end]
+    }
+
+    return [XPath:SelectNode:Rel $ctxt $spath]
+}
+
+# dom::tcl::XPath:SelectNode:Rel --
+#
+#	Match nodes with an XPath location path
+#
+# Arguments:
+#	ctxt	context - Tcl list
+#	path	split location path
+#
+# Results:
+#	Returns Tcl list of matching nodes
+
+proc dom::tcl::XPath:SelectNode:Rel {ctxt spath} {
+    if {![llength $spath]} {
+	return $ctxt
+    }
+
+    set step [lindex $spath 0]
+    set result {}
+    switch [lindex $step 0] {
+
+	child {
+	    # All children are candidates
+	    set children {}
+	    foreach node [XPath:SN:GetElementTypeNodes $ctxt] {
+		eval lappend children [node children $node]
+	    }
+
+	    # Now apply node test to each child
+	    foreach node $children {
+		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
+		    lappend result $node
+		}
+	    }
+
+	}
+
+	descendant-or-self {
+	    foreach node $ctxt {
+		if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
+		    lappend result $node
+		}
+		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
+	    }
+	}
+
+	descendant {
+	    foreach node $ctxt {
+		eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
+	    }
+	}
+
+	attribute {
+	    if {[string compare [lindex $step 1] "*"]} {
+		foreach node $ctxt {
+		    set attrNode [element getAttributeNode $node [lindex $step 1]]
+		    if {[llength $attrNode]} {
+			lappend result $attrNode
+		    }
+		}
+	    } else {
+		# All attributes are returned
+		foreach node $ctxt {
+		    foreach attrName [array names [node cget $node -attributes]] {
+			set attrNode [element getAttributeNode $node $attrName]
+			if {[llength $attrNode]} {
+			    lappend result $attrNode
+			}
+		    }
+		}
+	    }
+	}
+
+	default {
+	    return -code error "axis \"[lindex $step 0]\" is not supported"
+	}
+    }
+
+    # Now apply predicates
+    set result [XPath:ApplyPredicates $result [lindex $step 2]]
+
+    # Apply the next location step
+    return [XPath:SelectNode:Rel $result [lrange $spath 1 end]]
+}
+
+# dom::tcl::XPath:SN:GetElementTypeNodes --
+#
+#	Reduce nodeset to those nodes of element type
+#
+# Arguments:
+#	nodeset	set of nodes
+#
+# Results:
+#	Returns nodeset in which all nodes are element type
+
+proc dom::tcl::XPath:SN:GetElementTypeNodes nodeset {
+    set result {}
+    foreach node $nodeset {
+	switch [node cget $node -nodeType] {
+	    document -
+	    documentFragment -
+	    element {
+		lappend result $node
+	    }
+	    default {}
+	}
+    }
+    return $result
+}
+
+# dom::tcl::XPath:SN:ApplyNodeTest --
+#
+#	Apply the node test to a node
+#
+# Arguments:
+#	node	DOM node to test
+#	test	node test
+#
+# Results:
+#	1 if node passes, 0 otherwise
+
+proc dom::tcl::XPath:SN:ApplyNodeTest {node test} {
+    if {[llength $test] > 1} {
+	foreach {name typetest} $test break
+	# Node type test
+	switch -glob -- $name,[node cget $node -nodeType] {
+	    node,* {
+		return 1
+	    }
+	    text,textNode -
+	    comment,comment -
+	    processing-instruction,processingInstruction {
+		return 1
+	    }
+	    text,* -
+	    comment,* -
+	    processing-instruction,* {
+		return 0
+	    }
+	    default {
+		return -code error "illegal node type test \"[lindex $step 1]\""
+	    }
+	}
+    } else {
+	# Node name test
+	switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] \
+		\\*,element,* {
+	    return 1
+	} \
+		\\*,* {
+	    return 0
+	} \
+		*,element,$test {
+	    return 1
+	}
+    }
+
+    return 0
+}
+
+# dom::tcl::XPath:SN:DescendAndTest --
+#
+#	Descend the element hierarchy,
+#	apply the node test as we go
+#
+# Arguments:
+#	nodeset	nodes to be tested and descended
+#	test	node test
+#
+# Results:
+#	Returned nodeset of nodes which pass the test
+
+proc dom::tcl::XPath:SN:DescendAndTest {nodeset test} {
+    set result {}
+
+    foreach node $nodeset {
+	if {[XPath:SN:ApplyNodeTest $node $test]} {
+	    lappend result $node
+	}
+	switch [node cget $node -nodeType] {
+	    document -
+	    documentFragment -
+	    element {
+		eval lappend result [XPath:SN:DescendAndTest [node children $node] $test]
+	    }
+	}
+    }
+
+    return $result
+}
+
+# dom::tcl::XPath:ApplyPredicates --
+#
+#	Filter a nodeset with predicates
+#
+# Arguments:
+#	ctxt	current context nodeset
+#	preds	list of predicates
+#
+# Results:
+#	Returns new (possibly reduced) context nodeset
+
+proc dom::tcl::XPath:ApplyPredicates {ctxt preds} {
+
+    set result {}
+    foreach node $ctxt {
+	set passed 1
+	foreach predicate $preds {
+	    if {![XPath:ApplyPredicate $node $predicate]} {
+		set passed 0
+		break
+	    }
+	}
+	if {$passed} {
+	    lappend result $node
+	}
+    }
+
+    return $result
+}
+
+# dom::tcl::XPath:ApplyPredicate --
+#
+#	Filter a node with a single predicate
+#
+# Arguments:
+#	node	current context node
+#	pred	predicate
+#
+# Results:
+#	Returns boolean
+
+proc dom::tcl::XPath:ApplyPredicate {node pred} {
+
+    switch -- [lindex $pred 0] {
+	= -
+	!= -
+	>= -
+	<= -
+	> -
+	> {
+
+	    if {[llength $pred] != 3} {
+		return -code error "malformed expression"
+	    }
+
+	    set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]]
+	    set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]]
+
+	    # Convert operands to the correct type, if necessary
+	    switch -glob [lindex $operand1 0],[lindex $operand2 0] {
+		literal,literal {
+		    return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
+		}
+
+		number,number -
+		literal,number -
+		number,literal {
+		    # Compare as numbers
+		    return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
+		}
+
+		boolean,boolean {
+		    # Compare as booleans
+		    return -code error "boolean comparison not yet implemented"
+		}
+
+		node,node {
+		    # Nodeset comparison
+		    return -code error "nodeset comparison not yet implemented"
+		}
+
+		node,* {
+		    set value {}
+		    if {[llength [lindex $operand1 1]]} {
+			set value [node stringValue [lindex [lindex $operand1 1] 0]]
+		    }
+		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]]
+		}
+		*,node {
+		    set value {}
+		    if {[llength [lindex $operand2 1]]} {
+			set value [node stringValue [lindex [lindex $operand2 1] 0]]
+		    }
+		    return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]]
+		}
+
+		default {
+		    return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]"
+		}
+	    }
+	}
+
+	function {
+	    return -code error "invalid predicate"
+	}
+	number -
+	literal {
+	    return -code error "invalid predicate"
+	}
+
+	path {
+	    set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]]
+	    return [expr {[llength $nodeset] > 0 ? 1 : 0}]
+	}
+
+    }
+
+    return 1
+}
+
+# dom::tcl::XPath:Pred:Compare --
+
+proc dom::tcl::XPath:Pred:CompareLiterals {op operand1 operand2} {
+    set result [string compare $operand1 $operand2]
+
+    # The obvious:
+    #return [expr {$result $opMap($op) 0}]
+    # doesn't compile
+    
+    switch $op {
+	= {
+	    return [expr {$result == 0}]
+	}
+	!= {
+	    return [expr {$result != 0}]
+	}
+	<= {
+	    return [expr {$result <= 0}]
+	}
+	>= {
+	    return [expr {$result >= 0}]
+	}
+	< {
+	    return [expr {$result < 0}]
+	}
+	> {
+	    return [expr {$result > 0}]
+	}
+    }
+    return -code error "internal error"
+}
+
+# dom::tcl::XPath:Pred:ResolveExpr --
+
+proc dom::tcl::XPath:Pred:ResolveExpr {node expr} {
+
+    switch [lindex $expr 0] {
+	path {
+	    return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]]
+	}
+
+	function -
+	group {
+	    return -code error "[lindex $expr 0] not yet implemented"
+	}
+	literal -
+	number -
+	boolean {
+	    return $expr
+	}
+
+	default {
+	    return -code error "internal error"
+	}
+    }
+
+    return {}
+}
+
+#################################################
+#
+# Miscellaneous
+#
+#################################################
+
+# dom::tcl::hasmixedcontent --
+#
+#	Determine whether an element contains mixed content
+#
+# Arguments:
+#	token	dom node
+#
+# Results:
+#	Returns 1 if element contains mixed content,
+#	0 otherwise
+
+proc dom::tcl::hasmixedcontent token {
+    upvar #0 $token node
+
+    if {[string compare $node(node:nodeType) "element"]} {
+	# Really undefined
+	return 0
+    }
+
+    foreach child [set $node(node:childNodes)] {
+	upvar #0 $child childnode
+	if {![string compare $childnode(node:nodeType) "textNode"]} {
+	    return 1
+	}
+    }
+
+    return 0
+}
+
+# dom::tcl::prefix2namespaceURI --
+#
+#	Given an XML Namespace prefix, find the corresponding Namespace URI
+#
+# Arguments:
+#	node	DOM Node
+#	prefix	XML Namespace prefix
+#
+# Results:
+#	Returns URI
+
+proc dom::tcl::prefix2namespaceURI {node prefix} {
+
+    # Search this node and its ancestors for the appropriate
+    # XML Namespace declaration
+
+    set parent [dom::node parent $node]
+    set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix]
+    if {[string length $parent] && ![string length $nsuri]} {
+	set nsuri [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix]
+	set parent [dom::node parent $parent]
+    }
+
+    if {[string length $nsuri]} {
+	return $nsuri
+    } else {
+	return -code error "unable to find namespace URI for prefix \"$prefix\""
+    }
+
+}
+
+# dom::tcl::namespaceURI2prefix --
+#
+#	Given an XML Namespace URI, find the corresponding prefix
+#
+# Arguments:
+#	node	DOM Node
+#	nsuri	XML Namespace URI
+#
+# Results:
+#	Returns prefix
+
+proc dom::tcl::namespaceURI2prefix {node nsuri} {
+
+    # Search this node and its ancestors for the desired
+    # XML Namespace declaration
+
+    set found 0
+    set prefix {}
+    set parent [dom::node parent $node]
+    while {[string length $parent]} {
+	upvar #0 $node nodeinfo
+	catch {unset attrs}
+	array set attrs [array get $nodeinfo(element:attributeList)]
+	foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] {
+	    if {![string compare $declNSuri $nsuri]} {
+		set found 1
+		set prefix [lindex [split $nsdecl ^] 1]
+		break
+	    }
+	}
+	if {$found} {
+	    break
+	}
+	set node $parent
+	set parent [dom::node parent $node]
+    }
+
+    if {$found} {
+	return $prefix
+    } else {
+	return -code error "unable to find prefix for namespace URI \"$nsuri\""
+    }
+
+}
+
+# dom::tcl::GetField --
+#
+#	Return a value, or empty string if not defined
+#
+# Arguments:
+#	var	name of variable to return
+#
+# Results:
+#	Returns the value, or empty string if variable is not defined.
+
+proc dom::tcl::GetField var {
+    upvar $var v
+    if {[info exists v]} {
+	return $v
+    } else {
+	return {}
+    }
+}
+
+# dom::tcl::Min --
+#
+#	Return the minimum of two numeric values
+#
+# Arguments:
+#	a	a value
+#	b	another value
+#
+# Results:
+#	Returns the value which is lower than the other.
+
+proc dom::tcl::Min {a b} {
+    return [expr {$a < $b ? $a : $b}]
+}
+
+# dom::tcl::Max --
+#
+#	Return the maximum of two numeric values
+#
+# Arguments:
+#	a	a value
+#	b	another value
+#
+# Results:
+#	Returns the value which is greater than the other.
+
+proc dom::tcl::Max {a b} {
+    return [expr {$a > $b ? $a : $b}]
+}
+
+# dom::tcl::Boolean --
+#
+#	Return a boolean value
+#
+# Arguments:
+#	b	value
+#
+# Results:
+#	Returns 0 or 1
+
+proc dom::tcl::Boolean b {
+    regsub -nocase {^(true|yes|1|on)$} $b 1 b
+    regsub -nocase {^(false|no|0|off)$} $b 0 b
+    return $b
+}
+
diff --git a/tclxml/tcldom-tcl/dommap.tcl b/tclxml/tcldom-tcl/dommap.tcl
new file mode 100644
index 0000000..9d9ec87
--- /dev/null
+++ b/tclxml/tcldom-tcl/dommap.tcl
@@ -0,0 +1,108 @@
+# dommap.tcl --
+#
+#	Apply a mapping function to a DOM structure
+#
+# Copyright (c) 1998-2003 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: dommap.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package provide dommap 1.0
+
+# We need the DOM
+package require dom 2.6
+
+namespace eval dommap {
+    namespace export map
+}
+
+# dommap::apply --
+#
+#	Apply a function to a DOM document.
+#
+#	The callback command is invoked with the node ID of the
+#	matching DOM node as its argument.  The command may return
+#	an error, continue or break code to alter the processing
+#	of further nodes.
+#
+#	Filter functions may be applied to match particular
+#	nodes.  Valid functions include:
+#
+#	-nodeType regexp
+#	-nodeName regexp
+#	-nodeValue regexp
+#	-attribute {regexp regexp}
+#
+#	If a filter is specified then the node must match for the
+#	callback command to be invoked.  If a filter is not specified
+#	then all nodes match that filter.
+#
+# Arguments:
+#	node	DOM document node
+#	cmd	callback command
+#	args	configuration options
+#
+# Results:
+#	Depends on callback command
+
+proc dommap::apply {node cmd args} {
+    array set opts $args
+
+    # Does this node match?
+    set match 1
+    catch {set match [expr $match && [regexp $opts(-nodeType) [::dom::node cget $node -nodeType]]]}
+    catch {set match [expr $match && [regexp $opts(-nodeName) [::dom::node cget $node -nodeName]]]}
+    catch {set match [expr $match && [regexp $opts(-nodeValue) [::dom::node cget $node -nodeValue]]]}
+    if {$match && ![string compare [::dom::node cget $node -nodeType] element]} {
+	set match 0
+	foreach {attrName attrValue} [array get [::dom::node cget $node -attributes]] {
+	    set match 1
+	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 0] $attrName]]}
+	    catch {set match [expr $match && [regexp [lindex $opts(-attribute) 1] $attrValue]]}
+	    if {$match} break
+	}
+    }
+    if {$match && [set code [catch {eval $cmd [list $node]} msg]]} {
+	switch $code {
+	    0 {}
+	    3 {
+		return -code break
+	    }
+	    4 {
+		return -code continue
+	    }
+	    default {
+		return -code error $msg
+	    }
+	}
+    }
+
+    # Process children
+    foreach child [::dom::node children $node] {
+	switch [catch {eval apply [list $child] [list $cmd] $args} msg] {
+	    0 {
+		# No action required
+	    }
+	    3 {
+		# break
+		return -code break
+	    }
+	    4 {
+		# continue - skip processing of siblings
+		return
+	    }
+	    1 -
+	    2 -
+	    default {
+		# propagate the error message
+		return -code error $msg
+	    }
+	}
+    }
+
+    return {}
+}
+
diff --git a/tclxml/tcldom-tcl/xmlswitch.tcl b/tclxml/tcldom-tcl/xmlswitch.tcl
new file mode 100644
index 0000000..4e2a2a1
--- /dev/null
+++ b/tclxml/tcldom-tcl/xmlswitch.tcl
@@ -0,0 +1,520 @@
+# xmlswitch.tcl --
+#
+#	This file implements a control structure for Tcl.
+#	'xmlswitch' iterates over an XML document.  Features in
+#	the document may be specified using XPath location paths,
+#	and these will trigger Tcl scripts when matched.
+#
+# Copyright (c) 2008 Explain
+# http://www.explain.com.au/
+# Copyright (c) 2000-2003 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: xmlswitch.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package provide xmlswitch 3.2
+
+# We need the xml, dom and xpath packages
+
+package require xml 3.2
+package require dom 3.2
+package require xpath 1.0
+
+namespace eval xmlswitch {
+    namespace export xmlswitch xmlswitchcont xmlswitchend
+    namespace export domswitch
+    namespace export free rootnode
+
+    variable counter 0
+
+    variable typemap
+    array set typemap {
+	text textNode
+	comment comment
+	processing-instruction processingInstruction
+    }
+}
+
+# xmlswitch::xmlswitch --
+#
+#	Parse XML data, matching for XPath locations along the way
+#	and (possibly) triggering callbacks.
+#
+#	A DOM tree is built as a side-effect (necessary for resolving
+#	XPath location paths).
+#
+# Arguments:
+#	xml	XML document
+#	args	configuration options,
+#		plus a single path/script expression, or multiple expressions
+#
+# Results:
+#	Tcl callbacks may be invoked.
+#	If -async option is true returns a token for this "process".
+
+proc xmlswitch::xmlswitch {xml args} {
+    variable counter
+
+    set stateVarName [namespace current]::State[incr counter]
+    upvar #0 $stateVarName state
+    set state(stateVarName) $stateVarName
+    set state(-async) 0
+
+    set state(pathArray) ${stateVarName}Paths
+    upvar #0 $state(pathArray) paths
+    array set paths {}
+
+    set cleanup {
+	unset state
+	unset paths
+    }
+
+    # Find configuration options and remove
+    set numOpts 0
+    foreach {opt value} $args {
+	switch -glob -- $opt {
+	    -* {
+		set state($opt) $value
+		incr numOpts 2
+	    }
+	    default {
+		set args [lrange $args $numOpts end]
+		break
+	    }
+	}
+    }
+
+    switch -- [llength $args] {
+	0 {
+	    # Nothing to do
+	    eval $cleanup
+	    return $stateVarName
+	}
+	1 {
+	    foreach {path script} [lindex $args 0] {
+		set paths([xpath::split $path]) $script
+	    }
+	}
+	default {
+	    if {[llength $args] % 2} {
+		eval $cleanup
+		return -code error "no script matching location path \"[lindex $args end]\""
+	    }
+	    foreach {path script} $args {
+		set paths([xpath::split $path]) $script
+	    }
+	}
+    }
+
+    set root [set state(root) [dom::DOMImplementation create]]
+    set state(current) $root
+
+    # Parse the document
+    # We're going to do this incrementally, so the caller can
+    # break at any time
+    set state(parser) [eval xml::parser [array get state -parser]]
+    #append cleanup "\n $parser destroy\n"
+    $state(parser) configure \
+	    -elementstartcommand [namespace code [list ParseElementStart $stateVarName]]	\
+	    -elementendcommand [namespace code [list ParseElementEnd $stateVarName]]		\
+	    -characterdatacommand [namespace code [list ParseCharacterData $stateVarName]]	\
+	    -final 0
+
+#	    -processinginstructioncommand [namespace code [list ParsePI $stateVarName]]		\
+#	    -commentcommand [namespace code [list ParseComment]]
+
+    if {[catch {$state(parser) parse $xml} err]} {
+	eval $cleanup
+	return -code error $err
+    }
+
+    if {$state(-async)} {
+	return $stateVarName
+    } else {
+	eval $cleanup
+	return {}
+    }
+}
+
+# xmlswitch::xmlswitchcont --
+#
+#	Provide more XML data to parse
+#
+# Arguments:
+#	token	state variable name
+#	xml	XML data
+#
+# Results:
+#	More parsing
+
+proc xmlswitch::xmlswitchcont {token xml} {
+    upvar #0 $token state
+
+    $state(parser) parse $xml
+
+    return {}
+}
+
+# xmlswitch::xmlswitchend --
+#
+#	Signal that no further data is available
+#
+# Arguments:
+#	token	state array
+#
+# Results:
+#	Parser configuration changed
+
+proc xmlswitch::xmlswitchend token {
+    upvar #0 $token state
+
+    $state(parser) configure -final true
+
+    return {}
+}
+
+# xmlswitch::rootnode --
+#
+#	Get the root node
+#
+# Arguments:
+#	token	state array
+#
+# Results:
+#	Returns root node token
+
+proc xmlswitch::rootnode token {
+    upvar #0 $token state
+
+    return $state(root)
+}
+
+# xmlswitch::free --
+#
+#	Free resources EXCEPT the DOM tree.
+#	"-all" causes DOM tree to be destroyed too.
+#
+# Arguments:
+#	token	state array
+#	args	options
+#
+# Results:
+#	Resources freed.
+
+proc xmlswitch::free {token args} {
+    upvar #0 $token state
+
+    if {[lsearch $args "-all"] >= 0} {
+	dom::DOMImplementation destroy $state(root)
+    }
+
+    catch {unset $state(pathArray)}
+    catch {unset state}
+
+    catch {$state(parser) free}
+
+    return {}
+}
+
+# xmlswitch::ParseElementStart --
+#
+#	Handle element start tag
+#
+# Arguments:
+#	token	state array
+#	name	element type
+#	attrList attribute list
+#	args	options
+# Results:
+#	All XPath location paths are checked for a match,
+#	and script evaluated for matching XPath.
+#	DOM tree node added.
+
+proc xmlswitch::ParseElementStart:dbgdisabled {token name attrList args} {
+    if {[catch {eval ParseElementStart:dbg [list $token $name $attrList] $args} msg]} {
+	puts stderr [list ParseElementStart failed with msg $msg]
+	puts stderr $::errorInfo
+	return -code error $msg
+    } else {
+	puts stderr [list ParseElementStart returned OK]
+    }
+    return $msg
+}
+proc xmlswitch::ParseElementStart {token name attrList args} {
+
+    upvar #0 $token state
+    array set opts $args
+
+    #puts stderr [list xmlswitch::ParseElementStart $token $name $attrList $args]
+
+    lappend state(current) \
+	    [dom::document createElement [lindex $state(current) end] $name]
+    foreach {name value} $attrList {
+	dom::element setAttribute [lindex $state(current) end] $name $value
+    }
+
+    MatchTemplates $token [lindex $state(current) end]
+
+    return {}
+}
+
+# xmlswitch::ParseElementEnd --
+#
+#	Handle element end tag
+#
+# Arguments:
+#	token	state array
+#	name	element type
+#	args	options
+# Results:
+#	State changed
+
+proc xmlswitch::ParseElementEnd {token name args} {
+    upvar #0 $token state
+
+    set state(current) [lreplace $state(current) end end]
+
+    return {}
+}
+
+# xmlswitch::ParseCharacterData --
+#
+#	Handle character data
+#
+# Arguments:
+#	token	state array
+#	data	pcdata
+#
+# Results:
+#	All XPath location paths are checked for a match,
+#	and script evaluated for matching XPath.
+#	DOM tree node added.
+
+proc xmlswitch::ParseCharacterData {token data} {
+    upvar #0 $token state
+
+    lappend state(current) \
+	    [dom::document createTextNode [lindex $state(current) end] $data]
+
+    MatchTemplates $token [lindex $state(current) end]
+
+    set state(current) [lreplace $state(current) end end]
+
+    return {}
+}
+
+# xmlswitch::domswitch --
+#
+#	Similar to xmlswitch above, but iterates over a pre-built
+#	DOM tree.
+#
+# Arguments:
+#	xml	XML document
+#	args	a single path/script expression, or multiple expressions
+#
+# Results:
+#	Tcl callbacks may be invoked.
+
+proc xmlswitch::domswitch {xml args} {
+}
+
+# xmlswitch::MatchTemplates --
+#
+#	Check all templates for one which matches
+#	the current node.
+#
+# Arguments:
+#	token	state array
+#	node	Current DOM node
+#
+# Results:
+#	If a template matches, its script is evaluated
+
+proc xmlswitch::MatchTemplates {token node} {
+    upvar #0 $token state
+    upvar #0 $state(pathArray) paths
+
+    #puts stderr [list xmlswitch::MatchTemplates $token $node (type: [dom::node cget $node -nodeType]) (name: [dom::node cget $node -nodeName])]
+
+    set matches {}
+
+    foreach {path script} [array get paths] {
+
+	#puts stderr [list checking path $path for a match]
+
+	set context $node
+
+	# Work backwards along the path, reversing each axis
+	set match 0
+	set i [llength $path]
+	#puts stderr [list $i steps to be tested]
+	while {[incr i -1] >= 0} {
+	    #puts stderr [list step $i [lindex $path $i]]
+	    switch -glob [llength [lindex $path $i]],$i {
+		0,0 {
+		    #puts stderr [list absolute path, end of steps - am I at the root?]
+		    if {![string length [dom::node parent $context]]} {
+			#puts stderr [list absolute path matched]
+			lappend matches [list $path $script]
+		    } else {
+			#puts stderr [list absolute path did not match]
+		    }
+		}
+		*,0 {
+		    #puts stderr [list last step, relative path]
+		    switch [lindex [lindex $path $i] 0] {
+			child {
+			    if {[NodeTest [lindex $path $i] $context] && \
+				    [CheckPredicates [lindex $path $i] $context]} {
+				#puts stderr [list relative path matched]
+				lappend matches [list $path $script]
+			    } else {
+				#puts stderr [list relative path did not match]
+			    }
+			}
+			default {
+			    return -code error "axis \"[lindex [lindex $path $i] 0]\" not supported"
+			}
+		    }
+		}
+		default {
+		    #puts stderr [list continuing checking steps]
+		    switch [lindex [lindex $path $i] 0] {
+			child {
+			    if {[NodeTest [lindex $path $i] $context] && \
+				    [CheckPredicates [lindex $path $i] $context]} {
+				set context [dom::node parent $context]
+			    } else {
+				#puts stderr [list no match]
+			    }
+			}
+			default {
+			    return -code error "axis \"[lindex [lindex $path $i] 0]\" not supported"
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+    # TODO: If there are multiple matches then we must pick the
+    # most specific match
+
+    if {[llength $matches] > 1} {
+	# For the moment we'll just take the first match
+	set matches [list [lindex $matches 0]]
+    }
+
+    if {[llength $matches]} {
+	#puts stderr [list evaluating callback at level [info level]]
+	uplevel 3 [lindex [lindex $matches 0] 1]
+    }
+
+    return {}
+}
+
+# xmlswitch::NodeTest --
+#
+#	Check that the node passes the node (type) test
+#
+# Arguments:
+#	step	Location step
+#	node	DOM node
+#
+# Results:
+#	Boolean
+
+proc xmlswitch::NodeTest {step node} {
+
+    if {[llength [lindex $step 1]] > 1} {
+	switch -glob -- [lindex [lindex $step 1] 0],[dom::node cget $node -nodeType] {
+	    node,* -
+	    text,textNode -
+	    comment,comment -
+	    processing-instruction,processingInstruction {
+		return 1
+	    }
+	    default {
+		return 0
+	    }
+	}
+    } elseif {![string compare [lindex $step 1] "*"]} {
+	return 1
+    } elseif {![string compare [lindex $step 1] [dom::node cget $node -nodeName]]} {
+	return 1
+    } else {
+	return 0
+    }
+}
+
+# xmlswitch::CheckPredicates --
+#
+#	Check that the node passes the predicates
+#
+# Arguments:
+#	step	Location step
+#	node	DOM node
+#
+# Results:
+#	Boolean
+
+proc xmlswitch::CheckPredicates {step node} {
+    variable typemap
+
+    set predicates [lindex $step 2]
+    # Shortcut: no predicates means everything passes
+    if {![llength $predicates]} {
+	return 1
+    }
+
+    # Get the context node set
+    switch [lindex $step 0] {
+	child {
+	    set nodeset {}
+	    if {[llength [lindex $step 1]]} {
+		foreach {name typetest} [lindex $step 1] break
+		switch -- $name {
+		    node {
+			set nodeset [dom::node children [dom::node parent $node]]
+		    }
+		    text -
+		    comment -
+		    processing-instruction {
+			foreach child [dom::node children [dom::node parent $node]] {
+			    if {![string compare [dom::node cget $child -nodeType] $typemap($name)]} {
+				lappend nodeset $child
+			    }
+			}
+		    }
+		    default {
+			# Error
+		    }
+		}
+	    } else {
+		foreach child [dom::node children [dom::node parent $node]] {
+		    if {![string compare [lindex $step 1] [dom::node cget $child -nodeName]]} {
+			lappend nodeset $child
+		    }
+		}
+	    }
+	}
+	default {
+	    return -code error "axis \"[lindex $step 0]\" not supported"
+	}
+    }
+
+    foreach predicate $predicates {
+	# position() is the only supported predicate
+	if {[lsearch $nodeset $node] + 1 == $predicate} {
+	    # continue
+	} else {
+	    return 0
+	}
+    }
+
+    return 1
+}
+