summaryrefslogtreecommitdiffstats
path: root/tclxml/tcldom-tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tclxml/tcldom-tcl')
-rw-r--r--tclxml/tcldom-tcl/dom.tcl4291
-rw-r--r--tclxml/tcldom-tcl/dommap.tcl108
-rw-r--r--tclxml/tcldom-tcl/xmlswitch.tcl520
3 files changed, 4919 insertions, 0 deletions
diff --git a/tclxml/tcldom-tcl/dom.tcl b/tclxml/tcldom-tcl/dom.tcl
new file mode 100644
index 0000000..b3edc99
--- /dev/null
+++ b/tclxml/tcldom-tcl/dom.tcl
@@ -0,0 +1,4291 @@
+# dom.tcl --
+#
+# This file implements the Tcl language binding for the DOM -
+# the Document Object Model. Support for the core specification
+# is given here. Layered support for specific languages,
+# such as HTML, will be in separate modules.
+#
+# Copyright (c) 1998-2004 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: dom.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+# We need the xml package, so that we get Name defined
+
+package require xml 3.0
+
+package provide dom::tcl 3.0
+
+# Define generic constants
+
+namespace eval dom {
+ namespace export DOMImplementation
+ namespace export hasFeature createDocument create createDocumentType
+ namespace export createNode destroy isNode parse selectNode serialize
+ namespace export trim
+
+ namespace export document documentFragment node
+ namespace export element textNode attribute
+ namespace export processingInstruction
+ namespace export documenttype
+ namespace export event
+
+ variable maxSpecials
+ if {![info exists maxSpecials]} {
+ set maxSpecials 10
+ }
+
+ variable strictDOM 0
+
+ # Default -indentspec value
+ # spaces-per-indent-level {collapse-re collapse-value}
+ variable indentspec [list 2 [list { } \t]]
+
+ # The Namespace URI for XML Namespace declarations
+ variable xmlnsURI http://www.w3.org/2000/xmlns/
+
+ # DOM Level 2 Event defaults
+ variable bubbles
+ array set bubbles {
+ DOMFocusIn 1
+ DOMFocusOut 1
+ DOMActivate 1
+ click 1
+ mousedown 1
+ mouseup 1
+ mouseover 1
+ mousemove 1
+ mouseout 1
+ DOMSubtreeModified 1
+ DOMNodeInserted 1
+ DOMNodeRemoved 1
+ DOMNodeInsertedIntoDocument 0
+ DOMNodeRemovedFromDocument 0
+ DOMAttrModified 1
+ DOMAttrRemoved 1
+ DOMCharacterDataModified 1
+ }
+ variable cancelable
+ array set cancelable {
+ DOMFocusIn 0
+ DOMFocusOut 0
+ DOMActivate 1
+ click 1
+ mousedown 1
+ mouseup 1
+ mouseover 1
+ mousemove 0
+ mouseout 1
+ DOMSubtreeModified 0
+ DOMNodeInserted 0
+ DOMNodeRemoved 0
+ DOMNodeInsertedIntoDocument 0
+ DOMNodeRemovedFromDocument 0
+ DOMAttrModified 0
+ DOMAttrRemoved 0
+ DOMCharacterDataModified 0
+ }
+}
+
+namespace eval dom::tcl {
+ namespace export DOMImplementation
+ namespace export hasFeature createDocument create createDocumentType
+ namespace export createNode destroy isNode parse selectNode serialize
+ namespace export trim
+
+ namespace export document documentFragment node
+ namespace export element textNode attribute
+ namespace export processingInstruction
+ namespace export event
+}
+
+foreach p {DOMImplementation hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim document documentFragment node element textNode attribute processingInstruction event documenttype} {
+
+ proc dom::$p args "return \[eval tcl::$p \$args\]"
+
+}
+
+# Data structures
+#
+# Documents are stored in a Tcl namespace within the ::dom namespace.
+# The Document array variable stores data for the document itself.
+# Each node has an array variable for its data.
+#
+# "Live" data objects are stored as a separate Tcl variable.
+# Lists, such as child node lists, are Tcl list variables (ie scalar)
+# and keyed-value lists, such as attribute lists, are Tcl array
+# variables. The accessor function returns the variable name,
+# which the application should treat as a read-only object.
+#
+# A token is a FQ Tcl variable name.
+
+# dom::tcl::DOMImplementation --
+#
+# Implementation-dependent functions.
+# Most importantly, this command provides a function to
+# create a document instance.
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable DOMImplementationOptions {}
+ variable DOMImplementationCounter
+ if {![info exists DOMImplementationCounter]} {
+ set DOMImplementationCounter 0
+ }
+}
+
+proc dom::tcl::DOMImplementation {method args} {
+ variable DOMImplementationOptions
+ variable DOMImplementationCounter
+
+ switch -- $method {
+
+ hasFeature {
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be dom::DOMImplementation method args..."
+ }
+
+ # Later on, could use Tcl package facility
+ if {[regexp {create|destroy|parse|query|serialize|trim|Events|UIEvents|isNode} [lindex $args 0]]} {
+ if {![string compare [lindex $args 1] "1.0"]} {
+ return 1
+ } else {
+ return 0
+ }
+ } else {
+ return 0
+ }
+
+ }
+
+ createDocument {
+ # createDocument introduced in DOM Level 2
+
+ if {[llength $args] != 3} {
+ return -code error "wrong # args: should be DOMImplementation nsURI name doctype"
+ }
+
+ set doc [DOMImplementation create]
+
+ if {[string length [lindex $args 2]]} {
+ array set $doc [list document:doctype [lindex $args 2]]
+ }
+
+ document createElementNS $doc [lindex $args 0] [lindex $args 1]
+
+ return $doc
+ }
+
+ create {
+
+ # Non-standard method (see createDocument)
+ # Bootstrap a document instance
+
+ if {[llength $args] > 0} {
+ return -code error "wrong # args: should be DOMImplementation create"
+ }
+
+ # Allocate unique document array name
+ set ns [namespace current]::document[incr DOMImplementationCounter]
+ set name ${ns}::Document
+
+ # Create the Tcl namespace for this document
+ namespace eval $ns {
+ namespace export Document
+ }
+
+ set varPrefix ${name}var
+ set arrayPrefix ${name}arr
+
+ array set $name [list counter 1 \
+ node:nodeType document \
+ node:parentNode {} \
+ node:nodeName #document \
+ node:nodeValue {} \
+ node:childNodes ${varPrefix}1 \
+ documentFragment:masterDoc $name \
+ document:implementation [namespace current]::DOMImplementation \
+ document:xmldecl {version 1.0} \
+ document:documentElement {} \
+ document:doctype {} \
+ ]
+
+ # Initialise child node list
+ set $varPrefix {}
+
+ # Create a Tcl command for the document
+ proc $name {method args} "return \[eval [namespace current]::document \[list \$method\] $name \$args\]"
+
+ # Capture destruction of the document
+ trace add command $name delete [namespace code [list Document:Delete $name]]
+
+ # Return the new toplevel node
+ return $name
+ }
+
+ createDocumentType {
+ # Introduced in DOM Level 2
+
+ # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
+
+ if {[llength $args] < 3 || [llength $args] > 4} {
+ return -code error "wrong # args: should be: DOMImplementation createDocumentType qname publicid systemid ?internaldtd?"
+ }
+
+ return [eval CreateDocType $args]
+ }
+
+ createNode {
+ # Non-standard method
+ # Creates node(s) in the given document given an XPath expression
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be dom::DOMImplementation createNode xpath"
+ }
+
+ package require xpath
+
+ return [XPath:CreateNode [lindex $args 0] [lindex $args 1]]
+ }
+
+ destroy {
+
+ # Free all memory associated with a node
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be dom::DOMImplementation destroy token"
+ }
+
+ if {[catch {upvar #0 [lindex $args 0] node}]} {
+ # If the document is being destroyed then the Tcl namespace no longer exists
+ return {}
+ }
+
+ switch $node(node:nodeType) {
+
+ document -
+ documentFragment {
+
+ if {[string length $node(node:parentNode)]} {
+ unset $node(node:childNodes)
+
+ # Dispatch events
+ event postMutationEvent $node(node:parentNode) DOMSubtreeModified
+
+ return {}
+ }
+
+ # else this is the root document node,
+ # and we can optimize the cleanup.
+ # No need to dispatch events.
+
+ # First remove all command traces
+ foreach nodecmd [info commands [namespace qualifiers [lindex $args 0]]::*] {
+ trace remove command $nodecmd delete [namespace code [list Node:Delete $nodecmd]]
+ }
+
+ namespace delete [namespace qualifiers [lindex $args 0]]
+ }
+
+ documentType {
+ trace remove command [lindex $args 0] delete [namespace code [list DocumentType:Delete [lindex $args 0]]]
+ rename [lindex $args 0] {}
+ unset [lindex $args 0]
+ }
+
+ element {
+ # First make sure the node is removed from the tree
+ if {[string length $node(node:parentNode)]} {
+ node removeChild $node(node:parentNode) [lindex $args 0]
+ }
+ unset $node(node:childNodes)
+ unset $node(element:attributeList)
+ unset node
+ set name [lindex $args 0]
+ trace remove command $name delete [namespace code [list Node:Delete $name]]
+ rename $name {}
+
+ # Don't dispatch events here -
+ # already done by removeChild
+ }
+
+ event {
+ set name [lindex $args 0]
+ trace remove command $name delete [namespace code [list Node:Delete $name]]
+ rename $name {}
+ unset node
+ }
+
+ default {
+ # Store the parent for later
+ set parent $node(node:parentNode)
+
+ # First make sure the node is removed from the tree
+ if {[string length $node(node:parentNode)]} {
+ node removeChild $node(node:parentNode) [lindex $args 0]
+ }
+ unset node
+ set name [lindex $args 0]
+ trace remove command $name delete [namespace code [list Node:Delete $name]]
+ rename $name {}
+
+ # Dispatch events
+ event postMutationEvent $parent DOMSubtreeModified
+
+ }
+
+ }
+
+ return {}
+
+ }
+
+ isNode {
+ # isNode - non-standard method
+ # Sometimes it is useful to check if an arbitrary string
+ # refers to a DOM node
+
+ upvar #0 [lindex $args 0] node
+
+ if {![info exists node]} {
+ return 0
+ } elseif {[info exists node(node:nodeType)]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+
+ parse {
+
+ # This implementation uses TclXML version 2.0.
+ # TclXML can choose the best installed parser.
+
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be dom::DOMImplementation parse xml ?args...?"
+ }
+
+ array set opts {-parser {} -progresscommand {} -chunksize 8196}
+ if {[catch {array set opts [lrange $args 1 end]}]} {
+ return -code error "bad configuration options"
+ }
+
+ # Create a state array for this parse session
+ set state [namespace current]::parse[incr DOMImplementationCounter]
+ array set $state [array get opts -*]
+ array set $state [list progCounter 0]
+ set errorCleanup {}
+
+ if {[string length $opts(-parser)]} {
+ set parserOpt [list -parser $opts(-parser)]
+ } else {
+ set parserOpt {}
+ }
+ if {[catch {package require xml} version]} {
+ eval $errorCleanup
+ return -code error "unable to load XML parsing package"
+ }
+ set parser [eval xml::parser $parserOpt]
+
+ $parser configure \
+ -elementstartcommand [namespace code [list ParseElementStart $state]] \
+ -elementendcommand [namespace code [list ParseElementEnd $state]] \
+ -characterdatacommand [namespace code [list ParseCharacterData $state]] \
+ -processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \
+ -commentcommand [namespace code [list ParseComment $state]] \
+ -entityreferencecommand [namespace code [list ParseEntityReference $state]] \
+ -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \
+ -doctypecommand [namespace code [list ParseDocType $state]] \
+ -final 1
+
+ # Create top-level document
+ array set $state [list docNode [DOMImplementation create]]
+ array set $state [list current [lindex [array get $state docNode] 1]]
+
+ # Parse data
+ # Bug in TclExpat - doesn't handle non-final inputs
+ if {0 && [string length $opts(-progresscommand)]} {
+ $parser configure -final false
+ while {[string length [lindex $args 0]]} {
+ $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)]
+ set args [lreplace $args 0 0 \
+ [string range [lindex $args 0] $opts(-chunksize) end]]
+ uplevel #0 $opts(-progresscommand)
+ }
+ $parser configure -final true
+ } elseif {[catch {$parser parse [lindex $args 0]} err]} {
+ catch {rename $parser {}}
+ catch {unset $state}
+ return -code error $err
+ }
+
+ # Free data structures which are no longer required
+ $parser free
+ catch {rename $parser {}}
+
+ set doc [lindex [array get $state docNode] 1]
+ unset $state
+ return $doc
+
+ }
+
+ selectNode {
+ # Non-standard method
+ # Returns nodeset in the given document matching an XPath expression
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be dom::DOMImplementation selectNode token xpath"
+ }
+
+ package require xpath
+
+ return [XPath:SelectNode [lindex $args 0] [lindex $args 1]]
+ }
+
+ serialize {
+
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be dom::DOMImplementation serialize token"
+ }
+
+ upvar #0 [lindex $args 0] node
+
+ return [eval [list Serialize:$node(node:nodeType)] $args]
+
+ }
+
+ trim {
+
+ # Removes textNodes that only contain white space
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be dom::DOMImplementation trim token"
+ }
+
+ Trim [lindex $args 0]
+
+ # Dispatch DOMSubtreeModified event once here?
+
+ return {}
+
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+
+ }
+
+ return {}
+}
+
+namespace eval dom::tcl {
+ foreach method {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} {
+ proc $method args "eval [namespace current]::DOMImplementation $method \$args"
+ }
+}
+
+# dom::tcl::Document:Delete --
+#
+# Handle destruction of a document
+#
+# Arguments:
+# name document token
+# old )
+# new ) args added by trace command
+# op )
+
+proc dom::tcl::Document:Delete {name old new op} {
+ DOMImplementation destroy $name
+ return {}
+}
+
+# dom::tcl::document --
+#
+# Functions for a document node.
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable documentOptionsRO doctype|implementation|documentElement
+ variable documentOptionsRW actualEncoding|encoding|standalone|version
+}
+
+proc dom::tcl::document {method token args} {
+ variable documentOptionsRO
+ variable documentOptionsRW
+
+ upvar #0 $token node
+
+ set result {}
+
+ switch -- $method {
+ cget {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::document method token ?args ...?\""
+ }
+ if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
+ return $node(document:$option)
+ } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
+ switch -- $option {
+ encoding -
+ version -
+ standalone {
+ array set xmldecl $node(document:xmldecl)
+ return $xmldecl($option)
+ }
+ default {
+ return $node(document:$option)
+ }
+ }
+ } else {
+ return -code error "bad option \"[lindex $args 0]\""
+ }
+ }
+ configure {
+ if {[llength $args] == 1} {
+ return [document cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "no value specified for option \"[lindex $args end]\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} {
+ switch -- $opt {
+ encoding {
+ catch {unset xmldecl}
+ array set xmldecl $node(document:xmldecl)
+ set xmldecl(encoding) $value
+ set node(document:xmldecl) [array get xmldecl]
+ }
+ standalone {
+ if {[string is boolean $value]} {
+ catch {unset xmldecl}
+ array set xmldecl $node(document:xmldecl)
+ if {[string is true $value]} {
+ set xmldecl(standalone) yes
+ } else {
+ set xmldecl(standalone) no
+ }
+ set node(document:xmldecl) [array get xmldecl]
+ } else {
+ return -code error "unsupported value for option \"$option\" - must be boolean"
+ }
+ }
+ version {
+ if {$value == "1.0"} {
+ catch {unset xmldecl}
+ array set xmldecl $node(document:xmldecl)
+ set xmldecl(version) $value
+ set node(document:xmldecl) [array get xmldecl]
+ } else {
+ return -code error "unsupported value for option \"$option\""
+ }
+ }
+ default {
+ set node(document:$opt) $value
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
+ return -code error "attribute \"$option\" is read-only"
+ } else {
+ return -code error "bad option \"$option\""
+ }
+ }
+ }
+ }
+
+ createElement {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createElement token name\""
+ }
+
+ # Check that the element name is kosher
+ if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
+ return -code error "invalid element name \"[lindex $args 0]\""
+ }
+
+ # Invoke internal factory function
+ set result [CreateElement $token [lindex $args 0] {}]
+
+ }
+ createDocumentFragment {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be \"document createDocumentFragment token\""
+ }
+
+ set result [CreateGeneric $token node:nodeType documentFragment node:nodeName #document-fragment node:nodeValue {}]
+ }
+ createTextNode {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createTextNode token text\""
+ }
+
+ set result [CreateTextNode $token [lindex $args 0]]
+ }
+ createComment {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createComment token data\""
+ }
+
+ set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]]
+ }
+ createCDATASection {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createCDATASection token data\""
+ }
+
+ set result [CreateTextNode $token [lindex $args 0]]
+ node configure $result -cdatasection 1
+ }
+ createProcessingInstruction {
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \"document createProcessingInstruction token target data\""
+ }
+
+ set result [CreateGeneric $token node:nodeType processingInstruction \
+ node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
+ }
+ createAttribute {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createAttributes token name\""
+ }
+
+ # Check that the attribute name is kosher
+ if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
+ return -code error "invalid attribute name \"[lindex $args 0]\""
+ }
+
+ set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
+ }
+ createEntity {
+ set result [CreateGeneric $token node:nodeType entity]
+ }
+ createEntityReference {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createEntityReference token name\""
+ }
+ set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]]
+ }
+
+ importNode {
+ # Introduced in DOM Level 2
+
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be \"importNode token ?-deep boolean?\""
+ }
+ array set opts {
+ -deep 1
+ }
+ array set opts [lrange $args 1 end]
+ set opts(-deep) [Boolean $opts(-deep)]
+
+ if {[namespace qualifiers [lindex $args 0]] == [namespace qualifiers $token]} {
+ return -code error "source node \"[lindex $args 0]\" is in the same document"
+ }
+
+ switch [node cget [lindex $args 0] -nodeType] {
+ document -
+ documentType {
+ return -code error "node type \"[node cget [lindex $args 0] -type]\" cannot be imported"
+ }
+ documentFragment {
+ set result [document createDocumentFragment $token]
+ if {$opts(-deep)} {
+ foreach child [node children [lindex $args 0]] {
+ $result appendChild [$token importNode $child -deep 1]
+ }
+ }
+ }
+ element {
+ set result [CreateElement {} [node cget [lindex $args 0] -nodeName] [array get [node cget [lindex $args 0] -attributes]] -document $token]
+ if {$opts(-deep)} {
+ foreach child [node children [lindex $args 0]] {
+ $result appendChild [$token importNode $child -deep 1]
+ }
+ }
+ }
+ textNode {
+ set result [CreateTextNode {} [node cget [lindex $args 0] -nodeValue] -document $token]
+ }
+ attribute -
+ processingInstruction -
+ comment {
+ set result [CreateGeneric {} -document $token node:nodeType [node cget [lindex $args 0] -nodeType] node:nodeName [node cget [lindex $args 0] -nodeName] node:nodeValue [node cget [lindex $args 0] -nodeValue]]
+ }
+ }
+ }
+
+ createElementNS {
+ # Introduced in DOM Level 2
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be: \"createElementNS nsuri qualname\""
+ }
+
+ # Check that the qualified name is kosher
+ if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]] break} err]} {
+ return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\""
+ }
+
+ # Invoke internal factory function
+ set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname]
+ }
+
+ createAttributeNS {
+ # Introduced in DOM Level 2
+
+ return -code error "not yet implemented"
+ }
+
+ getElementsByTagNameNS {
+ # Introduced in DOM Level 2
+
+ return -code error "not yet implemented"
+ }
+
+ getElementsById {
+ # Introduced in DOM Level 2
+
+ return -code error "not yet implemented"
+ }
+
+ createEvent {
+ # Introduced in DOM Level 2
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"document createEvent token type\""
+ }
+
+ set result [CreateEvent $token [lindex $args 0]]
+
+ }
+
+ getElementsByTagName {
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be \"document getElementsByTagName token what\""
+ }
+
+ return [eval Element:GetByTagName [list $token [lindex $args 0]] \
+ [lrange $args 1 end]]
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+
+ }
+
+ # Dispatch events
+
+ # Node insertion events are generated here instead of the
+ # internal factory procedures. This is because the factory
+ # procedures are meant to be mean-and-lean during the parsing
+ # phase, and dispatching events at that time would be an
+ # excessive overhead. The factory methods here are pretty
+ # heavyweight anyway.
+
+ if {[string match create* $method] && [string compare $method "createEvent"]} {
+
+ event postMutationEvent $result DOMNodeInserted -relatedNode $token
+ event postMutationEvent $result DOMNodeInsertedIntoDocument
+ event postMutationEvent $token DOMSubtreeModified
+
+ }
+
+ return $result
+}
+
+### Factory methods
+###
+### These are lean-and-mean for fastest possible tree building
+
+# dom::tcl::CreateElement --
+#
+# Append an element to the given (parent) node (if any)
+#
+# Arguments:
+# token parent node (if empty -document option is mandatory)
+# name element name (no checking performed here)
+# aList attribute list
+# args configuration options
+#
+# Results:
+# New node created, parent optionally modified
+
+proc dom::tcl::CreateElement {token name aList args} {
+ array set opts $args
+
+ if {[string length $token]} {
+ upvar #0 $token parent
+ upvar #0 [namespace qualifiers $token]::Document document
+ set child [namespace qualifiers $token]::node[incr document(counter)]
+ } elseif {[info exists opts(-document)]} {
+ upvar #0 $opts(-document) document
+ set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
+ } else {
+ return -code error "no parent or document specified"
+ }
+
+ upvar #0 $child new
+
+ # Create the new node
+ # NB. normally we'd use Node:create here,
+ # but inline it instead for performance
+ array set new [list \
+ node:parentNode $token \
+ node:childNodes ${child}var \
+ node:nodeType element \
+ node:nodeName $name \
+ node:namespaceURI {} \
+ node:prefix {} \
+ node:localName $name \
+ node:nodeValue {} \
+ element:attributeList ${child}arr \
+ element:attributeNodes {} \
+ ]
+
+ catch {set new(node:namespaceURI) $opts(-namespace)}
+ catch {set new(node:localName) $opts(-localname)}
+ catch {set new(node:prefix) $opts(-prefix)}
+
+ # Initialise associated variables
+ set ${child}var {}
+ array set ${child}arr $aList
+ catch {
+ foreach {ns nsAttrList} $opts(-namespaceattributelists) {
+ foreach {attrName attrValue} $nsAttrList {
+ array set ${child}arr [list $ns^$attrName $attrValue]
+ }
+ }
+ }
+
+ # Update parent record
+
+ # Does this element qualify as the document element?
+ # If so, then has a document element already been set?
+
+ if {[string length $token] &&
+ [string equal $parent(node:nodeType) document]} {
+
+ if {$token == $parent(documentFragment:masterDoc)} {
+ if {[info exists parent(document:documentElement)] && \
+ [string length $parent(document:documentElement)]} {
+ # Do not attach to the tree
+ set new(node:parentNode) {}
+ } else {
+
+ # Check against document type decl
+ if {[string length $parent(document:doctype)]} {
+ upvar #0 $parent(document:doctype) doctypedecl
+ if {[string compare $name $doctypedecl(doctype:name)]} {
+ return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
+ }
+
+ } else {
+ # Synthesize document type declaration
+ set doctype [CreateDocType $name {} {}]
+ set document(document:doctype) $doctype
+ }
+
+ set parent(document:documentElement) $child
+ catch {lappend $parent(node:childNodes) $child}
+ }
+ } else {
+ catch {lappend $parent(node:childNodes) $child}
+ }
+ } else {
+ catch {lappend $parent(node:childNodes) $child}
+ }
+
+ proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
+ trace add command $child delete [namespace code [list Node:Delete $child]]
+
+ return $child
+}
+
+# dom::tcl::CreateTextNode --
+#
+# Append a textNode node to the given (parent) node (if any).
+#
+# This factory function can also be performed by
+# CreateGeneric, but text nodes are created so often
+# that this specific factory procedure speeds things up.
+#
+# Arguments:
+# token parent node (if empty -document option is mandatory)
+# text initial text
+# args additional configuration options
+#
+# Results:
+# New node created, parent optionally modified
+
+proc dom::tcl::CreateTextNode {token text args} {
+ array set opts $args
+
+ if {[string length $token]} {
+ upvar #0 $token parent
+ upvar #0 [namespace qualifiers $token]::Document document
+ set child [namespace qualifiers $token]::node[incr document(counter)]
+ } elseif {[info exists opts(-document)]} {
+ upvar #0 $opts(-document) document
+ set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
+ } else {
+ return -code error "no parent or document specified"
+ }
+
+ upvar #0 $child new
+
+ # Create the new node
+ # NB. normally we'd use Node:create here,
+ # but inline it instead for performance
+
+ # Text nodes never have children, so don't create a variable
+
+ array set new [list \
+ node:parentNode $token \
+ node:childNodes ${child}var \
+ node:nodeType textNode \
+ node:nodeValue $text \
+ node:nodeName #text \
+ node:cdatasection 0 \
+ ]
+
+ set ${child}var {}
+
+ # Update parent record
+ catch {lappend $parent(node:childNodes) $child}
+
+ proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
+ trace add command $child delete [namespace code [list Node:Delete $child]]
+
+ return $child
+}
+
+# dom::tcl::CreateGeneric --
+#
+# This is a template used for type-specific factory procedures
+#
+# Arguments:
+# token parent node (if empty -document option is mandatory)
+# args optional values
+#
+# Results:
+# New node created, parent modified
+
+proc dom::tcl::CreateGeneric {token args} {
+ array set opts $args
+
+ if {[string length $token]} {
+ upvar #0 $token parent
+ upvar #0 [namespace qualifiers $token]::Document document
+ set child [namespace qualifiers $token]::node[incr document(counter)]
+ } elseif {[info exists opts(-document)]} {
+ upvar #0 $opts(-document) document
+ set child [namespace qualifiers $opts(-document)]::node[incr document(counter)]
+ } else {
+ return -code error "no parent or document specified"
+ }
+ upvar #0 $child new
+
+ # Create the new node
+ # NB. normally we'd use Node:create here,
+ # but inline it instead for performance
+ array set new [eval list [list \
+ node:parentNode $token \
+ node:childNodes ${child}var ] \
+ $args \
+ ]
+ set ${child}var {}
+
+ switch -glob -- [string length $token],$opts(node:nodeType) {
+ 0,* -
+ *,attribute -
+ *,namespace {
+ # These type of nodes are not children of their parent
+ }
+
+ default {
+ # Update parent record
+ lappend $parent(node:childNodes) $child
+ }
+ }
+
+ proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
+ trace add command $child delete [namespace code [list Node:Delete $child]]
+
+ return $child
+}
+
+### Specials
+
+# dom::tcl::CreateDocType --
+#
+# Create a Document Type Declaration node.
+#
+# Arguments:
+# name root element type
+# publicid public identifier
+# systemid system identifier
+# internaldtd internal DTD subset
+#
+# Results:
+# Returns node id of the newly created node.
+
+proc dom::tcl::CreateDocType {name publicid systemid {internaldtd {}}} {
+ if {![regexp ^$::xml::QName\$ $name]} {
+ return -code error "invalid QName \"$name\""
+ }
+
+ set nodename [namespace current]::$name
+ upvar #0 $nodename doctype
+ if {[info exists doctype]} {
+ return $nodename
+ }
+
+ if {[llength $internaldtd] == 1 && [string length [lindex $internaldtd 0]] == 0} {
+ set dtd {}
+ }
+
+ array set doctype [list \
+ node:childNodes {} \
+ node:nodeType documentType \
+ node:nodeName $name \
+ node:nodeValue {} \
+ doctype:name $name \
+ doctype:entities {} \
+ doctype:notations {} \
+ doctype:publicId $publicid \
+ doctype:systemId $systemid \
+ doctype:internalSubset $internaldtd \
+ ]
+
+ proc $nodename {method args} "return \[eval [namespace current]::documenttype \[list \$method\] $nodename \$args\]"
+ trace add command $nodename delete [namespace code [list DocumentType:Delete $nodename]]
+
+ return $nodename
+}
+
+# dom::tcl::documenttype --
+#
+# Functions for a document type declaration node.
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable documenttypeOptionsRO name|entities|notations|publicId|systemId|internalSubset
+ variable documenttypeOptionsRW {}
+}
+
+proc dom::tcl::documenttype {method token args} {
+ variable documenttypeOptionsRO
+ variable documenttypeOptionsRW
+
+ upvar #0 $token node
+
+ set result {}
+
+ switch -- $method {
+ cget {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::documenttype method token ?args ...?\""
+ }
+ if {[regexp [format {^-(%s)$} $documenttypeOptionsRO] [lindex $args 0] discard option]} {
+ switch -- $option {
+ name {
+ return $node(node:nodeName)
+ }
+ default {
+ return $node(doctype:$option)
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRW] [lindex $args 0] discard option]} {
+ return $node(doctype:$option)
+ } else {
+ return -code error "bad option \"[lindex $args 0]\""
+ }
+ }
+ configure {
+ if {[llength $args] == 1} {
+ return [documenttype cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "no value specified for option \"[lindex $args end]\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $documenttypeOptionsRW] $option discard opt]} {
+ switch -- $opt {
+ default {
+ set node(doctype:$opt) $value
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $documenttypeOptionsRO] $option discard opt]} {
+ return -code error "attribute \"$option\" is read-only"
+ } else {
+ return -code error "bad option \"$option\""
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+# dom::tcl::DocumentType:Delete --
+#
+# Handle node destruction
+#
+# Arguments:
+# name node token
+# old )
+# new ) arguments appended by trace command
+# op )
+#
+# Results:
+# Node is destroyed
+
+proc dom::tcl::DocumentType:Delete {name old new op} {
+ DOMImplementation destroy $name
+}
+
+# dom::tcl::node --
+#
+# Functions for a general node.
+#
+# Implements EventTarget Interface - introduced in DOM Level 2
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument
+ variable nodeOptionsRW nodeValue|cdatasection
+
+ # Allowing nodeName to be rw is not standard DOM.
+ # A validating implementation would have to be very careful
+ # in allowing this feature
+ if {$::dom::strictDOM} {
+ append nodeOptionsRO |nodeName
+ } else {
+ append nodeOptionsRW |nodeName
+ }
+}
+# NB. cdatasection is not a standard DOM option
+
+proc dom::tcl::node {method token args} {
+ variable nodeOptionsRO
+ variable nodeOptionsRW
+
+ upvar #0 $token node
+
+ set result {}
+
+ switch -glob -- $method {
+ cg* {
+ # cget
+
+ # Some read-only configuration options are computed
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node cget token option\""
+ }
+ if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
+ switch $option {
+ nodeName {
+ set result $node(node:nodeName)
+ switch $node(node:nodeType) {
+ textNode {
+ catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]}
+ }
+ default {
+ }
+ }
+ }
+ childNodes {
+ # How are we going to handle documentElement?
+ set result $node(node:childNodes)
+ }
+ firstChild {
+ upvar #0 $node(node:childNodes) children
+ switch $node(node:nodeType) {
+ document {
+ set result [lindex $children 0]
+ catch {set result $node(document:documentElement)}
+ }
+ default {
+ set result [lindex $children 0]
+ }
+ }
+ }
+ lastChild {
+ upvar #0 $node(node:childNodes) children
+ switch $node(node:nodeType) {
+ document {
+ set result [lindex $children end]
+ catch {set result $node(document:documentElement)}
+ }
+ default {
+ set result [lindex $children end]
+ }
+ }
+ }
+ previousSibling {
+ # BUG: must take documentElement into account
+ # Find the parent node
+ upvar #0 $node(node:parentNode) parent
+ upvar #0 $parent(node:childNodes) children
+ set idx [lsearch $children $token]
+ if {$idx >= 0} {
+ set sib [lindex $children [incr idx -1]]
+ if {[llength $sib]} {
+ set result $sib
+ } else {
+ set result {}
+ }
+ } else {
+ set result {}
+ }
+ }
+ nextSibling {
+ # BUG: must take documentElement into account
+ # Find the parent node
+ upvar #0 $node(node:parentNode) parent
+ upvar #0 $parent(node:childNodes) children
+ set idx [lsearch $children $token]
+ if {$idx >= 0} {
+ set sib [lindex $children [incr idx]]
+ if {[llength $sib]} {
+ set result $sib
+ } else {
+ set result {}
+ }
+ } else {
+ set result {}
+ }
+ }
+ attributes {
+ if {[string compare $node(node:nodeType) element]} {
+ set result {}
+ } else {
+ set result $node(element:attributeList)
+ }
+ }
+ ownerDocument {
+ if {[string compare $node(node:parentNode) {}]} {
+ return [namespace qualifiers $token]::Document
+ } else {
+ return $token
+ }
+ }
+ default {
+ return [GetField node(node:$option)]
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
+ return [GetField node(node:$option)]
+ } else {
+ return -code error "unknown option \"[lindex $args 0]\""
+ }
+ }
+ co* {
+ # configure
+
+ if {[llength $args] == 1} {
+ return [node cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "wrong \# args: should be \"::dom::node configure node option\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {
+
+ switch $opt,$node(node:nodeType) {
+ nodeValue,textNode -
+ nodeValue,processingInstruction {
+ # Dispatch event
+ set evid [CreateEvent $token DOMCharacterDataModified]
+ event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {} {}
+ set node(node:nodeValue) $value
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+ }
+ default {
+ set node(node:$opt) $value
+ }
+ }
+
+ } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
+ return -code error "attribute \"$option\" is read-only"
+ } else {
+ return -code error "unknown option \"$option\""
+ }
+ }
+ }
+ }
+
+ in* {
+
+ # insertBefore
+
+ # Previous and next sibling relationships are OK,
+ # because they are dynamically determined
+
+ if {[llength $args] < 1 || [llength $args] > 2} {
+ return -code error "wrong # args: should be \"dom::node insertBefore token new ?ref?\""
+ }
+
+ upvar #0 [lindex $args 0] newChild
+ if {[string compare [namespace qualifiers [lindex $args 0]] [namespace qualifiers $token]]} {
+ return -code error "new node must be in the same document"
+ }
+
+ switch [llength $args] {
+ 1 {
+ # Append as the last node
+ if {[string length $newChild(node:parentNode)]} {
+ node removeChild $newChild(node:parentNode) [lindex $args 0]
+ }
+ lappend $node(node:childNodes) [lindex $args 0]
+ set newChild(node:parentNode) $token
+ }
+ 2 {
+ upvar #0 [lindex $args 1] refChild
+
+ if {[string compare [namespace qualifiers [lindex $args 1]] [namespace qualifiers [lindex $args 0]]]} {
+ return -code error "nodes must be in the same document"
+ }
+ set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
+ if {$idx < 0} {
+ return -code error "no such reference child"
+ } else {
+
+ # Remove from previous parent
+ if {[string length $newChild(node:parentNode)]} {
+ node removeChild $newChild(node:parentNode) [lindex $args 0]
+ }
+
+ # Insert into new node
+ set $node(node:childNodes) \
+ [linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
+ set newChild(node:parentNode) $token
+ }
+ }
+ }
+
+ event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
+ FireNodeInsertedEvents [lindex $args 0]
+ event postMutationEvent $token DOMSubtreeModified
+
+ set result [lindex $args 0]
+
+ }
+
+ rep* {
+
+ # replaceChild
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \"dom::node replaceChild token new old\""
+ }
+
+ upvar #0 [lindex $args 0] newChild
+ upvar #0 [lindex $args 1] oldChild
+ upvar #0 $node(node:childNodes) children
+
+ # Find where to insert new child
+ set idx [lsearch $children [lindex $args 1]]
+ if {$idx < 0} {
+ return -code error "no such old child"
+ }
+
+ # Remove new child from current parent
+ if {[string length $newChild(node:parentNode)]} {
+ node removeChild $newChild(node:parentNode) [lindex $args 0]
+ }
+
+ set children \
+ [lreplace $children $idx $idx [lindex $args 0]]
+ set newChild(node:parentNode) $token
+
+ # Update old child to reflect lack of parentage
+ set oldChild(node:parentNode) {}
+
+ set result [lindex $args 1]
+
+ event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token
+ FireNodeInsertedEvents [lindex $args 0]
+ event postMutationEvent $token DOMSubtreeModified
+
+ }
+
+ removeC* {
+
+ # removeChild
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node removeChild token child\""
+ }
+ upvar #0 [lindex $args 0] oldChild
+ if {[string compare [namespace qualifiers [lindex $args 0]] [namespace qualifiers $token]]} {
+ return -code error "node \"[lindex $args 0]\" is not a child"
+ }
+
+ # Remove the child from the parent
+ upvar #0 $node(node:childNodes) myChildren
+ if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} {
+ return -code error "node \"[lindex $args 0]\" is not a child"
+ }
+ set myChildren [lreplace $myChildren $idx $idx]
+
+ # Update the child to reflect lack of parentage
+ set oldChild(node:parentNode) {}
+
+ set result [lindex $args 0]
+
+ # Event propagation has a problem here:
+ # Nodes that until recently were ancestors may
+ # want to capture the event, but we've just removed
+ # the parentage information. They get a DOMSubtreeModified
+ # instead.
+ event postMutationEvent [lindex $args 0] DOMNodeRemoved -relatedNode $token
+ FireNodeRemovedEvents [lindex $args 0]
+ event postMutationEvent $token DOMSubtreeModified
+
+ }
+
+ ap* {
+
+ # appendChild
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node appendChild token child\""
+ }
+
+ # Add to new parent
+ node insertBefore $token [lindex $args 0]
+
+ set result [lindex $args 0]
+
+ }
+
+ hasChildNodes {
+ set result [Min 1 [llength [set $node(node:childNodes)]]]
+ }
+
+ isSameNode {
+ # Introduced in DOM Level 3
+ switch [llength $args] {
+ 1 {
+ return [expr {$token == [lindex $args 0]}]
+ }
+ default {
+ return -code error "wrong # args: should be \"dom::node isSameNode token ref\""
+ }
+ }
+ }
+
+ cl* {
+ # cloneNode
+
+ # May need to pay closer attention to generation of events here
+
+ set deep 0
+ switch [llength $args] {
+ 0 {
+ }
+ 2 {
+ foreach {opt value} $args {
+ switch -- $opt {
+ -deep {
+ set deep [Boolean $value]
+ }
+ default {
+ return -code error "bad option \"$opt\""
+ }
+ }
+ }
+ }
+ default {
+ return -code error "wrong # args: should be \"dom::node cloneNode token ?-deep boolean?\""
+ }
+ }
+
+ switch $node(node:nodeType) {
+ element {
+ set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -document [namespace qualifiers $token]::Document]
+ if {$deep} {
+ foreach child [set $node(node:childNodes)] {
+ node appendChild $result [node cloneNode $child -deep 1]
+ }
+ }
+ }
+ textNode {
+ set result [CreateTextNode {} $node(node:nodeValue) -document [namespace qualifiers $token]::Document]
+ }
+ document {
+ set result [DOMImplementation create]
+ upvar #0 $result clonedDoc
+ array set clonedDoc [array get node document:doctype]
+ if {$deep} {
+ foreach child [set $node(node:childNodes)] {
+ node appendChild $result [document importNode $result $child -deep 1]
+ }
+ }
+ }
+ documentFragment -
+ default {
+ set result [CreateGeneric {} node:nodeType $node(node:nodeType) -document [namespace qualifiers $token]::Document]
+ if {$deep} {
+ foreach child [set $node(node:childNodes)] {
+ node appendChild $result [node cloneNode $child -deep 1]
+ }
+ }
+ }
+ }
+ }
+
+ ch* {
+ # children -- non-standard method
+
+ # If this is a textNode, then catch the error
+ set result {}
+ catch {set result [set $node(node:childNodes)]}
+
+ }
+
+ par* {
+ # parent -- non-standard method
+
+ return $node(node:parentNode)
+
+ }
+
+ pat* {
+ # path -- non-standard method
+
+ for {
+ set ancestor $token
+ upvar #0 $token ancestorNd
+ set result {}
+ } {[string length $ancestorNd(node:parentNode)]} {
+ set ancestor $ancestorNd(node:parentNode)
+ upvar #0 $ancestor ancestorNd
+ } {
+ set result [linsert $result 0 $ancestor]
+ }
+ # The last node is the document node
+ set result [linsert $result 0 $ancestor]
+
+ }
+
+ createNode {
+ # createNode -- non-standard method
+
+ # Creates node(s) in this document given an XPath expression.
+ # Relative location paths have this node as their initial context.
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node createNode token path\""
+ }
+
+ package require xpath
+
+ return [XPath:CreateNode $token [lindex $args 0]]
+ }
+
+ selectNode {
+ # selectNode -- non-standard method
+
+ # Returns nodeset in this document matching an XPath expression.
+ # Relative location paths have this node as their initial context.
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node selectNode token path\""
+ }
+
+ package require xpath
+
+ return [XPath:SelectNode $token [lindex $args 0]]
+ }
+
+ stringValue {
+ # stringValue -- non-standard method
+ # Returns string value of a node, as defined by XPath Rec.
+
+ if {[llength $args] > 0} {
+ return -code error "wrong # args: should be \"dom::node stringValue token\""
+ }
+
+ switch $node(node:nodeType) {
+ document -
+ documentFragment -
+ element {
+ set value {}
+ foreach child [set $node(node:childNodes)] {
+ switch [node cget $child -nodeType] {
+ element -
+ textNode {
+ append value [node stringValue $child]
+ }
+ default {
+ # Other nodes are not considered
+ }
+ }
+ }
+ return $value
+ }
+ attribute -
+ textNode -
+ processingInstruction -
+ comment {
+ return $node(node:nodeValue)
+ }
+ default {
+ return {}
+ }
+ }
+
+ }
+
+ addEv* {
+ # addEventListener -- introduced in DOM Level 2
+
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be \"dom::node addEventListener token type ?listener? ?option value...?\""
+ }
+
+ set type [lindex $args 0]
+ set args [lrange $args 1 end]
+ set listener [lindex $args 0]
+ if {[llength $args] == 1} {
+ set args {}
+ } elseif {[llength $args] > 1} {
+ if {[string match -* $listener]} {
+ set listener {}
+ } else {
+ set args [lrange $args 1 end]
+ }
+ }
+ array set opts {-usecapture 0}
+ if {[catch {array set opts $args}]} {
+ return -code error "missing value for option \"[lindex $args end]\""
+ }
+ set opts(-usecapture) [Boolean $opts(-usecapture)]
+ set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]
+
+ if {[string length $listener]} {
+ if {![info exists node(event:$type:$listenerType)] || \
+ [lsearch $node(event:$type:$listenerType) $listener] < 0} {
+ lappend node(event:$type:$listenerType) $listener
+ }
+ # else avoid registering same listener twice
+ } else {
+ # List all listeners
+ set result {}
+ catch {set result $node(event:$type:$listenerType)}
+ return $result
+ }
+ }
+
+ removeE* {
+ # removeEventListener -- introduced in DOM Level 2
+
+ if {[llength $args] < 2} {
+ return -code error "wrong # args: should be \"dom::node removeEventListener token type listener ?option value...?\""
+ }
+
+ set type [lindex $args 0]
+ set listener [lindex $args 1]
+ array set opts {-usecapture 0}
+ array set opts [lrange $args 2 end]
+ set opts(-usecapture) [Boolean $opts(-usecapture)]
+ set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}]
+
+ set idx [lsearch $node(event:$type:$listenerType) $listener]
+ if {$idx >= 0} {
+ set node(event:$type:$listenerType) [lreplace $node(event:$type:$listenerType) $idx $idx]
+ }
+
+ }
+
+ disp* {
+ # dispatchEvent -- introduced in DOM Level 2
+
+ # This is where the fun happens!
+ # Check to see if there one or more event listener,
+ # if so trigger the listener(s).
+ # Then pass the event up to the ancestor.
+ # This may be modified by event capturing and bubbling.
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::node dispatchEvent token eventnode\""
+ }
+
+ set eventId [lindex $args 0]
+ upvar #0 $eventId event
+ set type $event(type)
+
+ if {![string length $event(eventPhase)]} {
+
+ # This is the initial dispatch of the event.
+ # First trigger any capturing event listeners
+ # Starting from the root, proceed downward
+
+ set event(eventPhase) capturing_phase
+ set event(target) $token
+
+ # DOM L2 specifies that the ancestors are determined
+ # at the moment of event dispatch, so using a static
+ # list is the correct thing to do
+
+ foreach ancestor [lreplace [node path $token] end end] {
+ set event(currentNode) $ancestor
+
+ upvar #0 $ancestor ancNode
+
+ if {[info exists ancNode(event:$type:capturer)]} {
+ foreach capturer $ancNode(event:$type:capturer) {
+ if {[catch {uplevel #0 $capturer [list $eventId]} capturerError]} {
+ bgerror "error in capturer \"$capturerError\""
+ }
+ }
+
+ # A listener may stop propagation,
+ # but we check here to let all of the
+ # listeners at that level complete
+
+ if {$event(cancelable) && $event(stopPropagation)} {
+ break
+ }
+ }
+ }
+
+ # Prepare for next phase
+ set event(eventPhase) at_target
+
+ }
+
+ set event(currentNode) $token
+
+ if {[info exists node(event:$type:listener)]} {
+ foreach listener $node(event:$type:listener) {
+ if {[catch {uplevel #0 $listener [list $eventId]} listenerError]} {
+ bgerror "error in listener \"$listenerError\""
+ }
+ }
+ }
+
+ set event(eventPhase) bubbling_phase
+
+ # Now propagate the event
+ if {$event(cancelable) && $event(stopPropagation)} {
+ # Event has been cancelled
+ } elseif {[llength $node(node:parentNode)]} {
+ # Go ahead and propagate
+ node dispatchEvent $node(node:parentNode) $eventId
+ }
+
+ set event(dispatched) 1
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+
+ }
+
+ return $result
+}
+
+# dom::tcl::Node:create --
+#
+# Generic node creation.
+# See also CreateElement, CreateTextNode, CreateGeneric.
+#
+# Arguments:
+# pVar array in caller which contains parent details
+# args configuration options
+#
+# Results:
+# New child node created.
+
+proc dom::tcl::Node:create {pVar args} {
+ upvar #0 $pVar parent
+
+ array set opts {-name {} -value {}}
+ array set opts $args
+
+ upvar #0 [namespace qualifiers $pVar]::Document document
+
+ # Create new node
+ if {![info exists opts(-id)]} {
+ set opts(-id) node[incr document(counter)]
+ }
+ set child [namespace qualifiers $pVar]::$opts(-id)
+ upvar #0 $child new
+ array set new [list \
+ node:parentNode $opts(-parent) \
+ node:childNodes ${child}var \
+ node:nodeType $opts(-type) \
+ node:nodeName $opts(-name) \
+ node:nodeValue $opts(-value) \
+ element:attributeList ${child}arr \
+ ]
+ set ${child}var {}
+ array set ${child}arr {}
+
+ # Update parent node
+ if {![info exists parent(document:documentElement)]} {
+ lappend parent(node:childNodes) $child
+ }
+
+ proc $child {method args} "return \[eval [namespace current]::node \[list \$method\] $child \$args\]"
+ trace add command $child delete [namespace code [list Node:Delete $child]]
+
+ return $child
+}
+
+# dom::tcl::Node:set --
+#
+# Generic node update
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# Node modified.
+
+proc dom::tcl::Node:set {token args} {
+ upvar #0 $token node
+
+ foreach {key value} $args {
+ set node($key) $value
+ }
+
+ return {}
+}
+
+# dom::tcl::Node:Delete --
+#
+# Handle node destruction
+#
+# Arguments:
+# name node token
+# old )
+# new ) arguments appended by trace command
+# op )
+#
+# Results:
+# Node is destroyed
+
+proc dom::tcl::Node:Delete {name old new op} {
+ if {[catch {DOMImplementation destroy $name} ret]} {
+ # Document has been deleted... namespace has been destroyed
+ } else {
+ return $ret
+ }
+}
+
+# dom::tcl::FireNodeInsertedEvents --
+#
+# Recursively descend the tree triggering DOMNodeInserted
+# events as we go.
+#
+# Arguments:
+# nodeid Node ID
+#
+# Results:
+# DOM L2 DOMNodeInserted events posted
+
+proc dom::tcl::FireNodeInsertedEvents nodeid {
+ event postMutationEvent $nodeid DOMNodeInsertedIntoDocument
+ foreach child [node children $nodeid] {
+ FireNodeInsertedEvents $child
+ }
+
+ return {}
+}
+
+# dom::tcl::FireNodeRemovedEvents --
+#
+# Recursively descend the tree triggering DOMNodeRemoved
+# events as we go.
+#
+# Arguments:
+# nodeid Node ID
+#
+# Results:
+# DOM L2 DOMNodeRemoved events posted
+
+proc dom::tcl::FireNodeRemovedEvents nodeid {
+ event postMutationEvent $nodeid DOMNodeRemovedFromDocument
+ foreach child [node children $nodeid] {
+ FireNodeRemovedEvents $child
+ }
+
+ return {}
+}
+
+# dom::tcl::element --
+#
+# Functions for an element.
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable elementOptionsRO tagName|empty
+ variable elementOptionsRW {}
+}
+
+proc dom::tcl::element {method token args} {
+ variable elementOptionsRO
+ variable elementOptionsRW
+
+ upvar #0 $token node
+
+ if {[string compare $node(node:nodeType) "element"]} {
+ return -code error "malformed node token \"$token\""
+ }
+ set result {}
+
+ switch -- $method {
+
+ cget {
+ # Some read-only configuration options are computed
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::element cget token option\""
+ }
+ if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
+ switch $option {
+ tagName {
+ set result [lindex $node(node:nodeName) 0]
+ }
+ empty {
+ if {![info exists node(element:empty)]} {
+ return 0
+ } else {
+ return $node(element:empty)
+ }
+ }
+ default {
+ return $node(node:$option)
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
+ return $node(node:$option)
+ } else {
+ return -code error "bad option \"[lindex $args 0]\""
+ }
+ }
+ configure {
+ if {[llength $args] == 1} {
+ return [document cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "no value specified for option \"[lindex $args end]\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
+ return -code error "option \"$option\" cannot be modified"
+ } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
+ return -code error "not implemented"
+ } else {
+ return -code error "bad option \"$option\""
+ }
+ }
+ }
+ }
+
+ getAttribute {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::element getAttribute token name\""
+ }
+
+ set result {}
+
+ upvar #0 $node(element:attributeList) attrList
+ catch {set result $attrList([lindex $args 0])}
+
+ return $result
+
+ }
+
+ setAttribute {
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \"dom::element setAttribute token name value\""
+ }
+
+ # Check that the attribute name is kosher
+ if {![regexp ^$::xml::Name\$ [lindex $args 0]]} {
+ return -code error "invalid attribute name \"[lindex $args 0]\""
+ }
+
+ upvar #0 $node(element:attributeList) attrList
+ set evid [CreateEvent $token DOMAttrModified]
+ set oldValue {}
+ catch {set oldValue $attrList([lindex $args 0])}
+ event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0] [expr {[info exists attrList([lindex $args 0])] ? "modification" : "addition"}]
+ set result [set attrList([lindex $args 0]) [lindex $args 1]]
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+
+ }
+
+ removeAttribute {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"dom::element removeAttribute token name\""
+ }
+
+ upvar #0 $node(element:attributeList) attrList
+ catch {unset attrList([lindex $args 0])}
+
+ event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0] -attrChange removal
+
+ }
+
+ getAttributeNS {
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \"dom::element getAttributeNS token ns name\""
+ }
+
+ set result {}
+ upvar #0 $node(element:attributeList) attrList
+ catch {set result $attrList([lindex $args 0]^[lindex $args 1])}
+
+ return $result
+
+ }
+
+ setAttributeNS {
+ if {[llength $args] != 3} {
+ return -code error "wrong # args: should be \"dom::element setAttributeNS token ns attr value\""
+ }
+
+ # Check that the attribute name is kosher
+ if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} {
+ return -code error "invalid qualified attribute name \"[lindex $args 1]\""
+ }
+
+ # BUG: At the moment the prefix is ignored
+
+ upvar #0 $node(element:attributeList) attrList
+ set evid [CreateEvent $token DOMAttrModified]
+ set oldValue {}
+ catch {set oldValue $attrList([lindex $args 0]^$localName)}
+ event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName [expr {[info exists attrList([lindex $args 0]^$localName)] ? "modification" : "addition"}]
+ set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]]
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+
+ }
+
+ removeAttributeNS {
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \"dom::element removeAttributeNS token ns name\""
+ }
+
+ upvar #0 $node(element:attributeList) attrList
+ catch {unset attrList([lindex $args 0]^[lindex $args 1])}
+
+ event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1] -attrChange removal
+
+ }
+
+ getAttributeNode {
+ array set tmp [array get $node(element:attributeList)]
+ if {![info exists tmp([lindex $args 0])]} {
+ return {}
+ }
+
+ # Synthesize an attribute node if one doesn't already exist
+ array set attrNodes $node(element:attributeNodes)
+ if {[catch {set result $attrNodes([lindex $args 0])}]} {
+ set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])]
+ lappend node(element:attributeNodes) [lindex $args 0] $result
+ }
+ }
+
+ setAttributeNode -
+ removeAttributeNode -
+ getAttributeNodeNS -
+ setAttributeNodeNS -
+ removeAttributeNodeNS {
+ return -code error "not yet implemented"
+ }
+
+ getElementsByTagName {
+ if {[llength $args] < 1} {
+ return -code error "wrong # args: should be \"dom::element getElementsByTagName token name\""
+ }
+
+ return [eval Element:GetByTagName [list $token [lindex $args 0]] \
+ [lrange $args 1 end]]
+ }
+
+ normalize {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be dom::element normalize token"
+ }
+
+ Element:Normalize node [set $node(node:childNodes)]
+ }
+
+ default {
+ return -code error "bad method \"$method\": should be cget, configure, getAttribute, setAttribute, removeAttribute, getAttributeNS, setAttributeNS, removeAttributeNS, getAttributeNode, setAttributeNode, removeAttributeNode, getAttributeNodeNS, setAttributeNodeNS, removeAttributeNodeNS, getElementsByTagName or normalize"
+ }
+
+ }
+
+ return $result
+}
+
+# dom::tcl::Element:GetByTagName --
+#
+# Search for (child) elements
+#
+# This used to be non-recursive, but then I read the DOM spec
+# properly and discovered that it should recurse. The -deep
+# option allows for backward-compatibility, and defaults to the
+# DOM-specified value of true.
+#
+# Arguments:
+# token parent node
+# name element type to search for
+# args configuration options
+#
+# Results:
+# The name of the variable containing the list of matching node tokens
+
+proc dom::tcl::Element:GetByTagName {token name args} {
+ upvar #0 $token node
+ upvar #0 [namespace qualifiers $token]::Document document
+
+ array set cfg {-deep 1}
+ array set cfg $args
+ set cfg(-deep) [Boolean $cfg(-deep)]
+
+ # Guard against arbitrary glob characters
+ # Checking that name is a legal XML Name does this
+ # However, '*' is permitted
+ if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} {
+ return -code error "invalid element name"
+ }
+
+ # Allocate variable name for this search
+ set searchVar ${token}search[incr document(counter)]
+ upvar \#0 $searchVar search
+
+ # Make list live by interposing on variable reads
+ # I don't think we need to interpose on unsets,
+ # and writing to this variable by the application is
+ # not permitted.
+
+ trace variable $searchVar w [namespace code Element:GetByTagName:Error]
+
+ if {[string compare $node(node:nodeType) "document"]} {
+ trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]]
+ } elseif {[llength $node(document:documentElement)]} {
+ # Document Element must exist and must be an element type node
+ trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]]
+ }
+
+ return $searchVar
+}
+
+# dom::tcl::Element:GetByTagName:Search --
+#
+# Search for elements. This does the real work.
+# Because this procedure is invoked everytime
+# the variable is read, it returns the live list.
+#
+# Arguments:
+# tokens nodes to search (inclusive)
+# name element type to search for
+# deep whether to search recursively
+# name1 \
+# name2 > appended by trace command
+# op /
+#
+# Results:
+# List of matching node tokens
+
+proc dom::tcl::Element:GetByTagName:Search {tokens name deep name1 name2 op} {
+ set result {}
+
+ foreach tok $tokens {
+ upvar #0 $tok nodeInfo
+ switch -- $nodeInfo(node:nodeType) {
+ element {
+ if {[string match $name [GetField nodeInfo(node:nodeName)]]} {
+ lappend result $tok
+ }
+ if {$deep} {
+ set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}]
+ if {[llength $childResult]} {
+ eval lappend result $childResult
+ }
+ }
+ }
+ }
+ }
+
+ if {[string length $name1]} {
+ set $name1 $result
+ return {}
+ } else {
+ return $result
+ }
+}
+
+# dom::tcl::Element:GetByTagName:Error --
+#
+# Complain about the application writing to a variable
+# that this package maintains.
+#
+# Arguments:
+# name1 \
+# name2 > appended by trace command
+# op /
+#
+# Results:
+# Error code returned.
+
+proc dom::tcl::Element:GetByTagName:Error {name1 name2 op} {
+ return -code error "dom: Read-only variable"
+}
+
+# dom::tcl::Element:Normalize --
+#
+# Normalize the text nodes
+#
+# Arguments:
+# pVar parent array variable in caller
+# nodes list of node tokens
+#
+# Results:
+# Adjacent text nodes are coalesced
+
+proc dom::tcl::Element:Normalize {pVar nodes} {
+ upvar #0 $pVar parent
+
+ set textNode {}
+
+ foreach n $nodes {
+ upvar #0 $n child
+ set cleanup {}
+
+ switch $child(node:nodeType) {
+ textNode {
+ if {[llength $textNode]} {
+
+ # Coalesce into previous node
+ set evid [CreateEvent $n DOMCharacterDataModified]
+ event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {} {}
+ append text(node:nodeValue) $child(node:nodeValue)
+ node dispatchEvent $n $evid
+ DOMImplementation destroy $evid
+
+ # Remove this child
+ upvar #0 $parent(node:childNodes) childNodes
+ set idx [lsearch $childNodes $n]
+ set childNodes [lreplace $childNodes $idx $idx]
+ unset $n
+ set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified]
+ event postMutationEvent $n DOMNodeRemoved
+
+ set $textNode [array get text]
+ } else {
+ set textNode $n
+ catch {unset text}
+ array set text [array get child]
+ }
+ }
+ element -
+ document -
+ documentFragment {
+ set textNode {}
+ Element:Normalize child [set $child(node:childNodes)]
+ }
+ default {
+ set textNode {}
+ }
+ }
+
+ eval $cleanup
+ }
+
+ return {}
+}
+
+# dom::tcl::processinginstruction --
+#
+# Functions for a processing intruction.
+#
+# Arguments:
+# method method to invoke
+# token token for node
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable piOptionsRO target
+ variable piOptionsRW data
+}
+
+proc dom::tcl::processinginstruction {method token args} {
+ variable piOptionsRO
+ variable piOptionsRW
+
+ upvar #0 $token node
+
+ set result {}
+
+ switch -- $method {
+
+ cget {
+ # Some read-only configuration options are computed
+ if {[llength $args] != 1} {
+ return -code error "too many arguments"
+ }
+ if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
+ switch $option {
+ target {
+ set result [lindex $node(node:nodeName) 0]
+ }
+ default {
+ return $node(node:$option)
+ }
+ }
+ } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
+ switch $option {
+ data {
+ return $node(node:nodeValue)
+ }
+ default {
+ return $node(node:$option)
+ }
+ }
+ } else {
+ return -code error "unknown option \"[lindex $args 0]\""
+ }
+ }
+ configure {
+ if {[llength $args] == 1} {
+ return [document cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "no value specified for option \"[lindex $args end]\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
+ return -code error "attribute \"$option\" is read-only"
+ } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
+ switch $opt {
+ data {
+ set evid [CreateEvent $token DOMCharacterDataModified]
+ event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {} {}
+ set node(node:nodeValue) $value
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+ }
+ default {
+ set node(node:$opt) $value
+ }
+ }
+ } else {
+ return -code error "unknown option \"$option\""
+ }
+ }
+ }
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+
+ }
+
+ return $result
+}
+
+#################################################
+#
+# DOM Level 2 Interfaces
+#
+#################################################
+
+# dom::tcl::event --
+#
+# Implements Event Interface
+#
+# Subclassed Interfaces are also defined here,
+# such as UIEvents.
+#
+# Arguments:
+# method method to invoke
+# token token for event
+# args arguments for method
+#
+# Results:
+# Depends on method used.
+
+namespace eval dom::tcl {
+ variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName|attrChange
+ variable eventOptionsRW {}
+
+ # Issue: should the attributes belonging to the subclassed Interface
+ # be separated out?
+
+ variable uieventOptionsRO detail|view
+ variable uieventOptionsRW {}
+
+ variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode
+ variable mouseeventOptionsRW {}
+
+ variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName
+ variable mutationeventOptionsRW {}
+}
+
+proc dom::tcl::event {method token args} {
+ variable eventOptionsRO
+ variable eventOptionsRW
+
+ upvar #0 $token event
+
+ set result {}
+
+ switch -glob -- $method {
+
+ cg* {
+ # cget
+
+ if {[llength $args] != 1} {
+ return -code error "too many arguments"
+ }
+ if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} {
+ return $event($option)
+ } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} {
+ return $event($option)
+ } else {
+ return -code error "unknown option \"[lindex $args 0]\""
+ }
+ }
+
+ co* {
+ # configure
+
+ if {[llength $args] == 1} {
+ return [event cget $token [lindex $args 0]]
+ } elseif {[expr [llength $args] % 2]} {
+ return -code error "no value specified for option \"[lindex $args end]\""
+ } else {
+ foreach {option value} $args {
+ if {[regexp [format {^-(%s)$} $eventOptionsRW] $option discard opt]} {
+ set event($opt) $value
+ } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} {
+ return -code error "attribute \"$option\" is read-only"
+ } else {
+ return -code error "unknown option \"$option\""
+ }
+ }
+ }
+
+ }
+
+ st* {
+ # stopPropagation
+
+ set event(stopPropagation) 1
+ }
+
+ pr* {
+ # preventDefault
+
+ set event(preventDefault) 1
+ }
+
+ initE* {
+ # initEvent
+
+ if {[llength $args] != 3} {
+ return -code error "wrong # args: should be dom::event initEvent token type bubbles cancelable"
+ }
+
+ if {$event(dispatched)} {
+ return -code error "event has been dispatched"
+ }
+
+ foreach {event(type) event(bubbles) event(cancelable)} $args break
+ }
+
+ initU* {
+ # initUIEvent
+
+ if {[llength $args] < 4 || [llength $args] > 5} {
+ return -code error "wrong # args: should be dom::event initUIEvent token type bubbles cancelable view detail"
+ }
+
+ if {$event(dispatched)} {
+ return -code error "event has been dispatched"
+ }
+
+ set event(detail) 0
+ foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break
+ }
+
+ initMo* {
+ # initMouseEvent
+
+ if {[llength $args] != 15} {
+ return -code error "wrong # args: should be dom::event initMouseEvent token type bubbles cancelable view detail screenX screenY clientX clientY ctrlKey altKey shiftKey metaKey button relatedNode"
+ }
+
+ if {$event(dispatched)} {
+ return -code error "event has been dispatched"
+ }
+
+ set event(detail) 1
+ foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail) event(screenX) event(screenY) event(clientX) event(clientY) event(ctrlKey) event(altKey) event(shiftKey) event(metaKey) event(button) event(relatedNode)} $args break
+ }
+
+ initMu* {
+ # initMutationEvent
+
+ if {[llength $args] != 8} {
+ return -code error "wrong # args: should be dom::event initMutationEvent token type bubbles cancelable relatedNode prevValue newValue attrName attrChange"
+ }
+
+ if {$event(dispatched)} {
+ return -code error "event has been dispatched"
+ }
+
+ foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName) event(attrChange)} $args break
+ }
+
+ postUI* {
+ # postUIEvent, non-standard convenience method
+
+ set evType [lindex $args 0]
+ array set evOpts [list \
+ -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \
+ -view {} \
+ -detail {} \
+ ]
+ array set evOpts [lrange $args 1 end]
+
+ set evid [CreateEvent $token $evType]
+ event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail)
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+
+ }
+
+ postMo* {
+ # postMouseEvent, non-standard convenience method
+
+ set evType [lindex $args 0]
+ array set evOpts [list \
+ -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \
+ -view {} \
+ -detail {} \
+ -screenX {} \
+ -screenY {} \
+ -clientX {} \
+ -clientY {} \
+ -ctrlKey {} \
+ -altKey {} \
+ -shiftKey {} \
+ -metaKey {} \
+ -button {} \
+ -relatedNode {} \
+ ]
+ array set evOpts [lrange $args 1 end]
+
+ set evid [CreateEvent $token $evType]
+ event initMouseEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) $evOpts(-screenX) $evOpts(-screenY) $evOpts(-clientX) $evOpts(-clientY) $evOpts(-ctrlKey) $evOpts(-altKey) $evOpts(-shiftKey) $evOpts(-metaKey) $evOpts(-button) $evOpts(-relatedNode)
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+
+ }
+
+ postMu* {
+ # postMutationEvent, non-standard convenience method
+
+ set evType [lindex $args 0]
+ array set evOpts [list \
+ -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \
+ -relatedNode {} \
+ -prevValue {} -newValue {} \
+ -attrName {} -attrChange {} \
+ ]
+ array set evOpts [lrange $args 1 end]
+
+ set evid [CreateEvent $token $evType]
+ event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName) $evOpts(-attrChange)
+ node dispatchEvent $token $evid
+ DOMImplementation destroy $evid
+
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+ }
+
+ return $result
+}
+
+# dom::tcl::CreateEvent --
+#
+# Create an event object
+#
+# Arguments:
+# token parent node
+# type event type
+# args configuration options
+#
+# Results:
+# Returns event token
+
+proc dom::tcl::CreateEvent {token type args} {
+ array set opts $args
+ if {[string length $token]} {
+ upvar #0 $token parent
+ upvar #0 [namespace qualifiers $token]::Document document
+ set child [namespace qualifiers $token]::event[incr document(counter)]
+ } elseif {[info exists $opts(-document)]} {
+ upvar #0 $opts(-document) document
+ set child [namespace qualifiers $opts(-document)]::event[incr document(counter)]
+ }
+
+ upvar #0 $child event
+
+ # Create the event
+ array set event [list \
+ node:nodeType event \
+ type $type \
+ target {} \
+ currentNode {} \
+ cancelable 1 \
+ stopPropagation 0 \
+ preventDefault 0 \
+ dispatched 0 \
+ bubbles 1 \
+ eventPhase {} \
+ timeStamp [clock clicks -milliseconds] \
+ ]
+
+ proc $child {method args} "return \[eval [namespace current]::event \[list \$method\] $child \$args\]"
+ trace add command $child delete [namespace code [list Node:Delete $child]]
+
+ return $child
+}
+
+#################################################
+#
+# Serialisation
+#
+#################################################
+
+# dom::tcl::Serialize:documentFragment --
+#
+# Produce text for documentFragment.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:documentFragment {token args} {
+ upvar #0 $token node
+
+ if {[string compare "Document" [namespace tail $token]]} {
+ return [eval [list Serialize:node $token] $args]
+ } else {
+ if {[string compare {} [GetField node(document:documentElement)]]} {
+ return [eval Serialize:document [list $token] $args]
+ } else {
+ return -code error "document has no document element"
+ }
+ }
+
+}
+
+# dom::tcl::Serialize:document --
+#
+# Produce text for document.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:document {token args} {
+ upvar #0 $token node
+ array set opts {
+ -showxmldecl 1
+ -showdoctypedecl 1
+ }
+ array set opts $args
+
+ set result {}
+
+ if {[string length $node(document:doctype)]} {
+
+ upvar #0 $node(document:doctype) doctype
+
+ # Bug fix: can't use Serialize:attributeList for XML declaration,
+ # since attributes must occur in a given order (XML 2.8 [23])
+
+ set result {}
+
+ if {$opts(-showxmldecl)} {
+ append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n
+ }
+ if {$opts(-showdoctypedecl)} {
+ # Is document element in an XML Namespace?
+ # If so then include prefix in doctype decl
+ foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break
+ if {![string length $prefix]} {
+ # The prefix may not have been allocated yet
+ upvar #0 $node(document:documentElement) docel
+ if {[info exists docel(node:namespaceURI)] && \
+ [string length $docel(node:namespaceURI)]} {
+ set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)]
+ set docelName $declPrefix:$doctype(doctype:name)
+ } else {
+ set docelName $doctype(doctype:name)
+ }
+ } else {
+ set docelName $doctype(doctype:name)
+ }
+ # Applied patch by Marco Gonnelli, bug #590914
+ append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:publicId) $doctype(doctype:systemId)][expr {[string length $doctype(doctype:internalSubset)] ? " \[[string trim $doctype(doctype:internalSubset) \{\} ]\]" : {}}]>\n
+ }
+ }
+
+ # BUG #525505: Want to serialize all children including the
+ # document element.
+
+ if {[info exists $node(node:childNodes)]} {
+ foreach child [set $node(node:childNodes)] {
+ append result [eval Serialize:[node cget $child -nodeType] [list $child] $args]
+ }
+ }
+
+ return $result
+}
+
+# dom::tcl::Serialize:ExternalID --
+#
+# Returned appropriately quoted external identifiers
+#
+# Arguments:
+# publicid public identifier
+# systemid system identifier
+#
+# Results:
+# text
+
+proc dom::tcl::Serialize:ExternalID {publicid systemid} {
+
+ switch -glob -- [string length $publicid],[string length $systemid] {
+ 0,0 {
+ return {}
+ }
+ 0,* {
+ return " SYSTEM \"$systemid\""
+ }
+ *,* {
+ # Patch from c.l.t., Richard Calmbach (rc@hnc.com )
+ return " PUBLIC \"$publicid\" \"$systemid\""
+ }
+ }
+
+ return {}
+}
+
+# dom::tcl::Serialize:XMLDecl --
+#
+# Produce text for XML Declaration attribute.
+# Order is determine by document serialisation procedure.
+#
+# Arguments:
+# attr required attribute
+# attList attribute list
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:XMLDecl {attr attrList} {
+ array set data $attrList
+ if {![info exists data($attr)]} {
+ return {}
+ } elseif {[string length $data($attr)]} {
+ return " $attr='$data($attr)'"
+ } else {
+ return {}
+ }
+}
+
+# dom::tcl::Serialize:node --
+#
+# Produce text for an arbitrary node.
+# This simply serializes the child nodes of the node.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:node {token args} {
+ upvar #0 $token node
+ array set opts $args
+
+ if {[info exists opts(-indent)]} {
+ # NB. 0|1 cannot be used as booleans - mention this in docn
+ if {[regexp {^false|no|off$} $opts(-indent)]} {
+ # No action required
+ } elseif {[regexp {^true|yes|on$} $opts(-indent)]} {
+ set opts(-indent) 1
+ } else {
+ incr opts(-indent)
+ }
+ }
+
+ set result {}
+ foreach childToken [set $node(node:childNodes)] {
+ upvar #0 $childToken child
+ append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]]
+ }
+
+ return $result
+}
+
+# dom::tcl::Serialize:element --
+#
+# Produce text for an element.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:element {token args} {
+ upvar #0 $token node
+ array set opts {-newline {}}
+ array set opts $args
+
+ set result {}
+ set newline {}
+ if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
+ append result \n
+ set newline \n
+ }
+ append result [eval Serialize:Indent [array get opts]]
+ switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] {
+
+ 1,1 {
+ # XML Namespace is in scope, prefix supplied
+ if {[string length $node(node:prefix)]} {
+ # Make sure that there's a declaration for this XML Namespace
+ set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)]
+ # ASSERTION: $declPrefix == $node(node:prefix)
+ set nsPrefix $node(node:prefix):
+ } elseif {[string length $node(node:namespaceURI)]} {
+ set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
+ } else {
+ set nsPrefix {}
+ }
+ }
+
+ 1,0 {
+ # XML Namespace is in scope, no prefix
+ set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]:
+ if {![string compare $nsPrefix :]} {
+ set nsPrefix {}
+ }
+ }
+
+ 0,1 {
+ # Internal error
+ set nsPrefix {}
+ }
+
+ 0,0 -
+ default {
+ # No XML Namespace is in scope
+ set nsPrefix {}
+ }
+ }
+ append result <$nsPrefix$node(node:localName)
+
+ append result [Serialize:attributeList [array get $node(element:attributeList)]]
+
+ if {![llength [set $node(node:childNodes)]]} {
+
+ append result />$newline
+
+ } else {
+
+ append result >$newline
+
+ # Do the children
+ if {[hasmixedcontent $token]} {
+ set opts(-indent) no
+ }
+ append result [eval Serialize:node [list $token] [array get opts]]
+
+ append result [eval Serialize:Indent [array get opts]]
+ append result "$newline</$nsPrefix$node(node:localName)>$newline"
+
+ }
+
+ return $result
+}
+
+# dom::tcl::GetNamespacePrefix --
+#
+# Determine the XML Namespace prefix for a Namespace URI
+#
+# Arguments:
+# token node token
+# nsuri XML Namespace URI
+# args configuration options
+#
+# Results:
+# Returns prefix.
+# May add prefix information to node
+
+proc dom::tcl::GetNamespacePrefix {token nsuri args} {
+ upvar #0 $token node
+ array set options $args
+
+ GetNamespaceDecl $token $nsuri declNode prefix
+
+ if {[llength $declNode]} {
+ # A declaration was found for this Namespace URI
+ return $prefix
+ } else {
+ # No declaration found. Allocate a prefix
+ # and add XML Namespace declaration
+ set prefix {}
+ catch {set prefix $options(-prefix)}
+ if {![string compare $prefix {}]} {
+ upvar #0 [namespace qualifiers $token]::Document document
+ set prefix ns[incr document(counter)]
+ }
+ set node(node:prefix) $prefix
+ upvar \#0 $node(element:attributeList) attrs
+ set attrs(${::dom::xmlnsURI}^$prefix) $nsuri
+
+ return $prefix
+ }
+}
+
+# dom::tcl::GetNamespaceDecl --
+#
+# Find the XML Namespace declaration.
+#
+# Arguments:
+# token node token
+# nsuri XML Namespace URI
+# nodeVar Variable name for declaration
+# prefVar Variable for prefix
+#
+# Results:
+# If the declaration is found returns node and prefix
+
+proc dom::tcl::GetNamespaceDecl {token nsuri nodeVar prefVar} {
+ upvar #0 $token node
+ upvar $nodeVar declNode
+ upvar $prefVar prefix
+
+ while {[string length $node(node:parentNode)]} {
+
+ # Check this node's XML Namespace declarations
+ catch {unset attrs}
+ array set attrs [array get $node(element:attributeList)]
+ foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] {
+ if {![string compare $decluri $nsuri]} {
+ regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix
+ set declNode $token
+ return
+ }
+ }
+
+ # Move up to parent
+ set token $node(node:parentNode)
+ upvar #0 $token node
+ }
+
+ # Got to Document node and didn't find XML NS decl
+ set prefix {}
+ set declNode {}
+}
+
+# dom::tcl::Serialize:textNode --
+#
+# Produce text for a text node. This procedure may
+# return a CDATA section where appropriate.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:textNode {token args} {
+ upvar #0 $token node
+
+ if {$node(node:cdatasection)} {
+ return [Serialize:CDATASection $node(node:nodeValue)]
+ } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} {
+ return [Serialize:CDATASection $node(node:nodeValue)]
+ } else {
+ return [Encode $node(node:nodeValue)]
+ }
+}
+
+# dom::tcl::Serialize:ExceedsThreshold --
+#
+# Applies heuristic(s) to determine whether a text node
+# should be formatted as a CDATA section.
+#
+# Arguments:
+# text node text
+#
+# Results:
+# Boolean.
+
+proc dom::tcl::Serialize:ExceedsThreshold {text} {
+ return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}]
+}
+
+# dom::tcl::Serialize:CDATASection --
+#
+# Formats a CDATA section.
+#
+# Arguments:
+# text node text
+#
+# Results:
+# XML text.
+
+proc dom::tcl::Serialize:CDATASection {text} {
+ set result {}
+ while {[regexp {(.*)]]>(.*)} $text discard text trailing]} {
+ set result \]\]&gt\;<!\[CDATA\[$trailing\]\]>$result
+ }
+ return <!\[CDATA\[$text\]\]>$result
+}
+
+# dom::tcl::Serialize:processingInstruction --
+#
+# Produce text for a PI node.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:processingInstruction {token args} {
+ upvar #0 $token node
+
+ return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>"
+}
+
+# dom::tcl::Serialize:comment --
+#
+# Produce text for a comment node.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:comment {token args} {
+ upvar #0 $token node
+
+ return [eval Serialize:Indent $args]<!--$node(node:nodeValue)-->
+}
+
+# dom::tcl::Serialize:entityReference --
+#
+# Produce text for an entity reference.
+#
+# Arguments:
+# token node token
+# args configuration options
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:entityReference {token args} {
+ upvar #0 $token node
+
+ return &$node(node:nodeName)\;
+}
+
+# dom::tcl::Encode --
+#
+# Encode special characters
+#
+# Arguments:
+# value text value
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Encode value {
+ array set Entity {
+ $ $
+ < &lt;
+ > &gt;
+ & &amp;
+ \" &quot;
+ ' &apos;
+ }
+
+ regsub -all {([$<>&"'])} $value {$Entity(\1)} value
+
+ return [subst -nocommand -nobackslash $value]
+}
+
+# dom::tcl::Serialize:attributeList --
+#
+# Produce text for an attribute list.
+#
+# Arguments:
+# l name/value paired list
+#
+# Results:
+# XML format text.
+
+proc dom::tcl::Serialize:attributeList {l} {
+
+ set result {}
+ foreach {name value} $l {
+
+ if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} {
+ if {[string compare $nsuri $::dom::xmlnsURI]} {
+ # Need the node token to resolve the Namespace URI
+ append result { } ?:$prefix =
+ } else {
+ # A Namespace declaration
+ append result { } xmlns:$prefix =
+ }
+ } else {
+ append result { } $name =
+ }
+
+ # Handle special characters
+ regsub -all & $value {\&amp;} value
+ regsub -all < $value {\&lt;} value
+
+ if {![string match *\"* $value]} {
+ append result \"$value\"
+ } elseif {![string match *'* $value]} {
+ append result '$value'
+ } else {
+ regsub -all \" $value {\&quot;} value
+ append result \"$value\"
+ }
+
+ }
+
+ return $result
+}
+
+# dom::tcl::Serialize:Indent --
+#
+# Calculate the indentation required, if any
+#
+# Arguments:
+# args configuration options, which may specify -indent
+#
+# Results:
+# May return white space
+
+proc dom::tcl::Serialize:Indent args {
+ array set opts [list -indentspec $::dom::indentspec]
+ array set opts $args
+
+ if {![info exists opts(-indent)] || \
+ [regexp {^false|no|off$} $opts(-indent)]} {
+ return {}
+ }
+
+ if {[regexp {^true|yes|on$} $opts(-indent)]} {
+ # Default indent level is 0
+ return \n
+ }
+
+ if {!$opts(-indent)} {
+ return \n
+ }
+
+ set ws [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }]
+ regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws
+
+ return $ws
+
+}
+
+#################################################
+#
+# Parsing
+#
+#################################################
+
+# dom::tcl::ParseElementStart --
+#
+# Push a new element onto the stack.
+#
+# Arguments:
+# stateVar global state array variable
+# name element name
+# attrList attribute list
+# args configuration options
+#
+# Results:
+# An element is created within the currently open element.
+
+proc dom::tcl::ParseElementStart {stateVar name attrList args} {
+
+ upvar #0 $stateVar state
+ array set opts $args
+
+ # Push namespace declarations
+ # We need to be able to map namespaceURI's back to prefixes
+ set nsattrlists {}
+ catch {
+ foreach {namespaceURI prefix} $opts(-namespacedecls) {
+ lappend state(NS:$namespaceURI) $prefix
+
+ # Also, synthesize namespace declaration attributes
+ # TclXML is a little too clever when it parses them away!
+
+ lappend nsattrlists $prefix $namespaceURI
+ }
+ lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists
+
+ }
+
+ set nsarg {}
+ catch {
+ lappend nsarg -namespace $opts(-namespace)
+ lappend nsarg -localname $name
+ lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end]
+ }
+
+ lappend state(current) \
+ [eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]]
+
+ if {[info exists opts(-empty)] && $opts(-empty)} {
+ # Flag this node as being an empty element
+ upvar #0 [lindex $state(current) end] node
+ set node(element:empty) 1
+ }
+
+ # Temporary: implement -progresscommand here, because of broken parser
+ if {[string length $state(-progresscommand)]} {
+ if {!([incr state(progCounter)] % $state(-chunksize))} {
+ uplevel #0 $state(-progresscommand)
+ }
+ }
+}
+
+# dom::tcl::ParseElementEnd --
+#
+# Pop an element from the stack.
+#
+# Arguments:
+# stateVar global state array variable
+# name element name
+# args configuration options
+#
+# Results:
+# Currently open element is closed.
+
+proc dom::tcl::ParseElementEnd {stateVar name args} {
+ upvar #0 $stateVar state
+
+ set state(current) [lreplace $state(current) end end]
+}
+
+# dom::tcl::ParseCharacterData --
+#
+# Add a textNode to the currently open element.
+#
+# Arguments:
+# stateVar global state array variable
+# data character data
+#
+# Results:
+# A textNode is created.
+
+proc dom::tcl::ParseCharacterData {stateVar data} {
+ upvar #0 $stateVar state
+
+ CreateTextNode [lindex $state(current) end] $data
+}
+
+# dom::tcl::ParseProcessingInstruction --
+#
+# Add a PI to the currently open element.
+#
+# Arguments:
+# stateVar global state array variable
+# name PI name
+# target PI target
+#
+# Results:
+# A processingInstruction node is created.
+
+proc dom::tcl::ParseProcessingInstruction {stateVar name target} {
+ upvar #0 $stateVar state
+
+ CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
+}
+
+# dom::tcl::ParseXMLDeclaration --
+#
+# Add information from the XML Declaration to the document.
+#
+# Arguments:
+# stateVar global state array variable
+# version version identifier
+# encoding character encoding
+# standalone standalone document declaration
+#
+# Results:
+# Document node modified.
+
+proc dom::tcl::ParseXMLDeclaration {stateVar version encoding standalone} {
+ upvar #0 $stateVar state
+
+ upvar #0 $state(docNode) document
+ array set xmldecl $document(document:xmldecl)
+
+ array set xmldecl [list version $version \
+ standalone $standalone \
+ encoding $encoding \
+ ]
+
+ set document(document:xmldecl) [array get xmldecl]
+
+ return {}
+}
+
+# dom::tcl::ParseDocType --
+#
+# Add a Document Type Declaration node to the document.
+#
+# Arguments:
+# stateVar global state array variable
+# root root element type
+# publit public identifier literal
+# systemlist system identifier literal
+# dtd internal DTD subset
+#
+# Results:
+# DocType node added
+
+proc dom::tcl::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}} args} {
+ upvar #0 $stateVar state
+ upvar #0 $state(docNode) document
+
+ set document(document:doctype) [CreateDocType $state(docNode) $publit $systemlit $dtd]
+
+ return {}
+}
+
+# dom::tcl::ParseComment --
+#
+# Parse comment
+#
+# Arguments:
+# stateVar state array
+# data comment data
+#
+# Results:
+# Comment node added to DOM tree
+
+proc dom::tcl::ParseComment {stateVar data} {
+ upvar #0 $stateVar state
+
+ CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data
+
+ return {}
+}
+
+# dom::tcl::ParseEntityReference --
+#
+# Parse an entity reference
+#
+# Arguments:
+# stateVar state variable
+# ref entity
+#
+# Results:
+# Entity reference node added to DOM tree
+
+proc dom::tcl::ParseEntityReference {stateVar ref} {
+ upvar #0 $stateVar state
+
+ CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref
+
+ return {}
+}
+
+#################################################
+#
+# Trim white space
+#
+#################################################
+
+# dom::tcl::Trim --
+#
+# Remove textNodes that only contain white space
+#
+# Arguments:
+# nodeid node to trim
+#
+# Results:
+# textNode nodes may be removed (from descendants)
+
+proc dom::tcl::Trim nodeid {
+ upvar #0 $nodeid node
+
+ switch $node(node:nodeType) {
+
+ textNode {
+ if {![string length [string trim $node(node:nodeValue)]]} {
+ node removeChild $node(node:parentNode) $nodeid
+ }
+ }
+
+ default {
+ # Some nodes have no child list. Reported by Jim Hollister <jhollister@objectspace.com>
+ set children {}
+ catch {set children [set $node(node:childNodes)]}
+ foreach child $children {
+ Trim $child
+ }
+ }
+
+ }
+
+ return {}
+}
+
+#################################################
+#
+# XPath support
+#
+#################################################
+
+# dom::tcl::XPath:CreateNode --
+#
+# Given an XPath expression, create the node
+# referred to by the expression. Nodes required
+# as steps of the path are created if they do
+# not exist.
+#
+# Arguments:
+# node context node
+# path location path
+#
+# Results:
+# Node(s) created in the DOM tree.
+# Returns token for deepest node in the expression.
+
+proc dom::tcl::XPath:CreateNode {node path} {
+
+ set root [::dom::node cget $node -ownerDocument]
+
+ set spath [::xpath::split $path]
+
+ if {[llength $spath] <= 1} {
+ # / - do nothing
+ return $root
+ }
+
+ if {![llength [lindex $spath 0]]} {
+ # Absolute location path
+ set context $root
+ set spath [lrange $spath 1 end]
+ set contexttype document
+ } else {
+ set context $node
+ set contexttype [::dom::node cget $node -nodeType]
+ }
+
+ foreach step $spath {
+
+ # Sanity check on path
+ switch $contexttype {
+ document -
+ documentFragment -
+ element {}
+ default {
+ return -code error "node type \"$contexttype\" have no children"
+ }
+ }
+
+ switch [lindex $step 0] {
+
+ child {
+ if {[llength [lindex $step 1]] > 1} {
+ foreach {nodetype discard} [lindex $step 1] break
+
+ switch -- $nodetype {
+ text {
+ set posn [CreateNode:FindPosition [lindex $step 2]]
+
+ set count 0
+ set targetNode {}
+ foreach child [::dom::node children $context] {
+ switch [::dom::node cget $child -nodeType] {
+ textNode {
+ incr count
+ if {$count == $posn} {
+ set targetNode $child
+ break
+ }
+ }
+ default {}
+ }
+ }
+
+ if {[string length $targetNode]} {
+ set context $targetNode
+ } else {
+ # Creating sequential textNodes doesn't make sense
+ set context [::dom::document createTextNode $context {}]
+ }
+ set contexttype textNode
+ }
+ default {
+ return -code error "node type test \"${nodetype}()\" not supported"
+ }
+ }
+ } else {
+ # Find the child element
+ set posn [CreateNode:FindPosition [lindex $step 2]]
+
+ set count 0
+ set targetNode {}
+ foreach child [::dom::node children $context] {
+ switch [node cget $child -nodeType] {
+ element {
+ if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} {
+ incr count
+ if {$count == $posn} {
+ set targetNode $child
+ break
+ }
+ }
+ }
+ default {}
+ }
+ }
+
+ if {[string length $targetNode]} {
+ set context $targetNode
+ } else {
+ # Didn't find it so create required elements
+ while {$count < $posn} {
+ set child [::dom::document createElement $context [lindex $step 1]]
+ incr count
+ }
+ set context $child
+ }
+ set contexttype element
+
+ }
+ }
+
+ default {
+ return -code error "axis \"[lindex $step 0]\" is not supported"
+ }
+ }
+ }
+
+ return $context
+}
+
+# dom::tcl::CreateNode:FindPosition --
+
+proc dom::tcl::CreateNode:FindPosition predicates {
+ switch [llength $predicates] {
+ 0 {
+ return 1
+ }
+ 1 {
+ # Fall-through
+ }
+ default {
+ return -code error "multiple predicates not yet supported"
+ }
+ }
+ set predicate [lindex $predicates 0]
+
+ switch -- [lindex [lindex $predicate 0] 0] {
+ function {
+ switch -- [lindex [lindex $predicate 0] 1] {
+ position {
+ if {[lindex $predicate 1] == "="} {
+ if {[string compare [lindex [lindex $predicate 2] 0] "number"]} {
+ return -code error "operand must be a number"
+ } else {
+ set posn [lindex [lindex $predicate 2] 1]
+ }
+ } else {
+ return -code error "operator must be \"=\""
+ }
+ }
+ default {
+ return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported"
+ }
+ }
+ }
+ default {
+ return -code error "predicate must be position() function"
+ }
+ }
+
+ return $posn
+}
+
+# dom::tcl::XPath:SelectNode --
+#
+# Match nodes with an XPath location path
+#
+# Arguments:
+# ctxt context - Tcl list
+# path location path
+#
+# Results:
+# Returns Tcl list of matching nodes
+
+proc dom::tcl::XPath:SelectNode {ctxt path} {
+
+ if {![llength $ctxt]} {
+ return {}
+ }
+
+ set spath [xpath::split $path]
+
+ if {[string length [node parent [lindex $ctxt 0]]]} {
+ set root [namespace qualifiers [lindex $ctxt 0]]::Document
+ } else {
+ set root [lindex $ctxt 0]
+ }
+
+ if {[llength $spath] == 0} {
+ return $root
+ }
+ if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} {
+ return $root
+ }
+
+ if {![llength [lindex $spath 0]]} {
+ set ctxt $root
+ set spath [lrange $spath 1 end]
+ }
+
+ return [XPath:SelectNode:Rel $ctxt $spath]
+}
+
+# dom::tcl::XPath:SelectNode:Rel --
+#
+# Match nodes with an XPath location path
+#
+# Arguments:
+# ctxt context - Tcl list
+# path split location path
+#
+# Results:
+# Returns Tcl list of matching nodes
+
+proc dom::tcl::XPath:SelectNode:Rel {ctxt spath} {
+ if {![llength $spath]} {
+ return $ctxt
+ }
+
+ set step [lindex $spath 0]
+ set result {}
+ switch [lindex $step 0] {
+
+ child {
+ # All children are candidates
+ set children {}
+ foreach node [XPath:SN:GetElementTypeNodes $ctxt] {
+ eval lappend children [node children $node]
+ }
+
+ # Now apply node test to each child
+ foreach node $children {
+ if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
+ lappend result $node
+ }
+ }
+
+ }
+
+ descendant-or-self {
+ foreach node $ctxt {
+ if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} {
+ lappend result $node
+ }
+ eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
+ }
+ }
+
+ descendant {
+ foreach node $ctxt {
+ eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]]
+ }
+ }
+
+ attribute {
+ if {[string compare [lindex $step 1] "*"]} {
+ foreach node $ctxt {
+ set attrNode [element getAttributeNode $node [lindex $step 1]]
+ if {[llength $attrNode]} {
+ lappend result $attrNode
+ }
+ }
+ } else {
+ # All attributes are returned
+ foreach node $ctxt {
+ foreach attrName [array names [node cget $node -attributes]] {
+ set attrNode [element getAttributeNode $node $attrName]
+ if {[llength $attrNode]} {
+ lappend result $attrNode
+ }
+ }
+ }
+ }
+ }
+
+ default {
+ return -code error "axis \"[lindex $step 0]\" is not supported"
+ }
+ }
+
+ # Now apply predicates
+ set result [XPath:ApplyPredicates $result [lindex $step 2]]
+
+ # Apply the next location step
+ return [XPath:SelectNode:Rel $result [lrange $spath 1 end]]
+}
+
+# dom::tcl::XPath:SN:GetElementTypeNodes --
+#
+# Reduce nodeset to those nodes of element type
+#
+# Arguments:
+# nodeset set of nodes
+#
+# Results:
+# Returns nodeset in which all nodes are element type
+
+proc dom::tcl::XPath:SN:GetElementTypeNodes nodeset {
+ set result {}
+ foreach node $nodeset {
+ switch [node cget $node -nodeType] {
+ document -
+ documentFragment -
+ element {
+ lappend result $node
+ }
+ default {}
+ }
+ }
+ return $result
+}
+
+# dom::tcl::XPath:SN:ApplyNodeTest --
+#
+# Apply the node test to a node
+#
+# Arguments:
+# node DOM node to test
+# test node test
+#
+# Results:
+# 1 if node passes, 0 otherwise
+
+proc dom::tcl::XPath:SN:ApplyNodeTest {node test} {
+ if {[llength $test] > 1} {
+ foreach {name typetest} $test break
+ # Node type test
+ switch -glob -- $name,[node cget $node -nodeType] {
+ node,* {
+ return 1
+ }
+ text,textNode -
+ comment,comment -
+ processing-instruction,processingInstruction {
+ return 1
+ }
+ text,* -
+ comment,* -
+ processing-instruction,* {
+ return 0
+ }
+ default {
+ return -code error "illegal node type test \"[lindex $step 1]\""
+ }
+ }
+ } else {
+ # Node name test
+ switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] \
+ \\*,element,* {
+ return 1
+ } \
+ \\*,* {
+ return 0
+ } \
+ *,element,$test {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# dom::tcl::XPath:SN:DescendAndTest --
+#
+# Descend the element hierarchy,
+# apply the node test as we go
+#
+# Arguments:
+# nodeset nodes to be tested and descended
+# test node test
+#
+# Results:
+# Returned nodeset of nodes which pass the test
+
+proc dom::tcl::XPath:SN:DescendAndTest {nodeset test} {
+ set result {}
+
+ foreach node $nodeset {
+ if {[XPath:SN:ApplyNodeTest $node $test]} {
+ lappend result $node
+ }
+ switch [node cget $node -nodeType] {
+ document -
+ documentFragment -
+ element {
+ eval lappend result [XPath:SN:DescendAndTest [node children $node] $test]
+ }
+ }
+ }
+
+ return $result
+}
+
+# dom::tcl::XPath:ApplyPredicates --
+#
+# Filter a nodeset with predicates
+#
+# Arguments:
+# ctxt current context nodeset
+# preds list of predicates
+#
+# Results:
+# Returns new (possibly reduced) context nodeset
+
+proc dom::tcl::XPath:ApplyPredicates {ctxt preds} {
+
+ set result {}
+ foreach node $ctxt {
+ set passed 1
+ foreach predicate $preds {
+ if {![XPath:ApplyPredicate $node $predicate]} {
+ set passed 0
+ break
+ }
+ }
+ if {$passed} {
+ lappend result $node
+ }
+ }
+
+ return $result
+}
+
+# dom::tcl::XPath:ApplyPredicate --
+#
+# Filter a node with a single predicate
+#
+# Arguments:
+# node current context node
+# pred predicate
+#
+# Results:
+# Returns boolean
+
+proc dom::tcl::XPath:ApplyPredicate {node pred} {
+
+ switch -- [lindex $pred 0] {
+ = -
+ != -
+ >= -
+ <= -
+ > -
+ > {
+
+ if {[llength $pred] != 3} {
+ return -code error "malformed expression"
+ }
+
+ set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]]
+ set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]]
+
+ # Convert operands to the correct type, if necessary
+ switch -glob [lindex $operand1 0],[lindex $operand2 0] {
+ literal,literal {
+ return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
+ }
+
+ number,number -
+ literal,number -
+ number,literal {
+ # Compare as numbers
+ return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]]
+ }
+
+ boolean,boolean {
+ # Compare as booleans
+ return -code error "boolean comparison not yet implemented"
+ }
+
+ node,node {
+ # Nodeset comparison
+ return -code error "nodeset comparison not yet implemented"
+ }
+
+ node,* {
+ set value {}
+ if {[llength [lindex $operand1 1]]} {
+ set value [node stringValue [lindex [lindex $operand1 1] 0]]
+ }
+ return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]]
+ }
+ *,node {
+ set value {}
+ if {[llength [lindex $operand2 1]]} {
+ set value [node stringValue [lindex [lindex $operand2 1] 0]]
+ }
+ return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]]
+ }
+
+ default {
+ return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]"
+ }
+ }
+ }
+
+ function {
+ return -code error "invalid predicate"
+ }
+ number -
+ literal {
+ return -code error "invalid predicate"
+ }
+
+ path {
+ set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]]
+ return [expr {[llength $nodeset] > 0 ? 1 : 0}]
+ }
+
+ }
+
+ return 1
+}
+
+# dom::tcl::XPath:Pred:Compare --
+
+proc dom::tcl::XPath:Pred:CompareLiterals {op operand1 operand2} {
+ set result [string compare $operand1 $operand2]
+
+ # The obvious:
+ #return [expr {$result $opMap($op) 0}]
+ # doesn't compile
+
+ switch $op {
+ = {
+ return [expr {$result == 0}]
+ }
+ != {
+ return [expr {$result != 0}]
+ }
+ <= {
+ return [expr {$result <= 0}]
+ }
+ >= {
+ return [expr {$result >= 0}]
+ }
+ < {
+ return [expr {$result < 0}]
+ }
+ > {
+ return [expr {$result > 0}]
+ }
+ }
+ return -code error "internal error"
+}
+
+# dom::tcl::XPath:Pred:ResolveExpr --
+
+proc dom::tcl::XPath:Pred:ResolveExpr {node expr} {
+
+ switch [lindex $expr 0] {
+ path {
+ return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]]
+ }
+
+ function -
+ group {
+ return -code error "[lindex $expr 0] not yet implemented"
+ }
+ literal -
+ number -
+ boolean {
+ return $expr
+ }
+
+ default {
+ return -code error "internal error"
+ }
+ }
+
+ return {}
+}
+
+#################################################
+#
+# Miscellaneous
+#
+#################################################
+
+# dom::tcl::hasmixedcontent --
+#
+# Determine whether an element contains mixed content
+#
+# Arguments:
+# token dom node
+#
+# Results:
+# Returns 1 if element contains mixed content,
+# 0 otherwise
+
+proc dom::tcl::hasmixedcontent token {
+ upvar #0 $token node
+
+ if {[string compare $node(node:nodeType) "element"]} {
+ # Really undefined
+ return 0
+ }
+
+ foreach child [set $node(node:childNodes)] {
+ upvar #0 $child childnode
+ if {![string compare $childnode(node:nodeType) "textNode"]} {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# dom::tcl::prefix2namespaceURI --
+#
+# Given an XML Namespace prefix, find the corresponding Namespace URI
+#
+# Arguments:
+# node DOM Node
+# prefix XML Namespace prefix
+#
+# Results:
+# Returns URI
+
+proc dom::tcl::prefix2namespaceURI {node prefix} {
+
+ # Search this node and its ancestors for the appropriate
+ # XML Namespace declaration
+
+ set parent [dom::node parent $node]
+ set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix]
+ if {[string length $parent] && ![string length $nsuri]} {
+ set nsuri [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix]
+ set parent [dom::node parent $parent]
+ }
+
+ if {[string length $nsuri]} {
+ return $nsuri
+ } else {
+ return -code error "unable to find namespace URI for prefix \"$prefix\""
+ }
+
+}
+
+# dom::tcl::namespaceURI2prefix --
+#
+# Given an XML Namespace URI, find the corresponding prefix
+#
+# Arguments:
+# node DOM Node
+# nsuri XML Namespace URI
+#
+# Results:
+# Returns prefix
+
+proc dom::tcl::namespaceURI2prefix {node nsuri} {
+
+ # Search this node and its ancestors for the desired
+ # XML Namespace declaration
+
+ set found 0
+ set prefix {}
+ set parent [dom::node parent $node]
+ while {[string length $parent]} {
+ upvar #0 $node nodeinfo
+ catch {unset attrs}
+ array set attrs [array get $nodeinfo(element:attributeList)]
+ foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] {
+ if {![string compare $declNSuri $nsuri]} {
+ set found 1
+ set prefix [lindex [split $nsdecl ^] 1]
+ break
+ }
+ }
+ if {$found} {
+ break
+ }
+ set node $parent
+ set parent [dom::node parent $node]
+ }
+
+ if {$found} {
+ return $prefix
+ } else {
+ return -code error "unable to find prefix for namespace URI \"$nsuri\""
+ }
+
+}
+
+# dom::tcl::GetField --
+#
+# Return a value, or empty string if not defined
+#
+# Arguments:
+# var name of variable to return
+#
+# Results:
+# Returns the value, or empty string if variable is not defined.
+
+proc dom::tcl::GetField var {
+ upvar $var v
+ if {[info exists v]} {
+ return $v
+ } else {
+ return {}
+ }
+}
+
+# dom::tcl::Min --
+#
+# Return the minimum of two numeric values
+#
+# Arguments:
+# a a value
+# b another value
+#
+# Results:
+# Returns the value which is lower than the other.
+
+proc dom::tcl::Min {a b} {
+ return [expr {$a < $b ? $a : $b}]
+}
+
+# dom::tcl::Max --
+#
+# Return the maximum of two numeric values
+#
+# Arguments:
+# a a value
+# b another value
+#
+# Results:
+# Returns the value which is greater than the other.
+
+proc dom::tcl::Max {a b} {
+ return [expr {$a > $b ? $a : $b}]
+}
+
+# dom::tcl::Boolean --
+#
+# Return a boolean value
+#
+# Arguments:
+# b value
+#
+# Results:
+# Returns 0 or 1
+
+proc dom::tcl::Boolean b {
+ regsub -nocase {^(true|yes|1|on)$} $b 1 b
+ regsub -nocase {^(false|no|0|off)$} $b 0 b
+ return $b
+}
+
diff --git a/tclxml/tcldom-tcl/dommap.tcl b/tclxml/tcldom-tcl/dommap.tcl
new file mode 100644
index 0000000..9d9ec87
--- /dev/null
+++ b/tclxml/tcldom-tcl/dommap.tcl
@@ -0,0 +1,108 @@
+# dommap.tcl --
+#
+# Apply a mapping function to a DOM structure
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: dommap.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package provide dommap 1.0
+
+# We need the DOM
+package require dom 2.6
+
+namespace eval dommap {
+ namespace export map
+}
+
+# dommap::apply --
+#
+# Apply a function to a DOM document.
+#
+# The callback command is invoked with the node ID of the
+# matching DOM node as its argument. The command may return
+# an error, continue or break code to alter the processing
+# of further nodes.
+#
+# Filter functions may be applied to match particular
+# nodes. Valid functions include:
+#
+# -nodeType regexp
+# -nodeName regexp
+# -nodeValue regexp
+# -attribute {regexp regexp}
+#
+# If a filter is specified then the node must match for the
+# callback command to be invoked. If a filter is not specified
+# then all nodes match that filter.
+#
+# Arguments:
+# node DOM document node
+# cmd callback command
+# args configuration options
+#
+# Results:
+# Depends on callback command
+
+proc dommap::apply {node cmd args} {
+ array set opts $args
+
+ # Does this node match?
+ set match 1
+ catch {set match [expr $match && [regexp $opts(-nodeType) [::dom::node cget $node -nodeType]]]}
+ catch {set match [expr $match && [regexp $opts(-nodeName) [::dom::node cget $node -nodeName]]]}
+ catch {set match [expr $match && [regexp $opts(-nodeValue) [::dom::node cget $node -nodeValue]]]}
+ if {$match && ![string compare [::dom::node cget $node -nodeType] element]} {
+ set match 0
+ foreach {attrName attrValue} [array get [::dom::node cget $node -attributes]] {
+ set match 1
+ catch {set match [expr $match && [regexp [lindex $opts(-attribute) 0] $attrName]]}
+ catch {set match [expr $match && [regexp [lindex $opts(-attribute) 1] $attrValue]]}
+ if {$match} break
+ }
+ }
+ if {$match && [set code [catch {eval $cmd [list $node]} msg]]} {
+ switch $code {
+ 0 {}
+ 3 {
+ return -code break
+ }
+ 4 {
+ return -code continue
+ }
+ default {
+ return -code error $msg
+ }
+ }
+ }
+
+ # Process children
+ foreach child [::dom::node children $node] {
+ switch [catch {eval apply [list $child] [list $cmd] $args} msg] {
+ 0 {
+ # No action required
+ }
+ 3 {
+ # break
+ return -code break
+ }
+ 4 {
+ # continue - skip processing of siblings
+ return
+ }
+ 1 -
+ 2 -
+ default {
+ # propagate the error message
+ return -code error $msg
+ }
+ }
+ }
+
+ return {}
+}
+
diff --git a/tclxml/tcldom-tcl/xmlswitch.tcl b/tclxml/tcldom-tcl/xmlswitch.tcl
new file mode 100644
index 0000000..4e2a2a1
--- /dev/null
+++ b/tclxml/tcldom-tcl/xmlswitch.tcl
@@ -0,0 +1,520 @@
+# xmlswitch.tcl --
+#
+# This file implements a control structure for Tcl.
+# 'xmlswitch' iterates over an XML document. Features in
+# the document may be specified using XPath location paths,
+# and these will trigger Tcl scripts when matched.
+#
+# Copyright (c) 2008 Explain
+# http://www.explain.com.au/
+# Copyright (c) 2000-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xmlswitch.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package provide xmlswitch 3.2
+
+# We need the xml, dom and xpath packages
+
+package require xml 3.2
+package require dom 3.2
+package require xpath 1.0
+
+namespace eval xmlswitch {
+ namespace export xmlswitch xmlswitchcont xmlswitchend
+ namespace export domswitch
+ namespace export free rootnode
+
+ variable counter 0
+
+ variable typemap
+ array set typemap {
+ text textNode
+ comment comment
+ processing-instruction processingInstruction
+ }
+}
+
+# xmlswitch::xmlswitch --
+#
+# Parse XML data, matching for XPath locations along the way
+# and (possibly) triggering callbacks.
+#
+# A DOM tree is built as a side-effect (necessary for resolving
+# XPath location paths).
+#
+# Arguments:
+# xml XML document
+# args configuration options,
+# plus a single path/script expression, or multiple expressions
+#
+# Results:
+# Tcl callbacks may be invoked.
+# If -async option is true returns a token for this "process".
+
+proc xmlswitch::xmlswitch {xml args} {
+ variable counter
+
+ set stateVarName [namespace current]::State[incr counter]
+ upvar #0 $stateVarName state
+ set state(stateVarName) $stateVarName
+ set state(-async) 0
+
+ set state(pathArray) ${stateVarName}Paths
+ upvar #0 $state(pathArray) paths
+ array set paths {}
+
+ set cleanup {
+ unset state
+ unset paths
+ }
+
+ # Find configuration options and remove
+ set numOpts 0
+ foreach {opt value} $args {
+ switch -glob -- $opt {
+ -* {
+ set state($opt) $value
+ incr numOpts 2
+ }
+ default {
+ set args [lrange $args $numOpts end]
+ break
+ }
+ }
+ }
+
+ switch -- [llength $args] {
+ 0 {
+ # Nothing to do
+ eval $cleanup
+ return $stateVarName
+ }
+ 1 {
+ foreach {path script} [lindex $args 0] {
+ set paths([xpath::split $path]) $script
+ }
+ }
+ default {
+ if {[llength $args] % 2} {
+ eval $cleanup
+ return -code error "no script matching location path \"[lindex $args end]\""
+ }
+ foreach {path script} $args {
+ set paths([xpath::split $path]) $script
+ }
+ }
+ }
+
+ set root [set state(root) [dom::DOMImplementation create]]
+ set state(current) $root
+
+ # Parse the document
+ # We're going to do this incrementally, so the caller can
+ # break at any time
+ set state(parser) [eval xml::parser [array get state -parser]]
+ #append cleanup "\n $parser destroy\n"
+ $state(parser) configure \
+ -elementstartcommand [namespace code [list ParseElementStart $stateVarName]] \
+ -elementendcommand [namespace code [list ParseElementEnd $stateVarName]] \
+ -characterdatacommand [namespace code [list ParseCharacterData $stateVarName]] \
+ -final 0
+
+# -processinginstructioncommand [namespace code [list ParsePI $stateVarName]] \
+# -commentcommand [namespace code [list ParseComment]]
+
+ if {[catch {$state(parser) parse $xml} err]} {
+ eval $cleanup
+ return -code error $err
+ }
+
+ if {$state(-async)} {
+ return $stateVarName
+ } else {
+ eval $cleanup
+ return {}
+ }
+}
+
+# xmlswitch::xmlswitchcont --
+#
+# Provide more XML data to parse
+#
+# Arguments:
+# token state variable name
+# xml XML data
+#
+# Results:
+# More parsing
+
+proc xmlswitch::xmlswitchcont {token xml} {
+ upvar #0 $token state
+
+ $state(parser) parse $xml
+
+ return {}
+}
+
+# xmlswitch::xmlswitchend --
+#
+# Signal that no further data is available
+#
+# Arguments:
+# token state array
+#
+# Results:
+# Parser configuration changed
+
+proc xmlswitch::xmlswitchend token {
+ upvar #0 $token state
+
+ $state(parser) configure -final true
+
+ return {}
+}
+
+# xmlswitch::rootnode --
+#
+# Get the root node
+#
+# Arguments:
+# token state array
+#
+# Results:
+# Returns root node token
+
+proc xmlswitch::rootnode token {
+ upvar #0 $token state
+
+ return $state(root)
+}
+
+# xmlswitch::free --
+#
+# Free resources EXCEPT the DOM tree.
+# "-all" causes DOM tree to be destroyed too.
+#
+# Arguments:
+# token state array
+# args options
+#
+# Results:
+# Resources freed.
+
+proc xmlswitch::free {token args} {
+ upvar #0 $token state
+
+ if {[lsearch $args "-all"] >= 0} {
+ dom::DOMImplementation destroy $state(root)
+ }
+
+ catch {unset $state(pathArray)}
+ catch {unset state}
+
+ catch {$state(parser) free}
+
+ return {}
+}
+
+# xmlswitch::ParseElementStart --
+#
+# Handle element start tag
+#
+# Arguments:
+# token state array
+# name element type
+# attrList attribute list
+# args options
+# Results:
+# All XPath location paths are checked for a match,
+# and script evaluated for matching XPath.
+# DOM tree node added.
+
+proc xmlswitch::ParseElementStart:dbgdisabled {token name attrList args} {
+ if {[catch {eval ParseElementStart:dbg [list $token $name $attrList] $args} msg]} {
+ puts stderr [list ParseElementStart failed with msg $msg]
+ puts stderr $::errorInfo
+ return -code error $msg
+ } else {
+ puts stderr [list ParseElementStart returned OK]
+ }
+ return $msg
+}
+proc xmlswitch::ParseElementStart {token name attrList args} {
+
+ upvar #0 $token state
+ array set opts $args
+
+ #puts stderr [list xmlswitch::ParseElementStart $token $name $attrList $args]
+
+ lappend state(current) \
+ [dom::document createElement [lindex $state(current) end] $name]
+ foreach {name value} $attrList {
+ dom::element setAttribute [lindex $state(current) end] $name $value
+ }
+
+ MatchTemplates $token [lindex $state(current) end]
+
+ return {}
+}
+
+# xmlswitch::ParseElementEnd --
+#
+# Handle element end tag
+#
+# Arguments:
+# token state array
+# name element type
+# args options
+# Results:
+# State changed
+
+proc xmlswitch::ParseElementEnd {token name args} {
+ upvar #0 $token state
+
+ set state(current) [lreplace $state(current) end end]
+
+ return {}
+}
+
+# xmlswitch::ParseCharacterData --
+#
+# Handle character data
+#
+# Arguments:
+# token state array
+# data pcdata
+#
+# Results:
+# All XPath location paths are checked for a match,
+# and script evaluated for matching XPath.
+# DOM tree node added.
+
+proc xmlswitch::ParseCharacterData {token data} {
+ upvar #0 $token state
+
+ lappend state(current) \
+ [dom::document createTextNode [lindex $state(current) end] $data]
+
+ MatchTemplates $token [lindex $state(current) end]
+
+ set state(current) [lreplace $state(current) end end]
+
+ return {}
+}
+
+# xmlswitch::domswitch --
+#
+# Similar to xmlswitch above, but iterates over a pre-built
+# DOM tree.
+#
+# Arguments:
+# xml XML document
+# args a single path/script expression, or multiple expressions
+#
+# Results:
+# Tcl callbacks may be invoked.
+
+proc xmlswitch::domswitch {xml args} {
+}
+
+# xmlswitch::MatchTemplates --
+#
+# Check all templates for one which matches
+# the current node.
+#
+# Arguments:
+# token state array
+# node Current DOM node
+#
+# Results:
+# If a template matches, its script is evaluated
+
+proc xmlswitch::MatchTemplates {token node} {
+ upvar #0 $token state
+ upvar #0 $state(pathArray) paths
+
+ #puts stderr [list xmlswitch::MatchTemplates $token $node (type: [dom::node cget $node -nodeType]) (name: [dom::node cget $node -nodeName])]
+
+ set matches {}
+
+ foreach {path script} [array get paths] {
+
+ #puts stderr [list checking path $path for a match]
+
+ set context $node
+
+ # Work backwards along the path, reversing each axis
+ set match 0
+ set i [llength $path]
+ #puts stderr [list $i steps to be tested]
+ while {[incr i -1] >= 0} {
+ #puts stderr [list step $i [lindex $path $i]]
+ switch -glob [llength [lindex $path $i]],$i {
+ 0,0 {
+ #puts stderr [list absolute path, end of steps - am I at the root?]
+ if {![string length [dom::node parent $context]]} {
+ #puts stderr [list absolute path matched]
+ lappend matches [list $path $script]
+ } else {
+ #puts stderr [list absolute path did not match]
+ }
+ }
+ *,0 {
+ #puts stderr [list last step, relative path]
+ switch [lindex [lindex $path $i] 0] {
+ child {
+ if {[NodeTest [lindex $path $i] $context] && \
+ [CheckPredicates [lindex $path $i] $context]} {
+ #puts stderr [list relative path matched]
+ lappend matches [list $path $script]
+ } else {
+ #puts stderr [list relative path did not match]
+ }
+ }
+ default {
+ return -code error "axis \"[lindex [lindex $path $i] 0]\" not supported"
+ }
+ }
+ }
+ default {
+ #puts stderr [list continuing checking steps]
+ switch [lindex [lindex $path $i] 0] {
+ child {
+ if {[NodeTest [lindex $path $i] $context] && \
+ [CheckPredicates [lindex $path $i] $context]} {
+ set context [dom::node parent $context]
+ } else {
+ #puts stderr [list no match]
+ }
+ }
+ default {
+ return -code error "axis \"[lindex [lindex $path $i] 0]\" not supported"
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # TODO: If there are multiple matches then we must pick the
+ # most specific match
+
+ if {[llength $matches] > 1} {
+ # For the moment we'll just take the first match
+ set matches [list [lindex $matches 0]]
+ }
+
+ if {[llength $matches]} {
+ #puts stderr [list evaluating callback at level [info level]]
+ uplevel 3 [lindex [lindex $matches 0] 1]
+ }
+
+ return {}
+}
+
+# xmlswitch::NodeTest --
+#
+# Check that the node passes the node (type) test
+#
+# Arguments:
+# step Location step
+# node DOM node
+#
+# Results:
+# Boolean
+
+proc xmlswitch::NodeTest {step node} {
+
+ if {[llength [lindex $step 1]] > 1} {
+ switch -glob -- [lindex [lindex $step 1] 0],[dom::node cget $node -nodeType] {
+ node,* -
+ text,textNode -
+ comment,comment -
+ processing-instruction,processingInstruction {
+ return 1
+ }
+ default {
+ return 0
+ }
+ }
+ } elseif {![string compare [lindex $step 1] "*"]} {
+ return 1
+ } elseif {![string compare [lindex $step 1] [dom::node cget $node -nodeName]]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# xmlswitch::CheckPredicates --
+#
+# Check that the node passes the predicates
+#
+# Arguments:
+# step Location step
+# node DOM node
+#
+# Results:
+# Boolean
+
+proc xmlswitch::CheckPredicates {step node} {
+ variable typemap
+
+ set predicates [lindex $step 2]
+ # Shortcut: no predicates means everything passes
+ if {![llength $predicates]} {
+ return 1
+ }
+
+ # Get the context node set
+ switch [lindex $step 0] {
+ child {
+ set nodeset {}
+ if {[llength [lindex $step 1]]} {
+ foreach {name typetest} [lindex $step 1] break
+ switch -- $name {
+ node {
+ set nodeset [dom::node children [dom::node parent $node]]
+ }
+ text -
+ comment -
+ processing-instruction {
+ foreach child [dom::node children [dom::node parent $node]] {
+ if {![string compare [dom::node cget $child -nodeType] $typemap($name)]} {
+ lappend nodeset $child
+ }
+ }
+ }
+ default {
+ # Error
+ }
+ }
+ } else {
+ foreach child [dom::node children [dom::node parent $node]] {
+ if {![string compare [lindex $step 1] [dom::node cget $child -nodeName]]} {
+ lappend nodeset $child
+ }
+ }
+ }
+ }
+ default {
+ return -code error "axis \"[lindex $step 0]\" not supported"
+ }
+ }
+
+ foreach predicate $predicates {
+ # position() is the only supported predicate
+ if {[lsearch $nodeset $node] + 1 == $predicate} {
+ # continue
+ } else {
+ return 0
+ }
+ }
+
+ return 1
+}
+