# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package dom::tcl 2.6
# Meta as::build::date 2015-03-13
# Meta author          Steve Ball
# Meta category        XML
# Meta description     This package implements a generic DOM API
# Meta license         BSD
# Meta platform        tcl
# Meta require         {Tcl 8.4}
# Meta require         xml
# Meta require         xpath
# Meta subject         DOM processing {text processing} XML XSLT
# Meta summary         DOM API
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.4
package require xml
package require xpath

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide dom::tcl 2.6

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# 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-2003 Zveno Pty Ltd
# http://www.zveno.com/
#
# Zveno makes this software available free of charge for any purpose.
# Copies may be made of this software but all of this notice must be included
# on any copy.
#
# The software was developed for research purposes only and Zveno does not
# warrant that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying this software.
#
# $Id: domimpl.tcl,v 1.18 2003/03/09 11:12:49 balls Exp $

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

package require xml 2.6

# NB. DOM generic layer should be loaded before sourceing this script.
if {[catch {package require dom::generic 2.6}]} {
    package require dom::tclgeneric 2.6
}

package provide dom::tcl 2.6

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

}

# Define generic constants here, since this package
# is always loaded.

namespace eval dom {
    # 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
    }
}

# Data structure
#
# Documents are stored in an array within the dom namespace.
# Each element of the array is indexed by a unique identifier.
# Each element of the array is a key-value list with at least
# the following fields:
#	id docArray
#	node:parentNode node:childNodes node:nodeType
# Nodes of a particular type may have additional fields defined.
# Note that these fields in many circumstances are configuration options
# for a node type.
#
# "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 array element reference for a node.

# 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 0
}

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

    switch -- $method {

	hasFeature {

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    # 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 # arguments: should be DOMImplementation nsURI name doctype"
	    }

	    set doc [DOMImplementation create]

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

	    if {[string length [lindex $args 2]]} {
		document configure -doctype [lindex $args 2]
	    }

	    return $doc
	}

	create {

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

	    switch [llength $args] {
		0 {
		    # Allocate unique document array name
	    	    set name [namespace current]::document[incr DOMImplementationCounter]
		}
		1 {
		    # Use array name provided.  Should check that it is safe.
		    set name [lindex $args 0]
		    catch {unset $name}
		}
		default {
		    return -code error "wrong number of arguments"
		}
	    }

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

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

	    # Initialise child node list
	    set ${varPrefix}1 {}

	    # Return the new toplevel node
	    return ${name}(node1)

	}

	createDocumentType {
	    # Introduced in DOM Level 2

	    # Patch from c.l.t., Richard Calmbach (rc@hnc.com )

	    if {[llength $args] != 5} {
		return -code error "wrong number of arguments, should be: DOMImplementation createDocumentType token name publicid systemid internaldtd"
	    }

	    return [CreateDocType [lindex $args 0] [lindex $args 1] [lrange $args 2 3] [lindex $args 4]]
	}

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

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    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 number of arguments"
	    }
	    array set node [set [lindex $args 0]]

	    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.

		    # Patch from Gerald Lester

		    ##
		    ## First release all the associated variables
		    ##
		    upvar #0 $node(docArray) docArray
		    for {set i 0} {$i <= $docArray(counter)} {incr i} {
			catch {unset $node(docArray)var$i}
			catch {unset $node(docArray)arr$i}
			catch {unset $node(docArray)search$i}
		    }
             
		    ##
		    ## Then release the main document array
		    ##
		    if {[catch {unset $node(docArray)}]} {
			return -code error "unable to destroy document"
		    }

		}

		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 [lindex $args 0]

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

		event {
		    unset [lindex $args 0]
		}

		default {
		    # 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 [lindex $args 0]

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

		}

	    }

	    return {}

	}

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

	    if {![info exists [lindex $args 0]]} {
		return 0
	    } elseif {[catch {array set node [set [lindex $args 0]]}]} {
		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 number of arguments"
	    }

	    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}
		puts stderr $::errorInfo
		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

	}

	query {
	    # Either: query token string
	    # or: query token ?-tagname string? ?-attrname string? ?-attrvalue string? ?-text string? ?-comment string? ?-pitarget string? ?-pidata string?

	    switch [llength $args] {
		0 -
		1 {
		    return -code error "wrong number of arguments"
		}

		2 {
		    # The query applies to the entire document
		    return [Query [lindex $args 0] -tagname [lindex $args 1] \
			-attrname [lindex $args 1] -attrvalue [lindex $args 1] \
			-text [lindex $args 1] -comment [lindex $args 1] \
			-pitarget [lindex $args 1] -pidata [lindex $args 1]]
		}

		default {
		    # Configuration options have been specified to constrain the search
		    if {[llength [lrange $args 1 end]] % 2} {
			return -code error "no value given for option \"[lindex $args end]\""
		    }
		    set startnode [lindex $args 0]
		    foreach {opt value} [lrange $args 1 end] {
			switch -- $opt {
			    -tagname - -attrname - -attrvalue - -text - 
			    -comment - -pitarget - -pidata {}
			    default {
				return -code error "unknown query option \"$opt\""
			    }
			}
		    }

		    return [eval Query [list $startnode] [lrange $args 1 end]]

		}

	    }

	}

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

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    package require xpath

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

	serialize {

	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    array set node [set [lindex $args 0]]
	    return [eval [list Serialize:$node(node:nodeType)] $args]

	}

	trim {

	    # Removes textNodes that only contain white space

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    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 --
#
#	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

    array set node [set $token]

    set result {}

    switch -- $method {
	cget {
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    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 "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)$} $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]} {
				    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 "unknown option \"$option\""
		    }
		}
	    }

	    set $token [array get node]

	}

	createElement {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    # 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 number of arguments"
	    }

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

	    set result [CreateTextNode $token [lindex $args 0]]
	}
	createComment {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
	}
	createCDATASection {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    set result [CreateTextNode $token [lindex $args 0]]
	    node configure $result -cdatasection 1
	}
	createProcessingInstruction {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    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 number of arguments"
	    }

	    # 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 number of arguments"
	    }
	    set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
	}

	createDocTypeDecl {
	    # This is not a standard DOM 1.0 method
	    # Deprecated - see DOMImplementation createDocumentType

	    if {[llength $args] < 1 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    foreach {name extid dtd entities notations} $args break
	    set result [CreateDocType $token $name $extid]
	    document configure $token -doctype $result
	    documenttype configure $result -internalsubset $dtd
	    documenttype configure $result -entities $entities
	    documenttype configure $result -notations $notations
	}

	importNode {
	    # Introduced in DOM Level 2

	    return -code error "not yet implemented"
	}

	createElementNS {
	    # Introduced in DOM Level 2

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments, 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 number of arguments"
	    }

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

	}

	getElementsByTagName {
	    if {[llength $args] < 1} {
		return -code error "wrong number of arguments"
	    }

	    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
#	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]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

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

    catch {lappend docArray($id) node:namespaceURI $opts(-namespace)}
    catch {lappend docArray($id) node:localName $opts(-localname)}
    catch {lappend docArray($id) node:prefix $opts(-prefix)}

    # Initialise associated variables
    set ${docArrayName}var$docArray(counter) {}
    array set ${docArrayName}arr$docArray(counter) $aList
    catch {
	foreach {ns nsAttrList} $opts(-namespaceattributelists) {
	    foreach {attrName attrValue} $nsAttrList {
		array set ${docArrayName}arr$docArray(counter) [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]} {

	if {![string compare $parent(node:nodeType) documentFragment]} {
	    if {$parent(id) == $parent(documentFragment:masterDoc)} {
		if {[info exists parent(document:documentElement)] && \
		    [string length $parent(document:documentElement)]} {
		    unset docArray($id)
		    return -code error "document element already exists"
		} else {

		    # Check against document type decl
		    if {[string length $parent(document:doctype)]} {
			array set doctypedecl [set $parent(document:doctype)]
			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
			CreateDocType $token $name {} {}
			# Resynchronise parent record
			array set parent [set $token]
		    }

		    set parent(document:documentElement) $child
		    set $token [array get parent]
		}
	    }
	}

	lappend $parent(node:childNodes) $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
#	text	initial text
#	args	additional configuration options
#
# Results:
#	New node created, parent optionally modified

proc dom::tcl::CreateTextNode {token text args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # 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

    set docArray($id) [list id $id docArray $docArrayName \
	    node:parentNode $token		\
	    node:childNodes {}			\
	    node:nodeType textNode		\
	    node:nodeValue $text		\
	    node:nodeName #text			\
	    node:cdatasection 0			\
    ]

    if {[string length $token]} {
	# Update parent record
	lappend $parent(node:childNodes) $child
	set $token [array get parent]
    }

    return $child
}

# dom::tcl::CreateGeneric --
#
#	This is a template used for type-specific factory procedures
#
# Arguments:
#	token	parent node
#	args	optional values
#
# Results:
#	New node created, parent modified

proc dom::tcl::CreateGeneric {token args} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
	array set tmp [array get opts]
	foreach opt [array names tmp -*] {
	    unset tmp($opt)
	}
	set args [array get tmp]
    }

    set id node[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance
    set docArray($id) [eval list [list id $id docArray $docArrayName	\
	    node:parentNode $token					\
	    node:childNodes ${docArrayName}var$docArray(counter)]	\
	    $args
    ]
    set ${docArrayName}var$docArray(counter) {}

    catch {unset opts}
    array set opts $args
    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
	    set $token [array get parent]
	}
    }

    return $child
}

### Specials

# dom::tcl::CreateDocType --
#
#	Create a Document Type Declaration node.
#
# Arguments:
#	token	node id for the document node
#	name	root element type
#	extid	external entity id
#	dtd	internal DTD subset
#
# Results:
#	Returns node id of the newly created node.

proc dom::tcl::CreateDocType {token name {extid {}} {dtd {}} {entities {}} {notations {}}} {
    array set doc [set $token]
    upvar #0 $doc(docArray) docArray

    set id node[incr docArray(counter)]
    set child $doc(docArray)($id)

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

    set docArray($id) [list \
	    id $id docArray $doc(docArray) \
	    node:parentNode $token \
	    node:childNodes {} \
	    node:nodeType docType \
	    node:nodeName {} \
	    node:nodeValue {} \
	    doctype:name $name \
	    doctype:entities {} \
	    doctype:notations {} \
	    doctype:externalid $extid \
	    doctype:internaldtd $dtd \
    ]
    # NB. externalid and internaldtd are not standard DOM 1.0 attributes

    # Update parent

    set doc(document:doctype) $child

    # BUG: The doc type is NOT a child of the document node.
    # This behaviour has been removed.
    ##Add this node to the parent's child list
    ## This must come before the document element,
    ## so this implementation may be buggy
    #lappend $doc(node:childNodes) $child

    set $token [array get doc]

    return $child
}

# 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

    if {[catch {array set node [set $token]}]} {
	return -code error "token not found"
    }

    set result {}

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

	    # Some read-only configuration options are computed
	    if {[llength $args] != 1} {
		return -code error "too many arguments"
	    }
	    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) {
			    documentFragment {
				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) {
			    documentFragment {
				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
			array set parent [set $node(node:parentNode)]
			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
			array set parent [set $node(node:parentNode)]
			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 $node(docArray)(node1)
			} 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 number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    if {[string compare $newChild(docArray) $node(docArray)]} {
		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 {

		    array set refChild [set [lindex $args 1]]
		    if {[string compare $refChild(docArray) $newChild(docArray)]} {
			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
		    }
		}
	    }
	    set [lindex $args 0] [array get newChild]

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

	}

	rep* {

	    # replaceChild

	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    array set newChild [set [lindex $args 0]]
	    array set oldChild [set [lindex $args 1]]

	    # Find where to insert new child
	    set idx [lsearch [set $node(node:childNodes)] [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 $node(node:childNodes) \
		[lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]]
	    set newChild(node:parentNode) $token

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

	    set [lindex $args 1] [array get oldChild]
	    set [lindex $args 0] [array get newChild]

	    set result [lindex $args 0]

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

	}

	rem* {

	    # removeChild

	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }
	    array set oldChild [set [lindex $args 0]]
	    if {$oldChild(docArray) != $node(docArray)} {
		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 [lindex $args 0] [array get oldChild]

	    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 number of arguments"
	    }

	    # Add to new parent
	    node insertBefore $token [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 # arguments: 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 {
		}
		1 {
		    set deep [Boolean [lindex $args 0]]
		}
		default {
		    return -code error "too many arguments"
		}
	    }

	    switch $node(node:nodeType) {
		element {
		    set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
		textNode {
		    set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)]
		}
		document -
		documentFragment -
		default {
		    set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)]
		    if {$deep} {
			foreach child [set $node(node:childNodes)] {
			    node appendChild $result [node cloneNode $child]
			}
		    }
		}
	    }

	}

	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
		set result {}
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {[string length $ancNode(node:parentNode)]} {
		set ancestor $ancNode(node:parentNode)
		catch {unset ancNode}
		array set ancNode [set $ancestor]
	    } {
		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 number of arguments"
	    }

	    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 number of arguments"
	    }

	    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.

	    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] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [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"}]

	    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

	}

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

	    if {[llength $args] < 2} {
		return -code error "wrong number of arguments"
	    }

	    set type [string tolower [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 number of arguments"
	    }

	    set eventId [lindex $args 0]
	    array set event [set $eventId]
	    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
		set $eventId [array get event]

		# 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] {
		    array get event [set $eventId]
		    set event(currentNode) $ancestor
		    set $eventId [array get event]

		    catch {unset ancNode}
		    array set ancNode [set $ancestor]

		    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

			array set event [set $eventId]
			if {$event(cancelable) && $event(stopPropagation)} {
			    break
			}
		    }
		}

		# Prepare for next phase
		set event(eventPhase) at_target

	    }

	    set event(currentNode) $token
	    set $eventId [array get event]

	    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\""
		    }
		}
	    }

	    array set event [set $eventId]
	    set event(eventPhase) bubbling_phase
	    set $eventId [array get event]

	    # 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
	    set $eventId [array get event]

	}

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

    }

    set $token [array get node]

    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 $pVar parent

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

    upvar #0 $parent(docArray) docArray

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

    # Update parent node
    if {![info exists parent(document:documentElement)]} {
	lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)]
    }

    return $parent(docArray)($opts(-id))

}

# 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 $token node

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

    set $token [array get node]

    return {}
}

# 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

    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	return -code error "not an element type 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 {
		    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 "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]} {
			return -code error "not implemented"
		    } else {
			return -code error "unknown option \"$option\""
		    }
		}
	    }
	}

	getAttribute {
	    if {[llength $args] != 1} {
		return -code error "wrong number of arguments"
	    }

	    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 number of arguments"
	    }

	    # 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]
	    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 number of arguments"
	    }

	    upvar #0 $node(element:attributeList) attrList
	    catch {unset attrList([lindex $args 0])}

	    event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]

	}

	getAttributeNS {
	    if {[llength $args] != 2} {
		return -code error "wrong number of arguments"
	    }

	    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 number of arguments"
	    }

	    # 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
	    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 number of arguments"
	    }

	    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]

	}

	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 number of arguments"
	    }

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

	normalize {
	    if {[llength $args]} {
		return -code error "wrong number of arguments"
	    }

	    Element:Normalize node [set $node(node:childNodes)]
	}

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

    }

    set $token [array get node]

    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} {
    array set node [set $token]
    upvar \#0 $node(docArray) docArray

    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 $node(docArray)search[incr docArray(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) "documentFragment"]} {
	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 {
	catch {unset nodeInfo}
	array set nodeInfo [set $tok]
	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 $pVar parent

    set textNode {}

    foreach n $nodes {
	array set child [set $n]
	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

    array set node [set $token]

    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\""
	}

    }

    set $token [array get node]

    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
    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

    array set event [set $token]

    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\""
		    }
		}
	    }

	    set $token [array get event]

	}

	st* {
	    # stopPropagation

	    set event(stopPropagation) 1
	    set $token [array get event]

	}

	pr* {
	    # preventDefault

	    set event(preventDefault) 1
	    set $token [array get event]

	}

	initE* {
	    # initEvent

	    if {[llength $args] != 3} {
		return -code error "wrong number of arguments"
	    }

	    if {$event(dispatched)} {
		return -code error "event has been dispatched"
	    }

	    foreach {event(type) event(bubbles) event(cancelable)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initU* {
	    # initUIEvent

	    if {[llength $args] < 4 || [llength $args] > 5} {
		return -code error "wrong number of arguments"
	    }

	    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
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMo* {
	    # initMouseEvent

	    if {[llength $args] != 15} {
		return -code error "wrong number of arguments"
	    }

	    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
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	initMu* {
	    # initMutationEvent

	    if {[llength $args] != 7} {
		return -code error "wrong number of arguments"
	    }

	    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)} $args break
	    set event(type) [string tolower $event(type)]

	    set $token [array get event]

	}

	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 {}			\
	    ]
	    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)
	    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} {
    if {[string length $token]} {
	array set parent [set $token]
	upvar #0 $parent(docArray) docArray
	set docArrayName $parent(docArray)
    } else {
	array set opts $args
	upvar #0 $opts(-docarray) docArray
	set docArrayName $opts(-docarray)
    }

    set id event[incr docArray(counter)]
    set child ${docArrayName}($id)

    # Create the event
    set docArray($id) [list id $id docArray $docArrayName \
	    node:nodeType event	\
	    type $type		\
	    cancelable 1	\
	    stopPropagation 0	\
	    preventDefault 0	\
	    dispatched 0	\
	    bubbles 1		\
	    eventPhase {}	\
	    timeStamp [clock clicks -milliseconds]	\
	    ]

    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} {
    array set node [set $token]

    if {[string compare "node1" $node(documentFragment:masterDoc)]} {
	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} {
    array set node [set $token]
    array set opts {
	-showxmldecl 1
	-showdoctypedecl 1
    }
    array set opts $args

    if {![info exists node(document:documentElement)]} {
	return -code error "document has no document element"
    } elseif {![string length node(document:doctype)]} {
	return -code error "no document type declaration given"
    } else {

	array set doctype [set $node(document: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
		array set docel [set $node(document:documentElement)]
		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:externalid)][expr {[string length $doctype(doctype:internaldtd)] ? " \[[string trim $doctype(doctype:internaldtd) \{\} ]\]" : {}}]>\n
	}

	# BUG #525505: Want to serialize all children including the
	# document element.

	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:
#	id	external indentifiers
#
# Results:
#	text

proc dom::tcl::Serialize:ExternalID id {
    set publicid {}
    set systemid {}
    foreach {publicid systemid} $id break

    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} {
    array set node [set $token]
    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)] {
	catch {unset child}
	array set child [set $childToken]
	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} {
    array set node [set $token]
    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} {
    array set options $args
    array set node [set $token]

    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 $node(docArray) docArray
	    set prefix ns[incr docArray(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 $nodeVar declNode
    upvar $prefVar prefix

    array set nodeinfo [set $token]
    while {[string length $nodeinfo(node:parentNode)]} {

	# Check this node's XML Namespace declarations
	catch {unset attrs}
	array set attrs [array get $nodeinfo(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 $nodeinfo(node:parentNode)
	array set nodeinfo [set $token]
    }

    # 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} {
    array set node [set $token]

    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} {
    array set node [set $token]

    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} {
    array set node [set $token]

    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} {
    array set node [set $token]

    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
	array set node [set [lindex $state(current) end]]
	set node(element:empty) 1
	set [lindex $state(current) end] [array get node]
    }

    # 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

    array set node [set $state(docNode)]
    array set xmldecl $node(document:xmldecl)

    array set xmldecl [list version $version	\
	    standalone $standalone		\
	    encoding $encoding			\
    ]

    set node(document:xmldecl) [array get xmldecl]
    set $state(docNode) [array get node]

    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

    CreateDocType $state(docNode) $root [list $publit $systemlit] $dtd {} {}
    # Last two are entities and notaions (as namedNodeMap's)

    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 {
    array set node [set $nodeid]

    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 {}
}

#################################################
#
# Query function
#
#################################################

# dom::tcl::Query --
#
#	Search DOM.
#
# DEPRECATED: This is obsoleted by XPath.
#
# Arguments:
#	token	node to search
#	args	query options
#
# Results:
#	If query is found, return the node ID of the containing node.
#	Otherwise, return empty string

proc dom::tcl::Query {token args} {
    array set node [set $token]
    array set query $args

    set found 0
    switch $node(node:nodeType) {
	document -
	documentFragment {
	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }
	}
	element {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-tagname)]]}
	    if {$found} {
		return $token
	    }
	    if {![catch {array set attributes [set $node(element:attributeList)]}]} {
		catch {set found [expr [lsearch [array names attributes] $query(-attrname)] >= 0]}
		catch {set found [expr $found || [lsearch [array get attributes] $query(-attrvalue)] >= 0]}
	    }

	    if {$found} {
		return $token
	    }

	    foreach child [set $node(node:childNodes)] {
		if {[llength [set result [eval Query [list $child] $args]]]} {
		    return $result
		}
	    }

	}
	textNode -
	comment {
	    catch {
		set querytext [expr {$node(node:nodeType) == "textNode" ? $query(-text) : $query(-comment)}]
		set found [expr [string match $node(node:nodeValue) $querytext] >= 0]
	    }

	    if {$found} {
		return $token
	    }
	}
	processingInstruction {
	    catch {set found [expr ![string compare $node(node:nodeName) $query(-pitarget)]]}
	    catch {set found [expr $found || ![string compare $node(node:nodeValue) $query(-pidata)]]}

	    if {$found} {
		return $token
	    }
	}
    }

    if {$found} {
	return $token
    }

    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 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]]]} {
	array set nodearr [set [lindex $ctxt 0]]
	set root $nodearr(docArray)(node1)
    } 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] {
	    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] {
	    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 {
    array set node [set $token]

    if {[string compare $node(node:nodeType) "element"]} {
	# Really undefined
	return 0
    }

    foreach child [set $node(node:childNodes)] {
	catch {unset childnode}
	array set childnode [set $child]
	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]} {
	catch {unset nodeinfo}
	array set nodeinfo [set $node]
	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
}