dom.tcl

Go to the documentation of this file.

/*  dom.tcl --*/
/* */
/*  This file implements the Tcl language binding for the DOM -*/
/*  the Document Object Model.  Support for the core specification*/
/*  is given here.  Layered support for specific languages, */
/*  such as HTML, will be in separate modules.*/
/* */
/*  Copyright (c) 1998-2004 Zveno Pty Ltd*/
/*  http://www.zveno.com/*/
/* */
/*  See the file "LICENSE" in this distribution for information on usage and*/
/*  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/* */
/*  $Id: dom.tcl,v 1.23 2004/02/25 20:10:28 balls Exp $*/

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

package require xml 3.0

package provide dom::tcl 3.0

/*  Define generic constants*/

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

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export ret essingInstruction
    namespace export documenttype
    namespace export event

    variable maxSpecials
    if (![type info , type exists , type maxSpecials]) {
    set maxSpecials 10
    }

    variable strictDOM 0

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

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

    /*  DOM Level 2 Event defaults*/
    variable bubbles
    array  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  cancelable =  {
    DOMFocusIn 0
    DOMFocusOut 0
    DOMActivate 1
    click 1
    mousedown 1
    mouseup 1
    mouseover 1
    mousemove 0
    mouseout 1
    DOMSubtreeModified 0
    DOMNodeInserted 0
    DOMNodeRemoved 0
    DOMNodeInsertedIntoDocument 0
    DOMNodeRemovedFromDocument 0
    DOMAttrModified 0
    DOMAttrRemoved 0
    DOMCharacterDataModified 0
    }
}

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

    namespace export document documentFragment node
    namespace export element textNode attribute
    namespace export ret essingInstruction
    namespace export event
}

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

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

}

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

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

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

ret  dom::tcl::DOMImplementation (type method , type args) {
    variable DOMImplementationOptions
    variable DOMImplementationCounter

    switch -- $method {

    hasFeature {

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

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

    }

    createDocument {
        # createDocument introduced in DOM Level 2

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

        set doc [DOMImplementation create]

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

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

        return $doc
    }

    create {

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

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

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

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

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

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

        # Initialise child node list
        set $varPrefix {}

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

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

        # Return the new toplevel node
        return $name
    }

    createDocumentType {
        # Introduced in DOM Level 2

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

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

        return [eval CreateDocType $args]
    }

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

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

        package require xpath

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

    destroy {

        # Free all memory associated with a node

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

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

        switch $node(node:nodeType) {

        document -
        documentFragment {

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

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

            return {}
            }

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

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

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

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

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

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

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

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

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

            # Dispatch events
            event postMutationEvent $parent DOMSubtreeModified

        }

        }

        return {}

    }

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

        upvar #0 [lindex $args 0] node

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

    parse {

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

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

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

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

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

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

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

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

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

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

    }

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

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

        package require xpath

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

    serialize {

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

        upvar #0 [lindex $args 0] node

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

    }

    trim {

        # Removes textNodes that only contain white space

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

        Trim [lindex $args 0]

        # Dispatch DOMSubtreeModified event once here?

        return {}

    }

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

    }

    return {}
}

namespace dom::tcl {
    foreach ret  {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} (
    type proc $, type method , type args ", type eval [, type namespace , type current]::, type DOMImplementation $, type method \$, type args"
    )
}

# dom::tcl::Document:Delete --
#
#   Handle destruction of a document
#
# Arguments:
#   name    document token
#   old )
#   new ) args added by trace command
#   op  )

proc dom::tcl::Document:Delete {name old new op} {
    DOMImplementation destroy $name
    return {}
}

/*  dom::tcl::document --*/
/* */
/*  Functions for a document node.*/
/* */
/*  Arguments:*/
/*  method  method to invoke*/
/*  token   token for node*/
/*  args    arguments for method*/
/* */
/*  Results:*/
/*  Depends on method used.*/

namespace dom::tcl {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW actualEncoding|encoding|standalone|version
}

ret  dom::tcl::document (type method , type token , type args) {
    variable documentOptionsRO
    variable documentOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {
    cget {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"dom::document method token ?args ...?\""
        }
        if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
        return $node(document:$option)
        } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
        switch -- $option {
            encoding -
            version -
            standalone {
            array set xmldecl $node(document:xmldecl)
            return $xmldecl($option)
            }
            default {
            return $node(document:$option)
            }
        }
        } else {
        return -code error "bad option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [document cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} {
            switch -- $opt {
                encoding {
                catch {unset xmldecl}
                array set xmldecl $node(document:xmldecl)
                set xmldecl(encoding) $value
                set node(document:xmldecl) [array get xmldecl]
                }
                standalone {
                if {[string is boolean $value]} {
                    catch {unset xmldecl}
                    array set xmldecl $node(document:xmldecl)
                    if {[string is true $value]} {
                    set xmldecl(standalone) yes
                    } else {
                    set xmldecl(standalone) no
                    }
                    set node(document:xmldecl) [array get xmldecl]
                } else {
                    return -code error "unsupported value for option \"$option\" - must be boolean"
                }
                }
                version {
                if {$value == "1.0"} {
                    catch {unset xmldecl}
                    array set xmldecl $node(document:xmldecl)
                    set xmldecl(version) $value
                    set node(document:xmldecl) [array get xmldecl]
                } else {
                    return -code error "unsupported value for option \"$option\""
                }
                }
                default {
                set node(document:$opt) $value
                }
            }
            } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } else {
            return -code error "bad option \"$option\""
            }
        }
        }
    }

    createElement {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createElement token name\""
        }

        # Check that the element name is kosher
        if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
        return -code error "invalid element name \"[lindex $args 0]\""
        }

        # Invoke internal factory function
        set result [CreateElement $token [lindex $args 0] {}]

    }
    createDocumentFragment {
        if {[llength $args]} {
        return -code error "wrong # args: should be \"document createDocumentFragment token\""
        }

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

        set result [CreateTextNode $token [lindex $args 0]]
    }
    createComment {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createComment token data\""
        }

        set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
    }
    createCDATASection {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createCDATASection token data\""
        }

        set result [CreateTextNode $token [lindex $args 0]]
        node configure $result -cdatasection 1
    }
    createProcessingInstruction {
        if {[llength $args] != 2} {
        return -code error "wrong # args: should be \"document createProcessingInstruction token target data\""
        }

        set result [CreateGeneric $token node:nodeType processingInstruction \
            node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
    }
    createAttribute {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createAttributes token name\""
        }

        # Check that the attribute name is kosher
        if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
        return -code error "invalid attribute name \"[lindex $args 0]\""
        }

        set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
    }
    createEntity {
        set result [CreateGeneric $token node:nodeType entity]
    }
    createEntityReference {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createEntityReference token name\""
        }
        set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
    }

    importNode {
        # Introduced in DOM Level 2

        if {[llength $args] < 1} {
        return -code error "wrong # args: should be \"importNode token ?-deep boolean?\""
        }
        array set opts {
        -deep 1
        }
        array set opts [lrange $args 1 end]
        set opts(-deep) [Boolean $opts(-deep)]

        if {[namespace qualifiers [lindex $args 0]] == [namespace qualifiers $token]} {
        return -code error "source node \"[lindex $args 0]\" is in the same document"
        }

        switch [node cget [lindex $args 0] -nodeType] {
        document -
        documentType {
            return -code error "node type \"[node cget [lindex $args 0] -type]\" cannot be imported"
        }
        documentFragment {
            set result [document createDocumentFragment $token]
            if {$opts(-deep)} {
            foreach child [node children [lindex $args 0]] {
                $result appendChild [$token importNode $child -deep 1]
            }
            }
        }
        element {
            set result [CreateElement {} [node cget [lindex $args 0] -nodeName] [array get [node cget [lindex $args 0] -attributes]] -document $token]
            if {$opts(-deep)} {
            foreach child [node children [lindex $args 0]] {
                $result appendChild [$token importNode $child -deep 1]
            }
            }
        }
        textNode {
            set result [CreateTextNode {} [node cget [lindex $args 0] -nodeValue] -document $token]
        }
        attribute -
        processingInstruction -
        comment {
            set result [CreateGeneric {} -document $token node:nodeType [node cget [lindex $args 0] -nodeType] node:nodeName [node cget [lindex $args 0] -nodeName] node:nodeValue [node cget [lindex $args 0] -nodeValue]]
        }
        }
    }

    createElementNS {
        # Introduced in DOM Level 2

        if {[llength $args] != 2} {
        return -code error "wrong # args: should be: \"createElementNS nsuri qualname\""
        }

        # Check that the qualified name is kosher
        if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]]  break} err]} {
        return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\""
        }

        # Invoke internal factory function
        set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname]
    }

    createAttributeNS {
        # Introduced in DOM Level 2

        return -code error "not yet implemented"
    }

    getElementsByTagNameNS {
        # Introduced in DOM Level 2

        return -code error "not yet implemented"
    }

    getElementsById {
        # Introduced in DOM Level 2

        return -code error "not yet implemented"
    }

    createEvent {
        # Introduced in DOM Level 2

        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"document createEvent token type\""
        }

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

    }

    getElementsByTagName {
        if {[llength $args] < 1} {
        return -code error "wrong # args: should be \"document getElementsByTagName token what\""
        }

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

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

    }

    # Dispatch events

    # Node insertion events are generated here instead of the
    # internal factory procedures.  This is because the factory
    # procedures are meant to be mean-and-lean during the parsing
    # phase, and dispatching events at that time would be an
    # excessive overhead.  The factory methods here are pretty
    # heavyweight anyway.

    if {[string match create* $method] && [string compare $method "createEvent"]} {

    event postMutationEvent $result DOMNodeInserted -relatedNode $token
    event postMutationEvent $result DOMNodeInsertedIntoDocument
    event postMutationEvent $token DOMSubtreeModified

    }

    return $result
}

/*  Factory methods*/
/* */
/*  These are lean-and-mean for fastest possible tree building*/

/*  dom::tcl::CreateElement --*/
/* */
/*  Append an element to the given (parent) node (if any)*/
/* */
/*  Arguments:*/
/*  token   parent node (if empty -document option is mandatory)*/
/*  name    element name (no checking performed here)*/
/*  aList   attribute list*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  New node created, parent optionally modified*/

ret  dom::tcl::CreateElement (type token , type name , type aList , type args) {
    array set opts $args

    if {[string length $token]} {
    upvar #0 $token parent
    upvar #0 [namespace qualifiers $token]::Document document
    set child [namespace qualifiers $token]::node[incr document(counter)]
    } elseif {[info exists opts(-document)]} {
    upvar #0 $opts(-document) document
    set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
    } else {
    return -code error "no parent or document specified"
    }

    upvar #0 $child new

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

    catch {set new(node:namespaceURI) $opts(-namespace)}
    catch {set new(node:localName) $opts(-localname)}
    catch {set new(node:prefix) $opts(-prefix)}

    # Initialise associated variables
    set ${child}var {}
    array set ${child}arr $aList
    catch {
    foreach {ns nsAttrList} $opts(-namespaceattributelists) {
        foreach {attrName attrValue} $nsAttrList {
        array set ${child}arr [list $ns^$attrName $attrValue]
        }
    }
    }

    # Update parent record

    # Does this element qualify as the document element?
    # If so, then has a document element already been set?

    if {[string length $token] && 
    [string equal $parent(node:nodeType) document]} {

    if {$token == $parent(documentFragment:masterDoc)} {
        if {[info exists parent(document:documentElement)] && \
            [string length $parent(document:documentElement)]} {
        # Do not attach to the tree
        set new(node:parentNode) {}
        } else {

        # Check against document type decl
        if {[string length $parent(document:doctype)]} {
            upvar #0 $parent(document:doctype) doctypedecl
            if {[string compare $name $doctypedecl(doctype:name)]} {
            return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
            }

        } else {
            # Synthesize document type declaration
            set doctype [CreateDocType $name {} {}]
            set document(document:doctype) $doctype
        }

        set parent(document:documentElement) $child
        catch {lappend $parent(node:childNodes) $child}
        }
    } else {
        catch {lappend $parent(node:childNodes) $child}
    }
    } else {
    catch {lappend $parent(node:childNodes) $child}
    }

    proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

/*  dom::tcl::CreateTextNode --*/
/* */
/*  Append a textNode node to the given (parent) node (if any).*/
/* */
/*  This factory function can also be performed by*/
/*  CreateGeneric, but text nodes are created so often*/
/*  that this specific factory procedure speeds things up.*/
/* */
/*  Arguments:*/
/*  token   parent node (if empty -document option is mandatory)*/
/*  text    initial text*/
/*  args    additional configuration options*/
/* */
/*  Results:*/
/*  New node created, parent optionally modified*/

ret  dom::tcl::CreateTextNode (type token , type text , type args) {
    array set opts $args

    if {[string length $token]} {
    upvar #0 $token parent
    upvar #0 [namespace qualifiers $token]::Document document
    set child [namespace qualifiers $token]::node[incr document(counter)]
    } elseif {[info exists opts(-document)]} {
    upvar #0 $opts(-document) document
    set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
    } else {
    return -code error "no parent or document specified"
    }

    upvar #0 $child new

    # Create the new node
    # NB. normally we'd use Node:create here,
    # but inline it instead for performance

    # Text nodes never have children, so don't create a variable

    array set new [list \
        node:parentNode $token      \
        node:childNodes ${child}var     \
        node:nodeType textNode      \
        node:nodeValue $text        \
        node:nodeName #text         \
        node:cdatasection 0         \
    ]

    set ${child}var {}

    # Update parent record
    catch {lappend $parent(node:childNodes) $child}

    proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

/*  dom::tcl::CreateGeneric --*/
/* */
/*  This is a template used for type-specific factory procedures*/
/* */
/*  Arguments:*/
/*  token   parent node (if empty -document option is mandatory)*/
/*  args    optional values*/
/* */
/*  Results:*/
/*  New node created, parent modified*/

ret  dom::tcl::CreateGeneric (type token , type args) {
    array set opts $args

    if {[string length $token]} {
    upvar #0 $token parent
    upvar #0 [namespace qualifiers $token]::Document document
    set child [namespace qualifiers $token]::node[incr document(counter)]
    } elseif {[info exists opts(-document)]} {
    upvar #0 $opts(-document) document
    set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
    } else {
    return -code error "no parent or document specified"
    }
    upvar #0 $child new

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

    switch -glob -- [string length $token],$opts(node:nodeType) {
    0,* -
    *,attribute -
    *,namespace {
        # These type of nodes are not children of their parent
    }

    default {
        # Update parent record
        lappend $parent(node:childNodes) $child
    }
    }

    proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

/*  Specials*/

/*  dom::tcl::CreateDocType --*/
/* */
/*  Create a Document Type Declaration node.*/
/* */
/*  Arguments:*/
/*  name    root element type*/
/*  publicid    public identifier*/
/*  systemid    system identifier*/
/*  internaldtd internal DTD subset*/
/* */
/*  Results:*/
/*  Returns node id of the newly created node.*/

ret  dom::tcl::CreateDocType (type name , type publicid , type systemid , optional internaldtd ={)} {
    if {![regexp ^$::xml::QName\$ $name]} {
    return -code error "invalid QName \"$name\""
    }

     nodename =  [namespace current]::$name
    upvar /* 0 $nodename doctype*/
    if {[info exists doctype]} {
    return $nodename
    }

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

    array  doctype =  [list \
        node:childNodes {} \
        node:nodeType documentType \
        node:nodeName $name \
        node:nodeValue {} \
        doctype:name $name \
        doctype:entities {} \
        doctype:notations {} \
        doctype:publicId $publicid \
        doctype:systemId $systemid \
        doctype:internalSub $internaldtd =  \
    ]

    ret  $nodename (type method , type args) "return \[eval [namespace current]::documenttype \[list \$method\] $nodename \$args\]"
    trace add command $nodename delete [namespace code [list DocumentType:Delete $nodename]]

    return $nodename
}

# dom::tcl::documenttype --
#
#   Functions for a document type declaration node.
#
# Arguments:
#   method  method to invoke
#   token   token for node
#   args    arguments for method
#
# Results:
#   Depends on method used.

namespace eval dom::tcl {
    variable documenttypeOptionsRO name|entities|notations|publicId|systemId|internalSubset
    variable documenttypeOptionsRW {}
}

ret  dom::tcl::documenttype (type method , type token , type args) {
    variable documenttypeOptionsRO
    variable documenttypeOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {
    cget {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"dom::documenttype method token ?args ...?\""
        }
        if {[regexp [format {^-(%s)$} $documenttypeOptionsRO] [lindex $args 0] discard option]} {
        switch -- $option {
            name {
            return $node(node:nodeName)
            }
            default {
            return $node(doctype:$option)
            }
        }
        } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRW] [lindex $args 0] discard option]} {
        return $node(doctype:$option)
        } else {
        return -code error "bad option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [documenttype cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $documenttypeOptionsRW] $option discard opt]} {
            switch -- $opt {
                default {
                set node(doctype:$opt) $value
                }
            }
            } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRO] $option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } else {
            return -code error "bad option \"$option\""
            }
        }
        }
    }
    }

    return $result
}

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

ret  dom::tcl::DocumentType:Delete (type name , type old , type new , type op) {
    DOMImplementation destroy $name
}

/*  dom::tcl::node --*/
/* */
/*  Functions for a general node.*/
/* */
/*  Implements EventTarget Interface - introduced in DOM Level 2*/
/* */
/*  Arguments:*/
/*  method  method to invoke*/
/*  token   token for node*/
/*  args    arguments for method*/
/* */
/*  Results:*/
/*  Depends on method used.*/

namespace dom::tcl {
    variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument
    variable nodeOptionsRW nodeValue|cdatasection

    /*  Allowing nodeName to be rw is not standard DOM.*/
    /*  A validating implementation would have to be very careful*/
    /*  in allowing this feature*/
    if {$::dom::strictDOM} {
    append nodeOptionsRO |nodeName
    } else {
    append nodeOptionsRW |nodeName
    }
}
/*  NB. cdatasection is not a standard DOM option*/

ret  dom::tcl::node (type method , type token , type args) {
    variable nodeOptionsRO
    variable nodeOptionsRW

    upvar #0 $token node

    set result {}

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

        # Some read-only configuration options are computed
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"dom::node cget token option\""
        }
        if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
        switch $option {
            nodeName {
            set result $node(node:nodeName)
            switch $node(node:nodeType) {
                textNode {
                catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]}
                }
                default {
                }
            }
            }
            childNodes {
            # How are we going to handle documentElement?
            set result $node(node:childNodes)
            }
            firstChild {
            upvar #0 $node(node:childNodes) children
            switch $node(node:nodeType) {
                document {
                set result [lindex $children 0]
                catch {set result $node(document:documentElement)}
                }
                default {
                set result [lindex $children 0]
                }
            }
            }
            lastChild {
            upvar #0 $node(node:childNodes) children
            switch $node(node:nodeType) {
                document {
                set result [lindex $children end]
                catch {set result $node(document:documentElement)}
                }
                default {
                set result [lindex $children end]
                }
            }
            }
            previousSibling {
            # BUG: must take documentElement into account
            # Find the parent node
            upvar #0 $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx -1]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            nextSibling {
            # BUG: must take documentElement into account
            # Find the parent node
            upvar #0 $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            attributes {
            if {[string compare $node(node:nodeType) element]} {
                set result {}
            } else {
                set result $node(element:attributeList)
            }
            }
            ownerDocument {
            if {[string compare $node(node:parentNode) {}]} {
                return [namespace qualifiers $token]::Document
            } else {
                return $token
            }
            }
            default {
            return [GetField node(node:$option)]
            }
        }
        } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
        return [GetField node(node:$option)]
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }
    co* {
        # configure

        if {[llength $args] == 1} {
        return [node cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "wrong \# args: should be \"::dom::node configure node option\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {

            switch $opt,$node(node:nodeType) {
                nodeValue,textNode -
                nodeValue,processingInstruction {
                # Dispatch event
                set evid [CreateEvent $token DOMCharacterDataModified]
                event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {} {}
                set node(node:nodeValue) $value
                node dispatchEvent $token $evid
                DOMImplementation destroy $evid
                }
                default {
                set node(node:$opt) $value
                }
            }

            } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } else {
            return -code error "unknown option \"$option\""
            }
        }
        }
    }

    in* {

        # insertBefore

        # Previous and next sibling relationships are OK, 
        # because they are dynamically determined

        if {[llength $args] < 1 || [llength $args] > 2} {
        return -code error "wrong # args: should be \"dom::node insertBefore token new ?ref?\""
        }

        upvar #0 [lindex $args 0] newChild
        if {[string compare [namespace qualifiers [lindex $args 0]] [namespace qualifiers $token]]} {
        return -code error "new node must be in the same document"
        }

        switch [llength $args] {
        1 {
            # Append as the last node
            if {[string length $newChild(node:parentNode)]} {
            node removeChild $newChild(node:parentNode) [lindex $args 0]
            }
            lappend $node(node:childNodes) [lindex $args 0]
            set newChild(node:parentNode) $token
        }
        2 {
            upvar #0 [lindex $args 1] refChild

            if {[string compare [namespace qualifiers [lindex $args 1]] [namespace qualifiers [lindex $args 0]]]} {
            return -code error "nodes must be in the same document"
            }
            set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
            if {$idx < 0} {
            return -code error "no such reference child"
            } else {

            # Remove from previous parent
            if {[string length $newChild(node:parentNode)]} {
                node removeChild $newChild(node:parentNode) [lindex $args 0]
            }

            # Insert into new node
            set $node(node:childNodes) \
                [linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
            set newChild(node:parentNode) $token
            }
        }
        }

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

        set result [lindex $args 0]

    }

    rep* {

        # replaceChild

        if {[llength $args] != 2} {
        return -code error "wrong # args: should be \"dom::node replaceChild token new old\""
        }

        upvar #0 [lindex $args 0] newChild
        upvar #0 [lindex $args 1] oldChild
        upvar #0 $node(node:childNodes) children

        # Find where to insert new child
        set idx [lsearch $children [lindex $args 1]]
        if {$idx < 0} {
        return -code error "no such old child"
        }

        # Remove new child from current parent
        if {[string length $newChild(node:parentNode)]} {
        node removeChild $newChild(node:parentNode) [lindex $args 0]
        }

        set children \
        [lreplace $children $idx $idx [lindex $args 0]]
        set newChild(node:parentNode) $token

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

        set result [lindex $args 1]

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

    }

    removeC* {

        # removeChild

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

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

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

        set result [lindex $args 0]

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

    }

    ap* {

        # appendChild

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

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

        set result [lindex $args 0]

    }

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

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

    cl* {
        # cloneNode

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

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

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

    ch* {
        # children -- non-standard method

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

    }

    par* {
        # parent -- non-standard method

        return $node(node:parentNode)

    }

    pat* {
        # path -- non-standard method

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

    }

    createNode {
        # createNode -- non-standard method

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

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

        package require xpath

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

    selectNode {
        # selectNode -- non-standard method

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

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

        package require xpath

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

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

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

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

    }

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

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

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

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

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

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

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

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

    }

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

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

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

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

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

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

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

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

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

            upvar #0 $ancestor ancNode

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

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

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

        # Prepare for next phase
        set event(eventPhase) at_target

        }

        set event(currentNode) $token

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

        set event(eventPhase) bubbling_phase

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

        set event(dispatched) 1
    }

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

    }

    return $result
}

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

ret  dom::tcl::Node:create (type pVar , type args) {
    upvar #0 $pVar parent

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

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

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

    # Update parent node
    if {![info exists parent(document:documentElement)]} {
    lappend parent(node:childNodes) $child
    }

    proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

/*  dom::tcl::Node:set --*/
/* */
/*  Generic node update*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  Node modified.*/

ret  dom::tcl::Node:set (type token , type args) {
    upvar #0 $token node

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

    return {}
}

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

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

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

ret  dom::tcl::FireNodeInsertedEvents nodeid (
    type event , type postMutationEvent $, type nodeid , type DOMNodeInsertedIntoDocument
    , type foreach , type child [, type node , type children $, type nodeid] , optional 
    FireNodeInsertedEvents =$child
    

    , type return , optional 
)

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

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

    return {}
}

/*  dom::tcl::element --*/
/* */
/*  Functions for an element.*/
/* */
/*  Arguments:*/
/*  method  method to invoke*/
/*  token   token for node*/
/*  args    arguments for method*/
/* */
/*  Results:*/
/*  Depends on method used.*/

namespace dom::tcl {
    variable elementOptionsRO tagName|empty
    variable elementOptionsRW {}
}

ret  dom::tcl::element (type method , type token , type args) {
    variable elementOptionsRO
    variable elementOptionsRW

    upvar #0 $token node

    if {[string compare $node(node:nodeType) "element"]} {
    return -code error "malformed node token \"$token\""
    }
    set result {}

    switch -- $method {

    cget {
        # Some read-only configuration options are computed
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be \"dom::element cget token option\""
        }
        if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
        switch $option {
            tagName {
            set result [lindex $node(node:nodeName) 0]
            }
            empty {
            if {![info exists node(element:empty)]} {
                return 0
            } else {
                return $node(element:empty)
            }
            }
            default {
            return $node(node:$option)
            }
        }
        } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
        return $node(node:$option)
        } else {
        return -code error "bad option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [document cget $token [lindex $args 0]]
        } elseif {[expr [llength $args] % 2]} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
            return -code error "option \"$option\" cannot be modified"
            } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
            return -code error "not implemented"
            } else {
            return -code error "bad option \"$option\""
            }
        }
        }
    }

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

        set result {}

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

        return $result

    }

    setAttribute {
        if {[llength $args] != 2} {
        return -code error "wrong # args: should be \"dom::element setAttribute token name value\""
        }

        # Check that the attribute name is kosher
        if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
        return -code error "invalid attribute name \"[lindex $args 0]\""
        }

        upvar #0 $node(element:attributeList) attrList
        set evid [CreateEvent $token DOMAttrModified]
        set oldValue {}
        catch {set oldValue $attrList([lindex $args 0])}
        event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0] [expr {[info exists attrList([lindex $args 0])] ? "modification" : "addition"}]
        set result [set attrList([lindex $args 0]) [lindex $args 1]]
        node dispatchEvent $token $evid
        DOMImplementation destroy $evid

    }

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

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

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

    }

    getAttributeNS {
        if {[llength $args] != 2} {
        return -code error "wrong # args: should be \"dom::element getAttributeNS token ns name\""
        }

        set result {}
        upvar #0 $node(element:attributeList) attrList
        catch {set result $attrList([lindex $args 0]^[lindex $args 1])}

        return $result

    }

    setAttributeNS {
        if {[llength $args] != 3} {
        return -code error "wrong # args: should be \"dom::element setAttributeNS token ns attr value\""
        }

        # Check that the attribute name is kosher
        if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} {
        return -code error "invalid qualified attribute name \"[lindex $args 1]\""
        }

        # BUG: At the moment the prefix is ignored

        upvar #0 $node(element:attributeList) attrList
        set evid [CreateEvent $token DOMAttrModified]
        set oldValue {}
        catch {set oldValue $attrList([lindex $args 0]^$localName)}
        event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName [expr {[info exists attrList([lindex $args 0]^$localName)] ? "modification" : "addition"}]
        set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]]
        node dispatchEvent $token $evid
        DOMImplementation destroy $evid

    }

    removeAttributeNS {
        if {[llength $args] != 2} {
        return -code error "wrong # args: should be \"dom::element removeAttributeNS token ns name\""
        }

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

        event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1] -attrChange removal

    }

    getAttributeNode {
        array set tmp [array get $node(element:attributeList)]
        if {![info exists tmp([lindex $args 0])]} {
        return {}
        }

        # Synthesize an attribute node if one doesn't already exist
        array set attrNodes $node(element:attributeNodes)
        if {[catch {set result $attrNodes([lindex $args 0])}]} {
        set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])]
        lappend node(element:attributeNodes) [lindex $args 0] $result
        }
    }

    setAttributeNode -
    removeAttributeNode -
    getAttributeNodeNS -
    setAttributeNodeNS -
    removeAttributeNodeNS {
        return -code error "not yet implemented"
    }

    getElementsByTagName {
        if {[llength $args] < 1} {
        return -code error "wrong # args: should be \"dom::element getElementsByTagName token name\""
        }

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

    normalize {
        if {[llength $args]} {
        return -code error "wrong # args: should be dom::element normalize token"
        }

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

    default {
        return -code error "bad method \"$method\": should be cget, configure, getAttribute, setAttribute, removeAttribute, getAttributeNS, setAttributeNS, removeAttributeNS, getAttributeNode, setAttributeNode, removeAttributeNode, getAttributeNodeNS, setAttributeNodeNS, removeAttributeNodeNS, getElementsByTagName or normalize"
    }

    }

    return $result
}

/*  dom::tcl::Element:GetByTagName --*/
/* */
/*  Search for (child) elements*/
/* */
/*  This used to be non-recursive, but then I read the DOM spec*/
/*  properly and discovered that it should recurse.  The -deep*/
/*  option allows for backward-compatibility, and defaults to the*/
/*  DOM-specified value of true.*/
/* */
/*  Arguments:*/
/*  token   parent node*/
/*  name    element type to search for*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  The name of the variable containing the list of matching node tokens*/

ret  dom::tcl::Element:GetByTagName (type token , type name , type args) {
    upvar #0 $token node
    upvar #0 [namespace qualifiers $token]::Document document

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

    # Guard against arbitrary glob characters
    # Checking that name is a legal XML Name does this
    # However, '*' is permitted
    if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} {
    return -code error "invalid element name"
    }

    # Allocate variable name for this search
    set searchVar ${token}search[incr document(counter)]
    upvar \#0 $searchVar search

    # Make list live by interposing on variable reads
    # I don't think we need to interpose on unsets,
    # and writing to this variable by the application is
    # not permitted.

    trace variable $searchVar w [namespace code Element:GetByTagName:Error]

    if {[string compare $node(node:nodeType) "document"]} {
    trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]]
    } elseif {[llength $node(document:documentElement)]} {
    # Document Element must exist and must be an element type node
    trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]]
    }

    return $searchVar
}

/*  dom::tcl::Element:GetByTagName:Search --*/
/* */
/*  Search for elements.  This does the real work.*/
/*  Because this procedure is invoked everytime*/
/*  the variable is read, it returns the live list.*/
/* */
/*  Arguments:*/
/*  tokens  nodes to search (inclusive)*/
/*  name    element type to search for*/
/*  deep    whether to search recursively*/
/*  name1   \*/
/*  name2    > appended by trace command*/
/*  op  /*/
/* */
/*  Results:*/
/*  List of matching node tokens*/

ret  dom::tcl::Element:GetByTagName:Search (type tokens , type name , type deep , type name1 , type name2 , type op) {
    set result {}

    foreach tok $tokens {
    upvar #0 $tok nodeInfo
    switch -- $nodeInfo(node:nodeType) {
        element {
        if {[string match $name [GetField nodeInfo(node:nodeName)]]} {
            lappend result $tok
        }
        if {$deep} {
            set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}]
            if {[llength $childResult]} {
            eval lappend result $childResult
            }
        }
        }
    }
    }

    if {[string length $name1]} {
    set $name1 $result
    return {}
    } else {
    return $result
    }
}

/*  dom::tcl::Element:GetByTagName:Error --*/
/* */
/*  Complain about the application writing to a variable*/
/*  that this package maintains.*/
/* */
/*  Arguments:*/
/*  name1   \*/
/*  name2    > appended by trace command*/
/*  op  /*/
/* */
/*  Results:*/
/*  Error code returned.*/

ret  dom::tcl::Element:GetByTagName:Error (type name1 , type name2 , type op) {
    return -code error "dom: Read-only variable"
}

/*  dom::tcl::Element:Normalize --*/
/* */
/*  Normalize the text nodes*/
/* */
/*  Arguments:*/
/*  pVar    parent array variable in caller*/
/*  nodes   list of node tokens*/
/* */
/*  Results:*/
/*  Adjacent text nodes are coalesced*/

ret  dom::tcl::Element:Normalize (type pVar , type nodes) {
    upvar #0 $pVar parent

    set textNode {}

    foreach n $nodes {
    upvar #0 $n child
    set cleanup {}

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

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

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

            set $textNode [array get text]
        } else {
            set textNode $n
            catch {unset text}
            array set text [array get child]
        }
        }
        element -
        document -
        documentFragment {
        set textNode {}
        Element:Normalize child [set $child(node:childNodes)]
        }
        default {
        set textNode {}
        }
    }

    eval $cleanup
    }

    return {}
}

/*  dom::tcl::processinginstruction --*/
/* */
/*  Functions for a processing intruction.*/
/* */
/*  Arguments:*/
/*  method  method to invoke*/
/*  token   token for node*/
/*  args    arguments for method*/
/* */
/*  Results:*/
/*  Depends on method used.*/

namespace dom::tcl {
    variable piOptionsRO target
    variable piOptionsRW data
}

ret  dom::tcl::processinginstruction (type method , type token , type args) {
    variable piOptionsRO
    variable piOptionsRW

    upvar #0 $token node

    set result {}

    switch -- $method {

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

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

    }

    return $result
}

/* */
/* */
/*  DOM Level 2 Interfaces*/
/* */
/* */

/*  dom::tcl::event --*/
/* */
/*  Implements Event Interface*/
/* */
/*  Subclassed Interfaces are also defined here,*/
/*  such as UIEvents.*/
/* */
/*  Arguments:*/
/*  method  method to invoke*/
/*  token   token for event*/
/*  args    arguments for method*/
/* */
/*  Results:*/
/*  Depends on method used.*/

namespace dom::tcl {
    variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName|attrChange
    variable eventOptionsRW {}

    /*  Issue: should the attributes belonging to the subclassed Interface*/
    /*  be separated out?*/

    variable uieventOptionsRO detail|view
    variable uieventOptionsRW {}

    variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode
    variable mouseeventOptionsRW {}

    variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName
    variable mutationeventOptionsRW {}
}

ret  dom::tcl::event (type method , type token , type args) {
    variable eventOptionsRO
    variable eventOptionsRW

    upvar #0 $token event

    set result {}

    switch -glob -- $method {

    cg* {
        # cget

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

    co* {
        # configure

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

    }

    st* {
        # stopPropagation

        set event(stopPropagation) 1
    }

    pr* {
        # preventDefault

        set event(preventDefault) 1
    }

    initE* {
        # initEvent

        if {[llength $args] != 3} {
        return -code error "wrong # args: should be dom::event initEvent token type bubbles cancelable"
        }

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

        foreach {event(type) event(bubbles) event(cancelable)} $args break
    }

    initU* {
        # initUIEvent

        if {[llength $args] < 4 || [llength $args] > 5} {
        return -code error "wrong # args: should be dom::event initUIEvent token type bubbles cancelable view detail"
        }

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

        set event(detail) 0
        foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break
    }

    initMo* {
        # initMouseEvent

        if {[llength $args] != 15} {
        return -code error "wrong # args: should be dom::event initMouseEvent token type bubbles cancelable view detail screenX screenY clientX clientY ctrlKey altKey shiftKey metaKey button relatedNode"
        }

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

        set event(detail) 1
        foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail) event(screenX) event(screenY) event(clientX) event(clientY) event(ctrlKey) event(altKey) event(shiftKey) event(metaKey) event(button) event(relatedNode)} $args break
    }

    initMu* {
        # initMutationEvent

        if {[llength $args] != 8} {
        return -code error "wrong # args: should be dom::event initMutationEvent token type bubbles cancelable relatedNode prevValue newValue attrName attrChange"
        }

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

        foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName) event(attrChange)} $args break
    }

    postUI* {
        # postUIEvent, non-standard convenience method

        set evType [lindex $args 0]
        array set evOpts [list \
            -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)   \
            -view {}            \
            -detail {}          \
        ]
        array set evOpts [lrange $args 1 end]

        set evid [CreateEvent $token $evType]
        event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail)
        node dispatchEvent $token $evid
        DOMImplementation destroy $evid

    }

    postMo* {
        # postMouseEvent, non-standard convenience method

        set evType [lindex $args 0]
        array set evOpts [list \
            -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)   \
            -view {}            \
            -detail {}          \
            -screenX {}         \
            -screenY {}         \
            -clientX {}         \
            -clientY {}         \
            -ctrlKey {}         \
            -altKey {}          \
            -shiftKey {}        \
            -metaKey {}         \
            -button {}          \
            -relatedNode {}     \
        ]
        array set evOpts [lrange $args 1 end]

        set evid [CreateEvent $token $evType]
        event initMouseEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) $evOpts(-screenX) $evOpts(-screenY) $evOpts(-clientX) $evOpts(-clientY) $evOpts(-ctrlKey) $evOpts(-altKey) $evOpts(-shiftKey) $evOpts(-metaKey) $evOpts(-button) $evOpts(-relatedNode)
        node dispatchEvent $token $evid
        DOMImplementation destroy $evid

    }

    postMu* {
        # postMutationEvent, non-standard convenience method

        set evType [lindex $args 0]
        array set evOpts [list \
            -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType)   \
            -relatedNode {}         \
            -prevValue {} -newValue {}      \
            -attrName {} -attrChange {}     \
        ]
        array set evOpts [lrange $args 1 end]

        set evid [CreateEvent $token $evType]
        event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName) $evOpts(-attrChange)
        node dispatchEvent $token $evid
        DOMImplementation destroy $evid

    }

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

    return $result
}

/*  dom::tcl::CreateEvent --*/
/* */
/*  Create an event object*/
/* */
/*  Arguments:*/
/*  token   parent node*/
/*  type    event type*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  Returns event token*/

ret  dom::tcl::CreateEvent (type token , type type , type args) {
    array set opts $args
    if {[string length $token]} {
    upvar #0 $token parent
    upvar #0 [namespace qualifiers $token]::Document document
    set child [namespace qualifiers $token]::event[incr document(counter)]
    } elseif {[info exists $opts(-document)]} {
    upvar #0 $opts(-document) document
    set child [namespace qualifiers $opts(-document)]::event[incr document(counter)]
    }

    upvar #0 $child event

    # Create the event
    array set event [list \
        node:nodeType event \
        type $type      \
        target {}       \
        currentNode {}  \
        cancelable 1    \
        stopPropagation 0   \
        preventDefault 0    \
        dispatched 0    \
        bubbles 1       \
        eventPhase {}   \
        timeStamp [clock clicks -milliseconds]  \
        ]

    proc $child {method args} "return \[eval [namespace current]::event \[list \$method\] $child \$args\]"
    trace add command $child delete [namespace code [list Node:Delete $child]]

    return $child
}

/* */
/* */
/*  Serialisation*/
/* */
/* */

/*  dom::tcl::Serialize:documentFragment --*/
/* */
/*  Produce text for documentFragment.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:documentFragment (type token , type args) {
    upvar #0 $token node

    if {[string compare "Document" [namespace tail $token]]} {
    return [eval [list Serialize:node $token] $args]
    } else {
    if {[string compare {} [GetField node(document:documentElement)]]} {
        return [eval Serialize:document [list $token] $args]
    } else {
        return -code error "document has no document element"
    }
    }

}

/*  dom::tcl::Serialize:document --*/
/* */
/*  Produce text for document.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:document (type token , type args) {
    upvar #0 $token node
    array set opts {
    -showxmldecl 1
    -showdoctypedecl 1
    }
    array set opts $args

    set result {}

    if {[string length $node(document:doctype)]} {

    upvar #0 $node(document:doctype) doctype

    # Bug fix: can't use Serialize:attributeList for XML declaration,
    # since attributes must occur in a given order (XML 2.8 [23])

    set result {}

    if {$opts(-showxmldecl)} {
        append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n
    }
    if {$opts(-showdoctypedecl)} {
        # Is document element in an XML Namespace?
        # If so then include prefix in doctype decl
        foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break
        if {![string length $prefix]} {
        # The prefix may not have been allocated yet
        upvar #0 $node(document:documentElement) docel
        if {[info exists docel(node:namespaceURI)] && \
            [string length $docel(node:namespaceURI)]} {
            set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)]
            set docelName $declPrefix:$doctype(doctype:name)
        } else {
            set docelName $doctype(doctype:name)
        }
        } else {
        set docelName $doctype(doctype:name)
        }
        # Applied patch by Marco Gonnelli, bug #590914
        append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:publicId) $doctype(doctype:systemId)][expr {[string length $doctype(doctype:internalSubset)] ? " \[[string trim $doctype(doctype:internalSubset) \{\} ]\]" : {}}]>\n
    }
    }

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

    if {[info exists $node(node:childNodes)]} {
    foreach child [set $node(node:childNodes)] {
        append result [eval Serialize:[node cget $child -nodeType] [list $child] $args]
    }
    }

    return $result
}

/*  dom::tcl::Serialize:ExternalID --*/
/* */
/*  Returned appropriately quoted external identifiers*/
/* */
/*  Arguments:*/
/*  publicid    public identifier*/
/*  systemid    system identifier*/
/* */
/*  Results:*/
/*  text*/

ret  dom::tcl::Serialize:ExternalID (type publicid , type systemid) {

    switch -glob -- [string length $publicid],[string length $systemid] {
    0,0 {
        return {}
    }
    0,* {
        return " SYSTEM \"$systemid\""
    }
    *,* {
        # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
        return " PUBLIC \"$publicid\" \"$systemid\""
    }
    }

    return {}
}

/*  dom::tcl::Serialize:XMLDecl --*/
/* */
/*  Produce text for XML Declaration attribute.*/
/*  Order is determine by document serialisation procedure.*/
/* */
/*  Arguments:*/
/*  attr    required attribute*/
/*  attList attribute list*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:XMLDecl (type attr , type attrList) {
    array set data $attrList
    if {![info exists data($attr)]} {
    return {}
    } elseif {[string length $data($attr)]} {
    return " $attr='$data($attr)'"
    } else {
    return {}
    }
}

/*  dom::tcl::Serialize:node --*/
/* */
/*  Produce text for an arbitrary node.*/
/*  This simply serializes the child nodes of the node.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:node (type token , type args) {
    upvar #0 $token node
    array set opts $args

    if {[info exists opts(-indent)]} {
    # NB. 0|1 cannot be used as booleans - mention this in docn
    if {[regexp {^false|no|off$} $opts(-indent)]} {
        # No action required
    } elseif {[regexp {^true|yes|on$} $opts(-indent)]} {
        set opts(-indent) 1
    } else {
        incr opts(-indent)
    }
    }

    set result {}
    foreach childToken [set $node(node:childNodes)] {
    upvar #0 $childToken child
    append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]]
    }

    return $result
}

/*  dom::tcl::Serialize:element --*/
/* */
/*  Produce text for an element.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:element (type token , type args) {
    upvar #0 $token node
    array set opts {-newline {}}
    array set opts $args

    set result {}
    set newline {}
    if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
    append result \n
    set newline \n
    }
    append result [eval Serialize:Indent [array get opts]]
    switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] {

    1,1 {
        # XML Namespace is in scope, prefix supplied
        if {[string length $node(node:prefix)]} {
        # Make sure that there's a declaration for this XML Namespace
        set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)]
        # ASSERTION: $declPrefix == $node(node:prefix)
        set nsPrefix $node(node:prefix):
        } elseif {[string length $node(node:namespaceURI)]} {
        set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
        } else {
        set nsPrefix {}
        }
    }

    1,0 {
        # XML Namespace is in scope, no prefix
        set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
        if {![string compare $nsPrefix :]} {
        set nsPrefix {}
        }
    }

    0,1 {
        # Internal error
        set nsPrefix {}
    }

    0,0 -
    default {
        # No XML Namespace is in scope
        set nsPrefix {}
    }
    }
    append result <$nsPrefix$node(node:localName)

    append result [Serialize:attributeList [array get $node(element:attributeList)]]

    if {![llength [set $node(node:childNodes)]]} {

    append result />$newline

    } else {

    append result >$newline

    # Do the children
    if {[hasmixedcontent $token]} {
        set opts(-indent) no
    }
    append result [eval Serialize:node [list $token] [array get opts]]

    append result [eval Serialize:Indent [array get opts]]
    append result "$newline</$nsPrefix$node(node:localName)>$newline"

    }

    return $result
}

/*  dom::tcl::GetNamespacePrefix --*/
/* */
/*  Determine the XML Namespace prefix for a Namespace URI*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  nsuri   XML Namespace URI*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  Returns prefix.*/
/*  May add prefix information to node*/

ret  dom::tcl::GetNamespacePrefix (type token , type nsuri , type args) {
    upvar #0 $token node
    array set options $args

    GetNamespaceDecl $token $nsuri declNode prefix

    if {[llength $declNode]} {
    # A declaration was found for this Namespace URI
    return $prefix
    } else {
    # No declaration found.  Allocate a prefix
    # and add XML Namespace declaration
    set prefix {}
    catch {set prefix $options(-prefix)}
    if {![string compare $prefix {}]} {
        upvar #0 [namespace qualifiers $token]::Document document
        set prefix ns[incr document(counter)]
    }
    set node(node:prefix) $prefix
    upvar \#0 $node(element:attributeList) attrs
    set attrs(${::dom::xmlnsURI}^$prefix) $nsuri

    return $prefix
    }
}

/*  dom::tcl::GetNamespaceDecl --*/
/* */
/*  Find the XML Namespace declaration.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  nsuri   XML Namespace URI*/
/*  nodeVar Variable name for declaration*/
/*  prefVar Variable for prefix*/
/* */
/*  Results:*/
/*  If the declaration is found returns node and prefix*/

ret  dom::tcl::GetNamespaceDecl (type token , type nsuri , type nodeVar , type prefVar) {
    upvar #0 $token node
    upvar $nodeVar declNode
    upvar $prefVar prefix

    while {[string length $node(node:parentNode)]} {

    # Check this node's XML Namespace declarations
    catch {unset attrs}
    array set attrs [array get $node(element:attributeList)]
    foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] {
        if {![string compare $decluri $nsuri]} {
        regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix
        set declNode $token
        return
        }
    }

    # Move up to parent
    set token $node(node:parentNode)
    upvar #0 $token node
    }

    # Got to Document node and didn't find XML NS decl
    set prefix {}
    set declNode {}
}

/*  dom::tcl::Serialize:textNode --*/
/* */
/*  Produce text for a text node.  This procedure may*/
/*  return a CDATA section where appropriate.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:textNode (type token , type args) {
    upvar #0 $token node

    if {$node(node:cdatasection)} {
    return [Serialize:CDATASection $node(node:nodeValue)]
    } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} {
    return [Serialize:CDATASection $node(node:nodeValue)]
    } else {
    return [Encode $node(node:nodeValue)]
    }
}

/*  dom::tcl::Serialize:ExceedsThreshold --*/
/* */
/*  Applies heuristic(s) to determine whether a text node*/
/*  should be formatted as a CDATA section.*/
/* */
/*  Arguments:*/
/*  text    node text*/
/* */
/*  Results:*/
/*  Boolean.*/

ret  dom::tcl::Serialize:ExceedsThreshold (type text) {
    return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}]
}

/*  dom::tcl::Serialize:CDATASection --*/
/* */
/*  Formats a CDATA section.*/
/* */
/*  Arguments:*/
/*  text    node text*/
/* */
/*  Results:*/
/*  XML text.*/

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

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

ret  dom::tcl::Serialize:processingInstruction (type token , type args) {
    upvar #0 $token node

    return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>"
}

/*  dom::tcl::Serialize:comment --*/
/* */
/*  Produce text for a comment node.*/
/* */
/*  Arguments:*/
/*  token   node token*/
/*  args    configuration options*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Serialize:comment (type token , type args) {
    upvar #0 $token node

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

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

ret  dom::tcl::Serialize:entityReference (type token , type args) {
    upvar #0 $token node

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

/*  dom::tcl::Encode --*/
/* */
/*  Encode special characters*/
/* */
/*  Arguments:*/
/*  value   text value*/
/* */
/*  Results:*/
/*  XML format text.*/

ret  dom::tcl::Encode value (
    type array , type set , type Entity , optional 
    $ =$
    < =&lt;
    > =&gt;
    & =&amp;
    \" =&quot;
    ' =&apos;
    

    , type regsub -, type all , optional ([$<>&"']) $, type value , optional $Entity(\1) , type value

    , type return [, type subst -, type nocommand -, type nobackslash $, type value]
)

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

proc dom::tcl::Serialize:attributeList {l} {

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

    if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} {
        if {[string compare $nsuri $::dom::xmlnsURI]} {
        /*  Need the node token to resolve the Namespace URI*/
        append result { } ?:$prefix =
        } else {
        /*  A Namespace declaration*/
        append result { } xmlns:$prefix =
        }
    } else {
        append result { } $name =
    }

    /*  Handle special characters*/
    regsub -all & $value {\&amp;} value
    regsub -all < $value {\&lt;} value

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

    }

    return $result
}

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

ret  dom::tcl::Serialize:Indent args (
    type array , type set , type opts [, type list -, type indentspec $::, type dom::, type indentspec]
    , type array , type set , type opts $, type args

    , type if , optional ![info =exists opts(-indent)] =|| \
        =[regexp {^false|no|off$ $, type opts(-, type indent)]) {
    return {}
    }

    if {[regexp {^true|yes|on$} $opts(-indent)]} {
    /*  Default indent level is 0*/
    return \n
    }

    if {!$opts(-indent)} {
    return \n
    }

     ws =  [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }]
    regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws

    return $ws

}

/* */
/* */
/*  Parsing*/
/* */
/* */

/*  dom::tcl::ParseElementStart --*/
/* */
/*  Push a new element onto the stack.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  name        element name*/
/*  attrList    attribute list*/
/*  args        configuration options*/
/* */
/*  Results:*/
/*  An element is created within the currently open element.*/

ret  dom::tcl::ParseElementStart (type stateVar , type name , type attrList , type args) {

    upvar #0 $stateVar state
    array set opts $args

    # Push namespace declarations
    # We need to be able to map namespaceURI's back to prefixes
    set nsattrlists {}
    catch {
    foreach {namespaceURI prefix} $opts(-namespacedecls) {
        lappend state(NS:$namespaceURI) $prefix

        # Also, synthesize namespace declaration attributes
        # TclXML is a little too clever when it parses them away!

        lappend nsattrlists $prefix $namespaceURI
    }
    lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists

    }

    set nsarg {}
    catch {
    lappend nsarg -namespace $opts(-namespace)
    lappend nsarg -localname $name
    lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end]
    }

    lappend state(current) \
    [eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]]

    if {[info exists opts(-empty)] && $opts(-empty)} {
    # Flag this node as being an empty element
    upvar #0 [lindex $state(current) end] node
    set node(element:empty) 1
    }

    # Temporary: implement -progresscommand here, because of broken parser
    if {[string length $state(-progresscommand)]} {
    if {!([incr state(progCounter)] % $state(-chunksize))} {
        uplevel #0 $state(-progresscommand)
    }
    }
}

/*  dom::tcl::ParseElementEnd --*/
/* */
/*  Pop an element from the stack.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  name        element name*/
/*  args        configuration options*/
/* */
/*  Results:*/
/*  Currently open element is closed.*/

ret  dom::tcl::ParseElementEnd (type stateVar , type name , type args) {
    upvar #0 $stateVar state

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

/*  dom::tcl::ParseCharacterData --*/
/* */
/*  Add a textNode to the currently open element.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  data        character data*/
/* */
/*  Results:*/
/*  A textNode is created.*/

ret  dom::tcl::ParseCharacterData (type stateVar , type data) {
    upvar #0 $stateVar state

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

/*  dom::tcl::ParseProcessingInstruction --*/
/* */
/*  Add a PI to the currently open element.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  name        PI name*/
/*  target      PI target*/
/* */
/*  Results:*/
/*  A processingInstruction node is created.*/

ret  dom::tcl::ParseProcessingInstruction (type stateVar , type name , type target) {
    upvar #0 $stateVar state

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

/*  dom::tcl::ParseXMLDeclaration --*/
/* */
/*  Add information from the XML Declaration to the document.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  version     version identifier*/
/*  encoding    character encoding*/
/*  standalone  standalone document declaration*/
/* */
/*  Results:*/
/*  Document node modified.*/

ret  dom::tcl::ParseXMLDeclaration (type stateVar , type version , type encoding , type standalone) {
    upvar #0 $stateVar state

    upvar #0 $state(docNode) document
    array set xmldecl $document(document:xmldecl)

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

    set document(document:xmldecl) [array get xmldecl]

    return {}
}

/*  dom::tcl::ParseDocType --*/
/* */
/*  Add a Document Type Declaration node to the document.*/
/* */
/*  Arguments:*/
/*  stateVar    global state array variable*/
/*  root        root element type*/
/*  publit      public identifier literal*/
/*  systemlist  system identifier literal*/
/*  dtd     internal DTD subset*/
/* */
/*  Results:*/
/*  DocType node added*/

ret  dom::tcl::ParseDocType (type stateVar , type root , optional publit ={) {systemlit {}} {dtd {}} args} {
    upvar /* 0 $stateVar state*/
    upvar /* 0 $state(docNode) document*/

     document = (document:doctype) [CreateDocType $state(docNode) $publit $systemlit $dtd]

    return {}
}

/*  dom::tcl::ParseComment --*/
/* */
/*  Parse comment*/
/* */
/*  Arguments:*/
/*  stateVar    state array*/
/*  data        comment data*/
/* */
/*  Results:*/
/*  Comment node added to DOM tree*/

ret  dom::tcl::ParseComment (type stateVar , type data) {
    upvar #0 $stateVar state

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

    return {}
}

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

ret  dom::tcl::ParseEntityReference (type stateVar , type ref) {
    upvar #0 $stateVar state

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

    return {}
}

/* */
/* */
/*  Trim white space*/
/* */
/* */

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

ret  dom::tcl::Trim nodeid (
    type upvar #0 $, type nodeid , type node

    , type switch $, type node(, type node:, type nodeType) , optional 

    textNode ={
        if ={![string length =[string trim =$node(node:nodeValue)]] , optional 
        node =removeChild $node(node:parentNode) =$nodeid
        
    )

    default {
        # Some nodes have no child list.  Reported by Jim Hollister <jhollister@objectspace.com>
        set children {}
        catch {set children [set $node(node:childNodes)]}
        foreach child $children {
        Trim $child
        }
    }

    }

    return {}
}

/* */
/* */
/*  XPath support*/
/* */
/* */

/*  dom::tcl::XPath:CreateNode --*/
/* */
/*  Given an XPath expression, create the node*/
/*  referred to by the expression.  Nodes required*/
/*  as steps of the path are created if they do*/
/*  not exist.*/
/* */
/*  Arguments:*/
/*  node    context node*/
/*  path    location path*/
/* */
/*  Results:*/
/*  Node(s) created in the DOM tree.*/
/*  Returns token for deepest node in the expression.*/

ret  dom::tcl::XPath:CreateNode (type node , type path) {

    set root [::dom::node cget $node -ownerDocument]

    set spath [::xpath::split $path]

    if {[llength $spath] <= 1} {
    # / - do nothing
    return $root
    }

    if {![llength [lindex $spath 0]]} {
    # Absolute location path
    set context $root
    set spath [lrange $spath 1 end]
    set contexttype document
    } else {
    set context $node
    set contexttype [::dom::node cget $node -nodeType]
    }

    foreach step $spath {

    # Sanity check on path
    switch $contexttype {
        document -
        documentFragment -
        element {}
        default {
        return -code error "node type \"$contexttype\" have no children"
        }
    }

    switch [lindex $step 0] {

        child {
        if {[llength [lindex $step 1]] > 1} {
            foreach {nodetype discard} [lindex $step 1] break

            switch -- $nodetype {
            text {
                set posn [CreateNode:FindPosition [lindex $step 2]]

                set count 0
                set targetNode {}
                foreach child [::dom::node children $context] {
                switch [::dom::node cget $child -nodeType] {
                    textNode {
                    incr count
                    if {$count == $posn} {
                        set targetNode $child
                        break
                    }
                    }
                    default {}
                }
                }

                if {[string length $targetNode]} {
                set context $targetNode
                } else {
                # Creating sequential textNodes doesn't make sense
                set context [::dom::document createTextNode $context {}]
                }
                set contexttype textNode
            }
            default {
                return -code error "node type test \"${nodetype}()\" not supported"
            }
            }
        } else {
            # Find the child element
            set posn [CreateNode:FindPosition [lindex $step 2]]

            set count 0
            set targetNode {}
            foreach child [::dom::node children $context] {
            switch [node cget $child -nodeType] {
                element {
                if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} {
                    incr count
                    if {$count == $posn} {
                    set targetNode $child
                    break
                    }
                }
                }
                default {}
            }
            }

            if {[string length $targetNode]} {
            set context $targetNode
            } else {
            # Didn't find it so create required elements
            while {$count < $posn} {
                set child [::dom::document createElement $context [lindex $step 1]]
                incr count
            }
            set context $child
            }
            set contexttype element

        }
        }

        default {
        return -code error "axis \"[lindex $step 0]\" is not supported"
        }
    }
    }

    return $context
}

/*  dom::tcl::CreateNode:FindPosition --*/

ret  dom::tcl::CreateNode:FindPosition predicates (
    type switch [, type llength $, type predicates] , optional 
    0 ={
        return =1
    
    1 , optional 
        # =Fall-through
    
    , type default , optional 
        return =-code error ="multiple predicates =not yet =supported"
    
    )
    set predicate [lindex $predicates 0]

    switch -- [lindex [lindex $predicate 0] 0] {
    function {
        switch -- [lindex [lindex $predicate 0] 1] {
        position {
            if {[lindex $predicate 1] == "="} {
            if {[string compare [lindex [lindex $predicate 2] 0] "number"]} {
                return -code error "operand must be a number"
            } else {
                set posn [lindex [lindex $predicate 2] 1]
            }
            } else {
            return -code error "operator must be \"=\""
            }
        }
        default {
            return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported"
        }
        }
    }
    default {
        return -code error "predicate must be position() function"
    }
    }

    return $posn
}

/*  dom::tcl::XPath:SelectNode --*/
/* */
/*  Match nodes with an XPath location path*/
/* */
/*  Arguments:*/
/*  ctxt    context - Tcl list*/
/*  path    location path*/
/* */
/*  Results:*/
/*  Returns Tcl list of matching nodes*/

ret  dom::tcl::XPath:SelectNode (type ctxt , type path) {

    if {![llength $ctxt]} {
    return {}
    }

    set spath [xpath::split $path]

    if {[string length [node parent [lindex $ctxt 0]]]} {
    set root [namespace qualifiers [lindex $ctxt 0]]::Document
    } else {
    set root [lindex $ctxt 0]
    }

    if {[llength $spath] == 0} {
    return $root
    }
    if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} {
    return $root
    }

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

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

/*  dom::tcl::XPath:SelectNode:Rel --*/
/* */
/*  Match nodes with an XPath location path*/
/* */
/*  Arguments:*/
/*  ctxt    context - Tcl list*/
/*  path    split location path*/
/* */
/*  Results:*/
/*  Returns Tcl list of matching nodes*/

ret  dom::tcl::XPath:SelectNode:Rel (type ctxt , type spath) {
    if {![llength $spath]} {
    return $ctxt
    }

    set step [lindex $spath 0]
    set result {}
    switch [lindex $step 0] {

    child {
        # All children are candidates
        set children {}
        foreach node [XPath:SN:GetElementTypeNodes $ctxt] {
        eval lappend children [node children $node]
        }

        # Now apply node test to each child
        foreach node $children {
        if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
            lappend result $node
        }
        }

    }

    descendant-or-self {
        foreach node $ctxt {
        if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
            lappend result $node
        }
        eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
        }
    }

    descendant {
        foreach node $ctxt {
        eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
        }
    }

    attribute {
        if {[string compare [lindex $step 1] "*"]} {
        foreach node $ctxt {
            set attrNode [element getAttributeNode $node [lindex $step 1]]
            if {[llength $attrNode]} {
            lappend result $attrNode
            }
        }
        } else {
        # All attributes are returned
        foreach node $ctxt {
            foreach attrName [array names [node cget $node -attributes]] {
            set attrNode [element getAttributeNode $node $attrName]
            if {[llength $attrNode]} {
                lappend result $attrNode
            }
            }
        }
        }
    }

    default {
        return -code error "axis \"[lindex $step 0]\" is not supported"
    }
    }

    # Now apply predicates
    set result [XPath:ApplyPredicates $result [lindex $step 2]]

    # Apply the next location step
    return [XPath:SelectNode:Rel $result [lrange $spath 1 end]]
}

/*  dom::tcl::XPath:SN:GetElementTypeNodes --*/
/* */
/*  Reduce nodeset to those nodes of element type*/
/* */
/*  Arguments:*/
/*  nodeset set of nodes*/
/* */
/*  Results:*/
/*  Returns nodeset in which all nodes are element type*/

ret  dom::tcl::XPath:SN:GetElementTypeNodes nodeset (
    type set , type result , optional 
    , type foreach , type node $, type nodeset , optional 
    switch =[node cget =$node -nodeType] ={
        document =-
        documentFragment =-
        element ={
        lappend =result $node
        
        , type default , optional 
    )
    }
    return $result
}

# dom::tcl::XPath:SN:ApplyNodeTest --
#
#   Apply the node test to a node
#
# Arguments:
#   node    DOM node to test
#   test    node test
#
# Results:
#   1 if node passes, 0 otherwise

proc dom::tcl::XPath:SN:ApplyNodeTest {node test} {
    if {[llength $test] > 1} {
    foreach {name typetest} $test break
    /*  Node type test*/
    switch -glob -- $name,[node cget $node -nodeType] {
        node,* {
        return 1
        }
        text,textNode -
        comment,comment -
        ret essing-instruction,processingInstruction (
        type return 1
        )
        text,* -
        comment,* -
        processing-instruction,* {
        return 0
        }
        default {
        return -code error "illegal node type test \"[lindex $step 1]\""
        }
    }
    } else {
    /*  Node name test*/
    switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] \
        \\*,element,* {
        return 1
    } \
        \\*,* {
        return 0
    } \
        *,element,$test {
        return 1
    }
    }

    return 0
}

/*  dom::tcl::XPath:SN:DescendAndTest --*/
/* */
/*  Descend the element hierarchy,*/
/*  apply the node test as we go*/
/* */
/*  Arguments:*/
/*  nodeset nodes to be tested and descended*/
/*  test    node test*/
/* */
/*  Results:*/
/*  Returned nodeset of nodes which pass the test*/

ret  dom::tcl::XPath:SN:DescendAndTest (type nodeset , type test) {
    set result {}

    foreach node $nodeset {
    if {[XPath:SN:ApplyNodeTest $node $test]} {
        lappend result $node
    }
    switch [node cget $node -nodeType] {
        document -
        documentFragment -
        element {
        eval lappend result [XPath:SN:DescendAndTest [node children $node] $test]
        }
    }
    }

    return $result
}

/*  dom::tcl::XPath:ApplyPredicates --*/
/* */
/*  Filter a nodeset with predicates*/
/* */
/*  Arguments:*/
/*  ctxt    current context nodeset*/
/*  preds   list of predicates*/
/* */
/*  Results:*/
/*  Returns new (possibly reduced) context nodeset*/

ret  dom::tcl::XPath:ApplyPredicates (type ctxt , type preds) {

    set result {}
    foreach node $ctxt {
    set passed 1
    foreach predicate $preds {
        if {![XPath:ApplyPredicate $node $predicate]} {
        set passed 0
        break
        }
    }
    if {$passed} {
        lappend result $node
    }
    }

    return $result
}

/*  dom::tcl::XPath:ApplyPredicate --*/
/* */
/*  Filter a node with a single predicate*/
/* */
/*  Arguments:*/
/*  node    current context node*/
/*  pred    predicate*/
/* */
/*  Results:*/
/*  Returns boolean*/

ret  dom::tcl::XPath:ApplyPredicate (type node , type pred) {

    switch -- [lindex $pred 0] {
    = -
    != -
    >= -
    <= -
    > -
    > {

        if {[llength $pred] != 3} {
        return -code error "malformed expression"
        }

        set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]]
        set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]]

        # Convert operands to the correct type, if necessary
        switch -glob [lindex $operand1 0],[lindex $operand2 0] {
        literal,literal {
            return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
        }

        number,number -
        literal,number -
        number,literal {
            # Compare as numbers
            return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
        }

        boolean,boolean {
            # Compare as booleans
            return -code error "boolean comparison not yet implemented"
        }

        node,node {
            # Nodeset comparison
            return -code error "nodeset comparison not yet implemented"
        }

        node,* {
            set value {}
            if {[llength [lindex $operand1 1]]} {
            set value [node stringValue [lindex [lindex $operand1 1] 0]]
            }
            return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]]
        }
        *,node {
            set value {}
            if {[llength [lindex $operand2 1]]} {
            set value [node stringValue [lindex [lindex $operand2 1] 0]]
            }
            return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]]
        }

        default {
            return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]"
        }
        }
    }

    function {
        return -code error "invalid predicate"
    }
    number -
    literal {
        return -code error "invalid predicate"
    }

    path {
        set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]]
        return [expr {[llength $nodeset] > 0 ? 1 : 0}]
    }

    }

    return 1
}

/*  dom::tcl::XPath:Pred:Compare --*/

ret  dom::tcl::XPath:Pred:CompareLiterals (type op , type operand1 , type operand2) {
    set result [string compare $operand1 $operand2]

    # The obvious:
    #return [expr {$result $opMap($op) 0}]
    # doesn't compile
    
    switch $op {
    = {
        return [expr {$result == 0}]
    }
    != {
        return [expr {$result != 0}]
    }
    <= {
        return [expr {$result <= 0}]
    }
    >= {
        return [expr {$result >= 0}]
    }
    < {
        return [expr {$result < 0}]
    }
    > {
        return [expr {$result > 0}]
    }
    }
    return -code error "internal error"
}

/*  dom::tcl::XPath:Pred:ResolveExpr --*/

ret  dom::tcl::XPath:Pred:ResolveExpr (type node , type expr) {

    switch [lindex $expr 0] {
    path {
        return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]]
    }

    function -
    group {
        return -code error "[lindex $expr 0] not yet implemented"
    }
    literal -
    number -
    boolean {
        return $expr
    }

    default {
        return -code error "internal error"
    }
    }

    return {}
}

/* */
/* */
/*  Miscellaneous*/
/* */
/* */

/*  dom::tcl::hasmixedcontent --*/
/* */
/*  Determine whether an element contains mixed content*/
/* */
/*  Arguments:*/
/*  token   dom node*/
/* */
/*  Results:*/
/*  Returns 1 if element contains mixed content,*/
/*  0 otherwise*/

ret  dom::tcl::hasmixedcontent token (
    type upvar #0 $, type token , type node

    , type if , optional [string =compare $node(node:nodeType) ="element"] , optional 
    # =Really undefined
    =return 0
    

    , type foreach , type child [, type set $, type node(, type node:, type childNodes)] , optional 
    upvar =#0 $child =childnode
    if ={![string compare =$childnode(node:nodeType) "textNode"] , optional 
        return =1
    
    )

    return 0
}

# dom::tcl::prefix2namespaceURI --
#
#   Given an XML Namespace prefix, find the corresponding Namespace URI
#
# Arguments:
#   node    DOM Node
#   prefix  XML Namespace prefix
#
# Results:
#   Returns URI

proc dom::tcl::prefix2namespaceURI {node prefix} {

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

    set parent [dom::node parent $node]
    set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix]
    if {[string length $parent] && ![string length $nsuri]} {
     nsuri =  [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix]
     parent =  [dom::node parent $parent]
    }

    if {[string length $nsuri]} {
    return $nsuri
    } else {
    return -code error "unable to find namespace URI for prefix \"$prefix\""
    }

}

/*  dom::tcl::namespaceURI2prefix --*/
/* */
/*  Given an XML Namespace URI, find the corresponding prefix*/
/* */
/*  Arguments:*/
/*  node    DOM Node*/
/*  nsuri   XML Namespace URI*/
/* */
/*  Results:*/
/*  Returns prefix*/

ret  dom::tcl::namespaceURI2prefix (type node , type nsuri) {

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

    set found 0
    set prefix {}
    set parent [dom::node parent $node]
    while {[string length $parent]} {
    upvar #0 $node nodeinfo
    catch {unset attrs}
    array set attrs [array get $nodeinfo(element:attributeList)]
    foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] {
        if {![string compare $declNSuri $nsuri]} {
        set found 1
        set prefix [lindex [split $nsdecl ^] 1]
        break
        }
    }
    if {$found} {
        break
    }
    set node $parent
    set parent [dom::node parent $node]
    }

    if {$found} {
    return $prefix
    } else {
    return -code error "unable to find prefix for namespace URI \"$nsuri\""
    }

}

/*  dom::tcl::GetField --*/
/* */
/*  Return a value, or empty string if not defined*/
/* */
/*  Arguments:*/
/*  var name of variable to return*/
/* */
/*  Results:*/
/*  Returns the value, or empty string if variable is not defined.*/

ret  dom::tcl::GetField var (
    type upvar $, type var , type v
    , type if , optional [info =exists v] , optional 
    return =$v
     , type else , optional 
    return ={
    )
}

# dom::tcl::Min --
#
#   Return the minimum of two numeric values
#
# Arguments:
#   a   a value
#   b   another value
#
# Results:
#   Returns the value which is lower than the other.

proc dom::tcl::Min {a b} {
    return [expr {$a < $b ? $a : $b}]
}

/*  dom::tcl::Max --*/
/* */
/*  Return the maximum of two numeric values*/
/* */
/*  Arguments:*/
/*  a   a value*/
/*  b   another value*/
/* */
/*  Results:*/
/*  Returns the value which is greater than the other.*/

ret  dom::tcl::Max (type a , type b) {
    return [expr {$a > $b ? $a : $b}]
}

/*  dom::tcl::Boolean --*/
/* */
/*  Return a boolean value*/
/* */
/*  Arguments:*/
/*  b   value*/
/* */
/*  Results:*/
/*  Returns 0 or 1*/

ret  dom::tcl::Boolean b (
    type regsub -, type nocase , optional ^(true|yes|1|on)$ $, type b 1 , type b
    , type regsub -, type nocase , optional ^(false|no|0|off)$ $, type b 0 , type b
    , type return $, type b
)