PC World 2002 May/PCWorld_2002-05_cd.bin/Software/TemaCD/activetcltk/ActiveTcl8.3.4.1-8.win32-ix86.exe/ActiveTcl8.3.4.1-win32-ix86/lib/tcldom2.0/dom.tcl

Text File | 2001-10-22 | 96.9 KB | 3,986 lines

# 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-2000 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: dom.tcl,v 1.9 2001/01/23 10:56:38 balls Exp $

package provide dom::tcl 2.0

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

package require xml 2.0

namespace eval dom {
    namespace export DOMImplementation
    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export processingInstruction
    namespace export event

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

    variable strictDOM 0

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

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

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

}

# 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::GetHandle --
#
#    Checks that a token is valid and sets an array variable
#    in the caller to contain the node's fields.
#
#    This is expensive, so it is only used when called by
#    the application.
#
# Arguments:
#    type    node type (for future use)
#    token    token passed in
#    varName    variable name in caller to associate with node
#
# Results:
#    Variable gets node's fields, otherwise returns error.
#    Returns empty string.

proc dom::GetHandle {type token varName} {

    if {![info exists $token]} {
    return -code error "invalid token \"$token\""
    }

    upvar 1 $varName data
    array set data [set $token]

# Type checking not implemented
#    if {[string compare $data(node:nodeType) "document"]} {
#    return -code error "node is not of type document"
#    }

    return {}
}

# dom::PutHandle --
#
#    Writes the values from the working copy of the node's data
#    into the document's global array.
#
#    NB. Token checks are performed in GetHandle
#    NB(2). This is still expensive, so is not used.
#
# Arguments:
#    token    token passed in
#    varName    variable name in caller to associate with node
#
# Results:
#    Sets array element for this node to have new values.
#    Returns empty string.

proc dom::PutHandle {token varName} {

    upvar 1 $varName data
    set $token [array get data]

    return {}
}

# dom::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 {
    variable DOMImplementationOptions {}
    variable DOMImplementationCounter 0
}

proc dom::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 [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 {}        \
            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

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

        return [CreateDocType [lindex $args 0] [list [lindex $args 1] [lindex $args 2]]]
    }

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

        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 ${docArrayName}var$i}
            catch {unset ${docArrayName}arr$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]

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

        }

        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 {[catch {GetHandle node [lindex $args 0] node}]} {
        return 0
        } else {
        return 1
        }
    }

    parse {

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

        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 true

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

        GetHandle documentFragment [lindex $args 0] node
        return [eval [list Serialize:$node(node:nodeType)] $args]

    }

    trim {

        # Removes textNodes that only contain white space

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

        Trim [lindex $args 0]

        # Dispatch DOMSubtreeModified event once here?

        return {}

    }

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

    }

    return {}
}

# dom::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 {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW {}
}

proc dom::document {method token args} {
    variable documentOptionsRO
    variable documentOptionsRW

    # GetHandle also checks token
    GetHandle document $token node

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

        PutHandle $token 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]]} 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::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::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::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::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::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::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) {}

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

    return $child
}

### Specials

# dom::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::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)

    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

    # 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::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 {
    variable strictDOM

    variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName
    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 {$strictDOM} {
    append nodeOptionsRO |nodeName
    } else {
    append nodeOptionsRW |nodeName
    }
}
# NB. cdatasection is not a standard DOM option

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

    GetHandle node $token node

    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
            GetHandle node $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx -1]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            nextSibling {
            # BUG: must take documentElement into account
            # Find the parent node
            GetHandle node $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            attributes {
            if {[string compare $node(node:nodeType) element]} {
                set result {}
            } else {
                set result $node(element:attributeList)
            }
            }
            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 [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)$} $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"
        }

        GetHandle node [lindex $args 0] newChild
        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 {

            GetHandle node [lindex $args 1] refChild
            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
            }
        }
        }
        PutHandle [lindex $args 0] 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"
        }

        GetHandle node [lindex $args 0] newChild
        GetHandle node [lindex $args 1] oldChild

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

        PutHandle [lindex $args 1] oldChild
        PutHandle [lindex $args 0] 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)]]]
    }

    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)] {
            append value [node stringValue $child]
            }
            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]
        GetHandle event $eventId event
        set type $event(type)

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

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

        set event(eventPhase) capturing_phase
        set event(target) $token
        PutHandle $eventId 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] {
            GetHandle event $eventId event
            set event(currentNode) $ancestor
            PutHandle $eventId 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

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

        # Prepare for next phase
        set event(eventPhase) at_target

        }

        set event(currentNode) $token
        PutHandle $eventId 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\""
            }
        }
        }

        GetHandle event $eventId event
        set event(eventPhase) bubbling_phase
        PutHandle $eventId 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
        PutHandle $eventId event

    }

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

    }

    PutHandle $token node

    return $result
}

# dom::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::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::Node:set --
#
#    Generic node update
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    Node modified.

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

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

    set $token [array get node]

    return {}
}

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

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

    return {}
}

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

proc dom::FireNodeRemovedEvents nodeid {
    event postMutationEvent $nodeid DOMNodeRemovedFromDocument
    foreach child [node children $nodeid] {
    FireNodeRemovedEvents $child
    }

    return {}
}

# dom::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 {
    variable elementOptionsRO tagName|empty
    variable elementOptionsRW {}
}

proc dom::element {method token args} {
    variable elementOptionsRO
    variable elementOptionsRW

    GetHandle node $token node

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

    }

    PutHandle $token node

    return $result
}

# dom::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:
#    List of matching node tokens

proc dom::Element:GetByTagName {token name args} {
    array set node [set $token]

    array set cfg {-deep 1}
    array set cfg $args
    set cfg(-deep) [Boolean $cfg(-deep)]

    # Guard against arbitrary glob characters
    # Probably should check that name is a legal XML Name
    if {[regexp {[][*?\\]} $name] && [string compare $name "*"]} {
    return -code error "invalid element name"
    }

    set result {}

    if {[string compare $node(node:nodeType) "documentFragment"]} {
    return [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
    return [Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]
    }

    return $result
}

# dom::Element:GetByTagName:Search --
#
#    Search for elements.  This does the real work.
#
# Arguments:
#    tokens    nodes to search (inclusive)
#    name    element type to search for
#    deep    whether to search recursively
#
# Results:
#    List of matching node tokens

proc dom::Element:GetByTagName:Search {tokens name deep} {
    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
            }
        }
        }
    }
    }

    return $result
}

# dom::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::Element:Normalize {pVar nodes} {
    upvar $pVar parent

    set textNode {}

    foreach n $nodes {
    GetHandle node $n child
    set cleanup {}

    switch $child(node:nodeType) {
        textNode {
        if {[llength $textNode]} {

            # Coalesce into previous node
            set evid [CreateEvent $n DOMCharacterDataModified]
            event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {}
            append text(node:nodeValue) $child(node:nodeValue)
            node dispatchEvent $n $evid
            DOMImplementation destroy $evid

            # Remove this child
            upvar #0 $parent(node:childNodes) childNodes
            set idx [lsearch $childNodes $n]
            set childNodes [lreplace $childNodes $idx $idx]
            unset $n
            set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified]
            event postMutationEvent $n DOMNodeRemoved

            PutHandle $textNode 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::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 {
    variable piOptionsRO target
    variable piOptionsRW data
}

proc dom::processinginstruction {method token args} {
    variable piOptionsRO
    variable piOptionsRW

    GetHandle node $token node

    set result {}

    switch -- $method {

    cget {
        # Some read-only configuration options are computed
        if {[llength $args] != 1} {
        return -code error "too many arguments"
        }
        if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
        switch $option {
            target {
            set result [lindex $node(node:nodeName) 0]
            }
            default {
            return $node(node:$option)
            }
        }
        } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
        switch $option {
            data {
            return $node(node:nodeValue)
            }
            default {
            return $node(node:$option)
            }
        }
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [document cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
            switch $opt {
                data {
                set evid [CreateEvent $token DOMCharacterDataModified]
                event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {}
                set node(node:nodeValue) $value
                node dispatchEvent $token $evid
                DOMImplementation destroy $evid
                }
                default {
                set node(node:$opt) $value
                }
            }
            } else {
            return -code error "unknown option \"$option\""
            }
        }
        }
    }

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

    }

    PutHandle $token node

    return $result
}

#################################################
#
# DOM Level 2 Interfaces
#
#################################################

# dom::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 {
    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::event {method token args} {
    variable eventOptionsRO
    variable eventOptionsRW
    variable bubbles
    variable cancelable

    GetHandle event $token event

    set result {}

    switch -glob -- $method {

    cg* {
        # cget

        if {[llength $args] != 1} {
        return -code error "too many arguments"
        }
        if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} {
        return $event($option)
        } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} {
        return $event($option)
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }

    co* {
        # configure

        if {[llength $args] == 1} {
        return [event cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $eventOptionsRW] $option discard opt]} {
            set event($opt) $value
            } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } else {
            return -code error "unknown option \"$option\""
            }
        }
        }

        PutHandle $token event

    }

    st* {
        # stopPropagation

        set event(stopPropagation) 1
        PutHandle $token event

    }

    pr* {
        # preventDefault

        set event(preventDefault) 1
        PutHandle $token 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)]

        PutHandle $token 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)]

        PutHandle $token 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)]

        PutHandle $token 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)]

        PutHandle $token event

    }

    postUI* {
        # postUIEvent, non-standard convenience method

        set evType [lindex $args 0]
        array set evOpts [list \
            -bubbles $bubbles($evType) -cancelable $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 $bubbles($evType) -cancelable $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 $bubbles($evType) -cancelable $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::CreateEvent --
#
#    Create an event object
#
# Arguments:
#    token    parent node
#    type    event type
#    args    configuration options
#
# Results:
#    Returns event token

proc dom::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::Serialize:documentFragment --
#
#    Produce text for documentFragment.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::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::Serialize:document --
#
#    Produce text for document.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::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: Want to serialize all children except for the
    # document element, and then do the document element.

    # 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)} {
        append result <!DOCTYPE\ $doctype(doctype:name)[Serialize:ExternalID $doctype(doctype:externalid)][expr {[string length $doctype(doctype:internaldtd)] ? " \[$doctype(doctype:internaldtd)\]" : {}}]>\n
    }

    return $result[eval Serialize:element [list $node(document:documentElement)] $args]
    }

}

# dom::Serialize:ExternalID --
#
#    Returned appropriately quoted external identifiers
#
# Arguments:
#    id    external indentifiers
#
# Results:
#    text

proc dom::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\""
    }
    *,* {
        return " PUBLIC \"$publicid\" \"systemid\""
    }
    }

    return {}
}

# dom::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::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::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::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::Serialize:element --
#
#    Produce text for an element.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::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]]
    append result "<$node(node:nodeName)"
    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</$node(node:nodeName)>$newline"

    }

    return $result
}

# dom::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::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::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::Serialize:ExceedsThreshold {text} {
    variable maxSpecials

    return [expr {[regsub -all {[<>&]} $text {} discard] > $maxSpecials}]
}

# dom::Serialize:CDATASection --
#
#    Formats a CDATA section.
#
# Arguments:
#    text    node text
#
# Results:
#    XML text.

proc dom::Serialize:CDATASection {text} {
    set result {}
    while {[regexp {(.*)]]>(.*)} $text discard text trailing]} {
    set result \]\]>\;<!\[CDATA\[$trailing\]\]>$result
    }
    return <!\[CDATA\[$text\]\]>$result
}

# dom::Serialize:processingInstruction --
#
#    Produce text for a PI node.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::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::Serialize:comment --
#
#    Produce text for a comment node.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::Serialize:comment {token args} {
    array set node [set $token]

    return [eval Serialize:Indent $args]<!--$node(node:nodeValue)-->
}

# dom::Serialize:entityReference --
#
#    Produce text for an entity reference.
#
# Arguments:
#    token    node token
#    args    configuration options
#
# Results:
#    XML format text.

proc dom::Serialize:entityReference {token args} {
    array set node [set $token]

    return &$node(node:nodeName)\;
}

# dom::Encode --
#
#    Encode special characters
#
# Arguments:
#    value    text value
#
# Results:
#    XML format text.

proc dom::Encode value {
    array set Entity {
    $ $
    < <
    > >
    & &
    \" "
    ' '
    }

    regsub -all {([$<>&"'])} $value {$Entity(\1)} value

    return [subst -nocommand -nobackslash $value]
}

# dom::Serialize:attributeList --
#
#    Produce text for an attribute list.
#
# Arguments:
#    l    name/value paired list
#
# Results:
#    XML format text.

proc dom::Serialize:attributeList {l} {

    set result {}
    foreach {name value} $l {

    append result { } $name =

    # Handle special characters
    regsub -all < $value {\<} value
    regsub -all & $value {\&} value

    if {![string match *\"* $value]} {
        append result \"$value\"
    } elseif {![string match *'* $value]} {
        append result '$value'
    } else {
        regsub -all \" $value {\"} value
        append result \"$value\"
    }

    }

    return $result
}

# dom::Serialize:Indent --
#
#    Calculate the indentation required, if any
#
# Arguments:
#    args    configuration options, which may specify -indent
#
# Results:
#    May return white space

proc dom::Serialize:Indent args {
    variable indentspec
    array set opts [list -indentspec $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
#
#################################################

# 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::ParseElementStart {stateVar name attrList args} {
    variable xmlnsURI

    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) $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)
    }
    }
}

# 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::ParseElementEnd {stateVar name args} {
    upvar #0 $stateVar state

    set state(current) [lreplace $state(current) end end]
}

# 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::ParseCharacterData {stateVar data} {
    upvar #0 $stateVar state

    CreateTextNode [lindex $state(current) end] $data
}

# 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::ParseProcessingInstruction {stateVar name target} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
}

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

# 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::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::ParseComment --
#
#    Parse comment
#
# Arguments:
#    stateVar    state array
#    data        comment data
#
# Results:
#    Comment node added to DOM tree

proc dom::ParseComment {stateVar data} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data

    return {}
}

# dom::ParseEntityReference --
#
#    Parse an entity reference
#
# Arguments:
#    stateVar    state variable
#    ref        entity
#
# Results:
#    Entity reference node added to DOM tree

proc dom::ParseEntityReference {stateVar ref} {
    upvar #0 $stateVar state

    CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref

    return {}
}

#################################################
#
# Trim white space
#
#################################################

# dom::Trim --
#
#    Remove textNodes that only contain white space
#
# Arguments:
#    nodeid    node to trim
#
# Results:
#    textNode nodes may be removed (from descendants)

proc dom::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 <[e-mail]>
        set children {}
        catch {set children [set $node(node:childNodes)]}
        foreach child $children {
        Trim $child
        }
    }

    }

    return {}
}

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

# dom::Query --
#
#    Search DOM.
#
# DEPRECATED: This will be 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::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::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::XPath:CreateNode {node path} {

    if {[string length [node parent $node]]} {
    array set nodearr [set $node]
    set root $nodearr(docArray)(node1)
    } else {
    set root $node
    }

    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 [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 [node children $context] {
                switch [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 [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 [node children $context] {
            switch [node cget $child -nodeType] {
                element {
                if {![string compare [lindex $step 1] [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 [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::CreateNode:FindPosition --

proc dom::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::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::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] <= 1} {
    return $root
    }

    if {![llength [lindex $spath 0]]} {
    set ctxt $root
    set spath [lrange $spath 1 end]
    }

    return [XPath:SelectNode:Rel $ctxt $spath]
}

# dom::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::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::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::XPath:SN:GetElementTypeNodes nodeset {
    set result {}
    foreach node $nodeset {
    switch [node cget $node -nodeType] {
        documentFragment -
        element {
        lappend result $node
        }
        default {}
    }
    }
    return $result
}

# dom::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::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::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::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::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::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::XPath:ApplyPredicate --
#
#    Filter a node with a single predicate
#
# Arguments:
#    node    current context node
#    pred    predicate
#
# Results:
#    Returns boolean

proc dom::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::XPath:Pred:Compare --

proc dom::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::XPath:Pred:ResolveExpr --

proc dom::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::hasmixedcontent --
#
#    Determine whether an element contains mixed content
#
# Arguments:
#    token    dom node
#
# Results:
#    Returns 1 if element contains mixed content,
#    0 otherwise

proc dom::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::prefix2namespaceURI --
#
#    Given an XML Namespace prefix, find the corresponding Namespace URI
#
# Arguments:
#    node    DOM Node
#    prefix    XML Namespace prefix
#
# Results:
#    Returns URI

proc dom::prefix2namespaceURI {node prefix} {
    variable xmlnsURI

    # Search this node and its ancestors for the appropriate
    # XML Namespace declaration

    set parent [dom::node parent $node]
    set nsuri [dom::element getAttributeNS $node $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::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::GetField var {
    upvar $var v
    if {[info exists v]} {
    return $v
    } else {
    return {}
    }
}

# dom::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::Min {a b} {
    return [expr {$a < $b ? $a : $b}]
}

# dom::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::Max {a b} {
    return [expr {$a > $b ? $a : $b}]
}

# dom::Boolean --
#
#    Return a boolean value
#
# Arguments:
#    b    value
#
# Results:
#    Returns 0 or 1

proc dom::Boolean b {
    regsub -nocase {^(true|yes|1|on)$} $b 1 b
    regsub -nocase {^(false|no|0|off)$} $b 0 b
    return $b
}