• Publicity: Public Only All

xml-1-dom-procs.tcl

# 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 and XML, will be in separate modules. # # Copyright (c) 1998 Zveno Pty Ltd # http://www.zveno.com/ # # Zveno makes this software available free of charge for any purpose. # Copies may be made of this software but all of this notice must be included # on any copy. # # The software was developed for research purposes only and Zveno does not # warrant that it is error free or fit for any purpose. Zveno disclaims any # liability for all claims, expenses, losses, damages and costs any user may # incur as a result of using, copying or modifying this software. #

Location:
packages/acs-tcl/tcl/xml-1-dom-procs.tcl
CVS Identification:
$Id: xml-1-dom-procs.tcl,v 1.11.2.4 2023/07/10 08:43:13 gustafn Exp $

Procedures in this file

Detailed information

[ hide source ] | [ make this the default ]

Content File Source

ad_library {

# 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 and XML, will be in separate modules.
#
# Copyright (c) 1998 Zveno Pty Ltd
# http://www.zveno.com/
#
# Zveno makes this software available free of charge for any purpose.
# Copies may be made of this software but all of this notice must be included
# on any copy.
#
# The software was developed for research purposes only and Zveno does not
# warrant that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying this software.
#
    @cvs-id $Id: xml-1-dom-procs.tcl,v 1.11.2.4 2023/07/10 08:43:13 gustafn Exp $
}

package provide dom 1.6

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

# Data structure
#
# Documents are stored in an array within the dom namespace.
# Each element of the array is indexed by a unique identifier.
# Each element of the array is a key-value list with at least
# the following fields:
#    id docArray
#    node:parentNode node:childNodes node:nodeType
# Nodes of a particular type may have additional fields defined.
# Note that these fields in many circumstances are configuration options
# for a node type.
#
# "Live" data objects are stored as a separate Tcl variable.
# Lists, such as child node lists, are Tcl list variables (i.e. scalar)
# and keyed-value lists, such as attribute lists, are Tcl array
# variables.  The accessor function returns the variable name,
# which the application should treat as a read-only object.
#
# A token is a FQ array element reference for a node.

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

proc dom::GetHandle {type token varName} {

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

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

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

    return {}
}

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

proc dom::PutHandle {token varName} {

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

    return {}
}

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

namespace eval dom {
    variable DOMImplementationOptions {}
    variable DOMImplementationCounter 0
}

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

    switch -- $method {

    hasFeature {

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

        # Later on, could use Tcl package facility
        if {[regexp {create|destroy|parse|serialize|trim} [lindex $args 0]]} {
        if {[lindex $args 1] eq "1.0" } {
            return 1
        } else {
            return 0
        }
        } else {
        return 0
        }

    }

    create {

        # Bootstrap a document instance

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

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

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

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

        # Return the new top-level node
        return ${name}(node1)

    }

    destroy {

        # Cleanup a document

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

        # Patch from Gerald Lester

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

        return {}

    }

    parse {

        # This implementation allows use of either of two event-based,
        # non-validating XML parsers:
        # . TclXML Tcl-only parser (version 1.3 or higher)
        # . TclExpat parser

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

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

        switch -- $opts(-parser) {
        expat {
            if {[catch {package require expat} version]} {
            eval $errorCleanup
            return -code error "expat extension is not available"
            }
            set parser [expat [namespace current]::xmlparser]
        }
        tcl {
            if {[catch {package require xml 1.3} version]} {
            eval $errorCleanup
            return -code error "XML parser package is not available"
            }
            set parser [::xml::parser xmlparser]
        }
        default {
            # Automatically determine which parser to use
            if {[catch {package require expat} version]} {
            if {[catch {package require xml 1.3} version]} {
                eval $errorCleanup
                return -code error "unable to load XML parser"
            } else {
                set parser [::xml::parser xmlparser]
            }
            } else {
            set parser [expat [namespace current]::xmlparser]
            }
        }
        }

        $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]] \
        -final true

        # TclXML has features missing from expat
        catch {
        $parser configure \
            -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \
            -doctypecommand [namespace code [list ParseDocType $state]]
        }

        # 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]]
                    lset args 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 {}}
        unset -nocomplain $state
        return -code error $err
        }

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

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

    }

    serialize {

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

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

    }

    trim {

        # Removes textNodes that only contain white space

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

        Trim [lindex $args 0]

        return {}

    }

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

    }

    return {}
}

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

namespace eval dom {
    variable documentOptionsRO doctype|implementation|documentElement
    variable documentOptionsRW {}
}

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

    # GetHandle also checks token
    GetHandle document $token node

    set result {}

    switch -- $method {
    cget {
        if {[llength $args] != 1} {
        return -code error "too many arguments"
        }
        if {[regexp [format {^-(%s)$$documentOptionsRO] [lindex $args 0] discard option]} {
        return $node(document:$option)
        } elseif {[regexp [format {^-(%s)$$documentOptionsRW] [lindex $args 0] discard option]} {
        return $node(document:$option)
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [document cget $token [lindex $args 0]]
        } elseif {[llength $args] % 2} {
        return -code error "no value specified for option \"[lindex $args end]\""
        } else {
        foreach {option value} $args {
            if {[regexp [format {^-(%s)$$documentOptionsRW$option discard opt]} {
            set node(document:$opt$value
            } elseif {[regexp [format {^-(%s)$$documentOptionsRO$option discard opt]} {
            return -code error "attribute \"$option\" is read-only"
            } else {
            return -code error "unknown option \"$option\""
            }
        }
        }

        PutHandle $token node

    }

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

        # Check that the element name is kosher
        # BUG: The definition of 'Letter' here as ASCII letters
        # is not sufficient.  Also, CombiningChar and Extenders
        # must be added.
        if {![regexp {^[A-Za-z_:][-A-Za-z0-9._:]*$} [lindex $args 0]]} {
        return -code error "invalid element name \"[lindex $args 0]\""
        }

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

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

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

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

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

        set result [CreateGeneric $token node:nodeType CDATASection node:nodeValue [lindex $args 0]]
    }
    createProcessingInstruction {
        if {[llength $args] != 2} {
        return -code error "wrong number of arguments"
        }

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

        set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
    }
    createEntity {
        set result [CreateGeneric $token node:nodeType entity]
    }
    createEntityReference {
        set result [CreateGeneric $token node:nodeType entityReference]
    }

    createDocTypeDecl {
        # This is not a standard DOM 1.0 method
        if {[llength $args] < 1 || [llength $args] > 5} {
        return -code error "wrong number of arguments"
        }

        lassign $args name extid dtd entities notations
        set result [CreateDocType $token $name $extid $dtd $entities $notations]
    }

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

        return [Element:GetByTagName $token [lindex $args 0]]
    }

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

    }

    return $result
}

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

# dom::CreateElement --
#
#    Append an element to the given (parent) node (if any)
#
# Arguments:
#    token    parent node
#    name    element name (no checking performed here)
#    aList    attribute list
#    args    configuration options
#
# Results:
#    New node created, parent optionally modified

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

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

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

    # Initialise associated variables
    set ${docArrayName}var$docArray(counter) {}
    array set ${docArrayName}arr$docArray(counter) $aList

    # Update parent record

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

    if {[string length $token]} {

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

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

            } else {
            # Synthesize document type declaration
            CreateDocType $token $name {} {}
            # Resynchronise parent record
            array set parent [set $token]
            }

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

    lappend $parent(node:childNodes) $child

    }

    return $child
}

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

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

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

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

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

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

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

    return $child
}

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

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

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

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

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

    return $child
}

### Specials

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

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

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

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

    # Update parent

    set doc(document:doctype) $child

    # Add this node to the parent's child list
    # This must come before the document element,
    # so this implementation may be buggy
    lappend $doc(node:childNodes) $child

    set $token [array get doc]

    return $child
}

# dom::node --
#
#    Functions for a general node.
#
# Arguments:
#    method    method to invoke
#    token    token for node
#    args    arguments for method
#
# Results:
#    Depends on method used.

namespace eval dom {
    variable nodeOptionsRO nodeName|nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes
    variable nodeOptionsRW nodeValue
}

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

    GetHandle node $token node

    set result {}

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

        # Some read-only configuration options are computed
        if {[llength $args] != 1} {
        return -code error "too many arguments"
        }
        if {[regexp [format {^-(%s)$$nodeOptionsRO] [lindex $args 0] discard option]} {
        switch -- $option {
            childNodes {
            # How are we going to handle documentElement?
            set result $node(node:childNodes)
            }
            firstChild {
            upvar #0 $node(node:childNodes) children
            switch -- $node(node:nodeType) {
                documentFragment {
                set result [lindex $children 0]
                catch {set result $node(document:documentElement)}
                }
                default {
                set result [lindex $children 0]
                }
            }
            }
            lastChild {
            upvar #0 $node(node:childNodes) children
            switch -- $node(node:nodeType) {
                documentFragment {
                set result [lindex $children end]
                catch {set result $node(document:documentElement)}
                }
                default {
                set result [lindex $children end]
                }
            }
            }
            previousSibling {
            # BUG: must take documentElement into account
            # Find the parent node
            GetHandle node $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx -1]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            nextSibling {
            # BUG: must take documentElement into account
            # Find the parent node
            GetHandle node $node(node:parentNode) parent
            upvar #0 $parent(node:childNodes) children
            set idx [lsearch $children $token]
            if {$idx >= 0} {
                set sib [lindex $children [incr idx]]
                if {[llength $sib]} {
                set result $sib
                } else {
                set result {}
                }
            } else {
                set result {}
            }
            }
            attributes {
            if {$node(node:nodeType) ne "element" } {
                set result {}
            } else {
                set result $node(element:attributeList)
            }
            }
            default {
            return [GetField node(node:$option)]
            }
        }
        } elseif {[regexp [format {^-(%s)$$nodeOptionsRW] [lindex $args 0] discard option]} {
        return [GetField node(node:$option)]
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }
    co* {
        # configure

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

    in* {

        # insertBefore

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

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

        GetHandle node [lindex $args 0] newChild
        if {$newChild(docArray) ne $node(docArray) } {
        return -code error "new node must be in the same document"
        }

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

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

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

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

    rep* {

        # replaceChild

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

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

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

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

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

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

        PutHandle [lindex $args 1] oldChild
        PutHandle [lindex $args 0] newChild

        set result [lindex $args 0]

    }

    rem* {

        # removeChild

        if {[llength $args] != 1} {
        return -code error "wrong number of arguments"
        }
        array set oldChild [set [lindex $args 0]]
        if {$oldChild(docArray) != $node(docArray)} {
        return -code error "node \"[lindex $args 0]\" is not a child"
        }

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

        # Update the child to reflect lack of parentage
        set oldChild(node:parentNode) {}
        set [lindex $args 0] [array get oldChild]

        set result [lindex $args 0]
    }

    ap* {

        # appendChild

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

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

    }

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

    cl* {
        # cloneNode

        set deep 0
        switch [llength $args] {
        0 {
        }
        1 {
            set deep [Boolean [lindex $args 0]]
        }
        default {
            return -code error "too many arguments"
        }
        }

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

    }

    ch* {
        # children -- non-standard method

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

    }

    pa* {
        # parent -- non-standard method

        return $node(node:parentNode)

    }

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

    }

    PutHandle $token node

    return $result
}

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

proc dom::Node:create {pVar args} {
    upvar $pVar parent

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

    upvar #0 $parent(docArray) docArray

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

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

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

}

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

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

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

    set $token [array get node]

    return {}
}

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

namespace eval dom {
    variable elementOptionsRO {tagName empty}
    variable elementOptionsRW {}
}

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

    GetHandle node $token node

    set result {}

    switch -- $method {

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

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

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

    }

    setAttribute {
        if {[llength $args] == 0 || [llength $args] > 2} {
        return -code error "wrong number of arguments"
        }

        # TODO: Check that the attribute name is legal

        upvar #0 $node(element:attributeList) attrList
        set attrList([lindex $args 0]) [lindex $args 1]

    }

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

        upvar #0 $node(element:attributeList) attrList
        unset -nocomplain attrList([lindex $args 0])

    }

    getAttributeNode {
    }

    setAttributeNode {
    }

    removeAttributeNode {
    }

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

        return [Element:GetByTagName $token [lindex $args 0]]
    }

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

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

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

    }

    PutHandle $token node

    return $result
}

# Element:GetByTagName --
#
#    Search for (child) elements
#    NB. This does not descend the hierarchy.  Check the DOM spec.
#
# Arguments:
#    token    parent node
#    name    (child) elements to search for
#
# Results:
#    List of matching node tokens

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

    set result {}

    if {$node(node:nodeType) ne "documentFragment" } {
    foreach child [set $node(node:childNodes)] {
        unset -nocomplain childNode
        array set childNode [set $child]
        if {$childNode(node:nodeType) eq "element" 
        && [GetField childNode(node:nodeName)] eq $name 
        } {
        lappend result $child
        }
    }
    } elseif {[llength $node(document:documentElement)]} {
    # Document Element must exist and must be an element type node
    unset -nocomplain childNode
    array set childNode [set $node(document:documentElement)]
    if {$childNode(node:nodeName) eq $name } {
        set result $node(document:documentElement)
    }
    }

    return $result
}

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

proc dom::Element:Normalize {pVar nodes} {
    upvar $pVar parent

    set textNode {}

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

    switch -- $child(node:nodeType) {
        textNode {
        if {[llength $textNode]} {
            # Coalesce into previous node
            append text(node:nodeValue) $child(node:nodeValue)
            # Remove this child
            upvar #0 $parent(node:childNodes) childNodes
            set idx [lsearch $childNodes $n]
            set childNodes [lreplace $childNodes $idx $idx]
            unset $n
            set cleanup {}

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

    eval $cleanup
    }

    return {}
}

# dom::processinginstruction --
#
#    Functions for a processing instruction.
#
# Arguments:
#    method    method to invoke
#    token    token for node
#    args    arguments for method
#
# Results:
#    Depends on method used.

namespace eval dom {
    variable piOptionsRO target
    variable piOptionsRW data
}

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

    GetHandle node $token node

    set result {}

    switch -- $method {

    cget {
        # Some read-only configuration options are computed
        if {[llength $args] != 1} {
        return -code error "too many arguments"
        }
        if {[regexp [format {^-(%s)$$elementOptionsRO] [lindex $args 0] discard option]} {
        switch -- $option {
            target {
            set result [lindex $node(node:nodeName) 0]
            }
            default {
            return $node(node:$option)
            }
        }
        } elseif {[regexp [format {^-(%s)$$elementOptionsRW] [lindex $args 0] discard option]} {
        switch -- $option {
            data {
            return $node(node:nodeValue)
            }
            default {
            return $node(node:$option)
            }
        }
        } else {
        return -code error "unknown option \"[lindex $args 0]\""
        }
    }
    configure {
        if {[llength $args] == 1} {
        return [document cget $token [lindex $args 0]]
        } elseif {[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 node(node:nodeValue) $value
                }
                default {
                set node(node:$opt$value
                }
            }
            } else {
            return -code error "unknown option \"$option\""
            }
        }
        }
    }

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

    }

    PutHandle $token node

    return $result
}

#################################################
#
# Serialization
#
#################################################

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

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

    if {"node1" ne $node(documentFragment:masterDoc) } {
    return [eval [list Serialize:node $token$args]
    } else {
    if {{} ne [GetField node(document:documentElement)] } {
        return [eval Serialize:document [list $token$args]
    } else {
        return -code error "document has no document element"
    }
    }

}

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

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

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

    array set doctype [set $node(document:doctype)]

    # BUG: Want to serialize all children except for the 
    # document element, and then do the document element.

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

    return "<?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n<!DOCTYPE $doctype(doctype:name)[expr {[string length $doctype(doctype:externalid)] ? " PUBLIC[Serialize:ExternalID $doctype(doctype:externalid)]" : {}}][expr {[string length $doctype(doctype:internaldtd)] ? " \[$doctype(doctype:internaldtd)\]" : {}}]>\n[eval Serialize:element [list $node(document:documentElement)] $args]"
    }

}

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

proc dom::Serialize:ExternalID id {
    set result {}

    foreach ident $id {
    append result { } \"$ident\"
    }

    return $result
}

# dom::Serialize:XMLDecl --
#
#    Produce text for an arbitrary node.
#    This simply serializes the child nodes of the node.
#
# Arguments:
#    attr    required attribute
#    attList    attribute list
#
# Results:
#    XML format text.

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

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

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

    set result {}
    foreach childToken [set $node(node:childNodes)] {
    unset -nocomplain child
    array set child [set $childToken]
    append result [eval [list Serialize:$child(node:nodeType) $childToken$args]
    }

    return $result
}

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

proc dom::Serialize:element {token args} {
    array set node [set $token]
    array set opts {-newline {}}
    array set opts $args

    set result {}
    set newline {}
    if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
    append result \n
    set newline \n
    }
    append result "<$node(node:nodeName)"
    append result [Serialize:attributeList [array get $node(element:attributeList)]]

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

    append result />$newline

    } else {

    append result >$newline

    # Do the children
    append result [eval Serialize:node [list $token$args]

    append result "$newline</$node(node:nodeName)>$newline"

    }

    return $result
}

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

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

    return [Encode $node(node:nodeValue)]
}

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

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

    return "<$node(node:nodeName) $node(node:nodeValue)>"
}

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

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

    return <!--$node(node:nodeValue)-->
}

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

proc dom::Encode value {
    array set Entity {
    $ $
    < &lt;
    > &gt;
    & &amp;
    \" &quot;
    ' &apos;
    }

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

    return [subst -nocommand -nobackslash $value]
}

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

proc dom::Serialize:attributeList {l} {

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

    append result { } $name =

    # Handle special characters
    regsub -all < $value {\&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
}

#################################################
#
# Parsing
#
#################################################

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

proc dom::ParseElementStart {stateVar name attrList args} {
    upvar #0 $stateVar state
    array set opts $args

    lappend state(current) \
    [CreateElement [lindex $state(current) end] $name $attrList]

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

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

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

proc dom::ParseElementEnd {stateVar name args} {
    upvar #0 $stateVar state

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

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

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

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

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

proc dom::ParseProcessingInstruction {stateVar name target} {
    upvar #0 $stateVar state

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

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

proc dom::ParseXMLDeclaration {stateVar version encoding standalone} {
    upvar #0 $stateVar state

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

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

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

    return {}
}

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

proc dom::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}}} {
    upvar #0 $stateVar state

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

    return {}
}

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

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

proc dom::Trim nodeid {
    array set node [set $nodeid]

    switch -- $node(node:nodeType) {

    textNode {
        if {[string trim $node(node:nodeValue)] eq ""} {
        node removeChild $node(node:parentNode) $nodeid
        }
    }

    default {
        foreach child [set $node(node:childNodes)] {
        Trim $child
        }
    }

    }

    return {}
}

#################################################
#
# Miscellaneous
#
#################################################

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

proc GetField var {
    upvar $var v
    return [expr {[info exists v] ? $v : {}}]
}

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

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

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

proc dom::Max {a b} {
    return [expr {$a > $b ? $a : $b}]
}

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

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


# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End: