diff options
Diffstat (limited to 'tclxml/tcldom-tcl')
| -rw-r--r-- | tclxml/tcldom-tcl/dom.tcl | 4291 | ||||
| -rw-r--r-- | tclxml/tcldom-tcl/dommap.tcl | 108 | ||||
| -rw-r--r-- | tclxml/tcldom-tcl/xmlswitch.tcl | 520 |
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 \]\]>\;<!\[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 { + $ $ + < < + > > + & & + \" " + ' ' + } + + 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 {\&} value + regsub -all < $value {\<} value + + if {![string match *\"* $value]} { + append result \"$value\" + } elseif {![string match *'* $value]} { + append result '$value' + } else { + regsub -all \" $value {\"} value + append result \"$value\" + } + + } + + return $result +} + +# dom::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 +} + |