1# dom.tcl -- 2# 3# This file implements the Tcl language binding for the DOM - 4# the Document Object Model. Support for the core specification 5# is given here. Layered support for specific languages, 6# such as HTML, will be in separate modules. 7# 8# Copyright (c) 1998-2003 Zveno Pty Ltd 9# http://www.zveno.com/ 10# 11# Zveno makes this software available free of charge for any purpose. 12# Copies may be made of this software but all of this notice must be included 13# on any copy. 14# 15# The software was developed for research purposes only and Zveno does not 16# warrant that it is error free or fit for any purpose. Zveno disclaims any 17# liability for all claims, expenses, losses, damages and costs any user may 18# incur as a result of using, copying or modifying this software. 19# 20# $Id: domimpl.tcl,v 1.18 2003/03/09 11:12:49 balls Exp $ 21 22# We need the xml package, so that we get Name defined 23 24package require xml 2.6 25 26# NB. DOM generic layer should be loaded before sourceing this script. 27if {[catch {package require dom::generic 2.6}]} { 28 package require dom::tclgeneric 2.6 29} 30 31package provide dom::tcl 2.6 32 33namespace eval dom::tcl { 34 namespace export DOMImplementation 35 namespace export hasFeature createDocument create createDocumentType 36 namespace export createNode destroy isNode parse selectNode serialize 37 namespace export trim 38 39 namespace export document documentFragment node 40 namespace export element textNode attribute 41 namespace export processingInstruction 42 namespace export event 43 44} 45 46# Define generic constants here, since this package 47# is always loaded. 48 49namespace eval dom { 50 # DOM Level 2 Event defaults 51 variable bubbles 52 array set bubbles { 53 DOMFocusIn 1 54 DOMFocusOut 1 55 DOMActivate 1 56 click 1 57 mousedown 1 58 mouseup 1 59 mouseover 1 60 mousemove 1 61 mouseout 1 62 DOMSubtreeModified 1 63 DOMNodeInserted 1 64 DOMNodeRemoved 1 65 DOMNodeInsertedIntoDocument 0 66 DOMNodeRemovedFromDocument 0 67 DOMAttrModified 1 68 DOMAttrRemoved 1 69 DOMCharacterDataModified 1 70 } 71 variable cancelable 72 array set cancelable { 73 DOMFocusIn 0 74 DOMFocusOut 0 75 DOMActivate 1 76 click 1 77 mousedown 1 78 mouseup 1 79 mouseover 1 80 mousemove 0 81 mouseout 1 82 DOMSubtreeModified 0 83 DOMNodeInserted 0 84 DOMNodeRemoved 0 85 DOMNodeInsertedIntoDocument 0 86 DOMNodeRemovedFromDocument 0 87 DOMAttrModified 0 88 DOMAttrRemoved 0 89 DOMCharacterDataModified 0 90 } 91} 92 93# Data structure 94# 95# Documents are stored in an array within the dom namespace. 96# Each element of the array is indexed by a unique identifier. 97# Each element of the array is a key-value list with at least 98# the following fields: 99# id docArray 100# node:parentNode node:childNodes node:nodeType 101# Nodes of a particular type may have additional fields defined. 102# Note that these fields in many circumstances are configuration options 103# for a node type. 104# 105# "Live" data objects are stored as a separate Tcl variable. 106# Lists, such as child node lists, are Tcl list variables (ie scalar) 107# and keyed-value lists, such as attribute lists, are Tcl array 108# variables. The accessor function returns the variable name, 109# which the application should treat as a read-only object. 110# 111# A token is a FQ array element reference for a node. 112 113# dom::tcl::DOMImplementation -- 114# 115# Implementation-dependent functions. 116# Most importantly, this command provides a function to 117# create a document instance. 118# 119# Arguments: 120# method method to invoke 121# token token for node 122# args arguments for method 123# 124# Results: 125# Depends on method used. 126 127namespace eval dom::tcl { 128 variable DOMImplementationOptions {} 129 variable DOMImplementationCounter 0 130} 131 132proc dom::tcl::DOMImplementation {method args} { 133 variable DOMImplementationOptions 134 variable DOMImplementationCounter 135 136 switch -- $method { 137 138 hasFeature { 139 140 if {[llength $args] != 2} { 141 return -code error "wrong number of arguments" 142 } 143 144 # Later on, could use Tcl package facility 145 if {[regexp {create|destroy|parse|query|serialize|trim|Events|UIEvents|isNode} [lindex $args 0]]} { 146 if {![string compare [lindex $args 1] "1.0"]} { 147 return 1 148 } else { 149 return 0 150 } 151 } else { 152 return 0 153 } 154 155 } 156 157 createDocument { 158 # createDocument introduced in DOM Level 2 159 160 if {[llength $args] != 3} { 161 return -code error "wrong # arguments: should be DOMImplementation nsURI name doctype" 162 } 163 164 set doc [DOMImplementation create] 165 166 document createElementNS $doc [lindex $args 0] [lindex $args 1] 167 168 if {[string length [lindex $args 2]]} { 169 document configure -doctype [lindex $args 2] 170 } 171 172 return $doc 173 } 174 175 create { 176 177 # Non-standard method (see createDocument) 178 # Bootstrap a document instance 179 180 switch [llength $args] { 181 0 { 182 # Allocate unique document array name 183 set name [namespace current]::document[incr DOMImplementationCounter] 184 } 185 1 { 186 # Use array name provided. Should check that it is safe. 187 set name [lindex $args 0] 188 catch {unset $name} 189 } 190 default { 191 return -code error "wrong number of arguments" 192 } 193 } 194 195 set varPrefix ${name}var 196 set arrayPrefix ${name}arr 197 198 array set $name [list counter 1 \ 199 node1 [list id node1 docArray $name \ 200 node:nodeType documentFragment \ 201 node:parentNode {} \ 202 node:nodeName #document \ 203 node:nodeValue {} \ 204 node:childNodes ${varPrefix}1 \ 205 documentFragment:masterDoc node1 \ 206 document:implementation [namespace current]::DOMImplementation \ 207 document:xmldecl {version 1.0} \ 208 document:documentElement {} \ 209 document:doctype {} \ 210 ]] 211 212 # Initialise child node list 213 set ${varPrefix}1 {} 214 215 # Return the new toplevel node 216 return ${name}(node1) 217 218 } 219 220 createDocumentType { 221 # Introduced in DOM Level 2 222 223 # Patch from c.l.t., Richard Calmbach (rc@hnc.com ) 224 225 if {[llength $args] != 5} { 226 return -code error "wrong number of arguments, should be: DOMImplementation createDocumentType token name publicid systemid internaldtd" 227 } 228 229 return [CreateDocType [lindex $args 0] [lindex $args 1] [lrange $args 2 3] [lindex $args 4]] 230 } 231 232 createNode { 233 # Non-standard method 234 # Creates node(s) in the given document given an XPath expression 235 236 if {[llength $args] != 2} { 237 return -code error "wrong number of arguments" 238 } 239 240 package require xpath 241 242 return [XPath:CreateNode [lindex $args 0] [lindex $args 1]] 243 } 244 245 destroy { 246 247 # Free all memory associated with a node 248 249 if {[llength $args] != 1} { 250 return -code error "wrong number of arguments" 251 } 252 array set node [set [lindex $args 0]] 253 254 switch $node(node:nodeType) { 255 256 document - 257 documentFragment { 258 259 if {[string length $node(node:parentNode)]} { 260 unset $node(node:childNodes) 261 262 # Dispatch events 263 event postMutationEvent $node(node:parentNode) DOMSubtreeModified 264 265 return {} 266 } 267 268 # else this is the root document node, 269 # and we can optimize the cleanup. 270 # No need to dispatch events. 271 272 # Patch from Gerald Lester 273 274 ## 275 ## First release all the associated variables 276 ## 277 upvar #0 $node(docArray) docArray 278 for {set i 0} {$i <= $docArray(counter)} {incr i} { 279 catch {unset $node(docArray)var$i} 280 catch {unset $node(docArray)arr$i} 281 catch {unset $node(docArray)search$i} 282 } 283 284 ## 285 ## Then release the main document array 286 ## 287 if {[catch {unset $node(docArray)}]} { 288 return -code error "unable to destroy document" 289 } 290 291 } 292 293 element { 294 # First make sure the node is removed from the tree 295 if {[string length $node(node:parentNode)]} { 296 node removeChild $node(node:parentNode) [lindex $args 0] 297 } 298 unset $node(node:childNodes) 299 unset $node(element:attributeList) 300 unset [lindex $args 0] 301 302 # Don't dispatch events here - 303 # already done by removeChild 304 } 305 306 event { 307 unset [lindex $args 0] 308 } 309 310 default { 311 # First make sure the node is removed from the tree 312 if {[string length $node(node:parentNode)]} { 313 node removeChild $node(node:parentNode) [lindex $args 0] 314 } 315 unset [lindex $args 0] 316 317 # Dispatch events 318 event postMutationEvent $node(node:parentNode) DOMSubtreeModified 319 320 } 321 322 } 323 324 return {} 325 326 } 327 328 isNode { 329 # isNode - non-standard method 330 # Sometimes it is useful to check if an arbitrary string 331 # refers to a DOM node 332 333 if {![info exists [lindex $args 0]]} { 334 return 0 335 } elseif {[catch {array set node [set [lindex $args 0]]}]} { 336 return 0 337 } elseif {[info exists node(node:nodeType)]} { 338 return 1 339 } else { 340 return 0 341 } 342 } 343 344 parse { 345 346 # This implementation uses TclXML version 2.0. 347 # TclXML can choose the best installed parser. 348 349 if {[llength $args] < 1} { 350 return -code error "wrong number of arguments" 351 } 352 353 array set opts {-parser {} -progresscommand {} -chunksize 8196} 354 if {[catch {array set opts [lrange $args 1 end]}]} { 355 return -code error "bad configuration options" 356 } 357 358 # Create a state array for this parse session 359 set state [namespace current]::parse[incr DOMImplementationCounter] 360 array set $state [array get opts -*] 361 array set $state [list progCounter 0] 362 set errorCleanup {} 363 364 if {[string length $opts(-parser)]} { 365 set parserOpt [list -parser $opts(-parser)] 366 } else { 367 set parserOpt {} 368 } 369 if {[catch {package require xml} version]} { 370 eval $errorCleanup 371 return -code error "unable to load XML parsing package" 372 } 373 set parser [eval xml::parser $parserOpt] 374 375 $parser configure \ 376 -elementstartcommand [namespace code [list ParseElementStart $state]] \ 377 -elementendcommand [namespace code [list ParseElementEnd $state]] \ 378 -characterdatacommand [namespace code [list ParseCharacterData $state]] \ 379 -processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \ 380 -commentcommand [namespace code [list ParseComment $state]] \ 381 -entityreferencecommand [namespace code [list ParseEntityReference $state]] \ 382 -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \ 383 -doctypecommand [namespace code [list ParseDocType $state]] \ 384 -final 1 385 386 # Create top-level document 387 array set $state [list docNode [DOMImplementation create]] 388 array set $state [list current [lindex [array get $state docNode] 1]] 389 390 # Parse data 391 # Bug in TclExpat - doesn't handle non-final inputs 392 if {0 && [string length $opts(-progresscommand)]} { 393 $parser configure -final false 394 while {[string length [lindex $args 0]]} { 395 $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)] 396 set args [lreplace $args 0 0 \ 397 [string range [lindex $args 0] $opts(-chunksize) end]] 398 uplevel #0 $opts(-progresscommand) 399 } 400 $parser configure -final true 401 } elseif {[catch {$parser parse [lindex $args 0]} err]} { 402 catch {rename $parser {}} 403 catch {unset $state} 404 puts stderr $::errorInfo 405 return -code error $err 406 } 407 408 # Free data structures which are no longer required 409 $parser free 410 catch {rename $parser {}} 411 412 set doc [lindex [array get $state docNode] 1] 413 unset $state 414 return $doc 415 416 } 417 418 query { 419 # Either: query token string 420 # or: query token ?-tagname string? ?-attrname string? ?-attrvalue string? ?-text string? ?-comment string? ?-pitarget string? ?-pidata string? 421 422 switch [llength $args] { 423 0 - 424 1 { 425 return -code error "wrong number of arguments" 426 } 427 428 2 { 429 # The query applies to the entire document 430 return [Query [lindex $args 0] -tagname [lindex $args 1] \ 431 -attrname [lindex $args 1] -attrvalue [lindex $args 1] \ 432 -text [lindex $args 1] -comment [lindex $args 1] \ 433 -pitarget [lindex $args 1] -pidata [lindex $args 1]] 434 } 435 436 default { 437 # Configuration options have been specified to constrain the search 438 if {[llength [lrange $args 1 end]] % 2} { 439 return -code error "no value given for option \"[lindex $args end]\"" 440 } 441 set startnode [lindex $args 0] 442 foreach {opt value} [lrange $args 1 end] { 443 switch -- $opt { 444 -tagname - -attrname - -attrvalue - -text - 445 -comment - -pitarget - -pidata {} 446 default { 447 return -code error "unknown query option \"$opt\"" 448 } 449 } 450 } 451 452 return [eval Query [list $startnode] [lrange $args 1 end]] 453 454 } 455 456 } 457 458 } 459 460 selectNode { 461 # Non-standard method 462 # Returns nodeset in the given document matching an XPath expression 463 464 if {[llength $args] != 2} { 465 return -code error "wrong number of arguments" 466 } 467 468 package require xpath 469 470 return [XPath:SelectNode [lindex $args 0] [lindex $args 1]] 471 } 472 473 serialize { 474 475 if {[llength $args] < 1} { 476 return -code error "wrong number of arguments" 477 } 478 479 array set node [set [lindex $args 0]] 480 return [eval [list Serialize:$node(node:nodeType)] $args] 481 482 } 483 484 trim { 485 486 # Removes textNodes that only contain white space 487 488 if {[llength $args] != 1} { 489 return -code error "wrong number of arguments" 490 } 491 492 Trim [lindex $args 0] 493 494 # Dispatch DOMSubtreeModified event once here? 495 496 return {} 497 498 } 499 500 default { 501 return -code error "unknown method \"$method\"" 502 } 503 504 } 505 506 return {} 507} 508 509namespace eval dom::tcl { 510 foreach method {hasFeature createDocument create createDocumentType createNode destroy isNode parse selectNode serialize trim} { 511 proc $method args "eval [namespace current]::DOMImplementation $method \$args" 512 } 513} 514 515# dom::tcl::document -- 516# 517# Functions for a document node. 518# 519# Arguments: 520# method method to invoke 521# token token for node 522# args arguments for method 523# 524# Results: 525# Depends on method used. 526 527namespace eval dom::tcl { 528 variable documentOptionsRO doctype|implementation|documentElement 529 variable documentOptionsRW actualEncoding|encoding|standalone|version 530} 531 532proc dom::tcl::document {method token args} { 533 variable documentOptionsRO 534 variable documentOptionsRW 535 536 array set node [set $token] 537 538 set result {} 539 540 switch -- $method { 541 cget { 542 if {[llength $args] != 1} { 543 return -code error "too many arguments" 544 } 545 if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} { 546 return $node(document:$option) 547 } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} { 548 switch -- $option { 549 encoding - 550 version - 551 standalone { 552 array set xmldecl $node(document:xmldecl) 553 return $xmldecl($option) 554 } 555 default { 556 return $node(document:$option) 557 } 558 } 559 } else { 560 return -code error "unknown option \"[lindex $args 0]\"" 561 } 562 } 563 configure { 564 if {[llength $args] == 1} { 565 return [document cget $token [lindex $args 0]] 566 } elseif {[expr [llength $args] % 2]} { 567 return -code error "no value specified for option \"[lindex $args end]\"" 568 } else { 569 foreach {option value} $args { 570 if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} { 571 switch -- $opt { 572 encoding { 573 catch {unset xmldecl} 574 array set xmldecl $node(document:xmldecl) 575 set xmldecl(encoding) $value 576 set node(document:xmldecl) [array get xmldecl] 577 } 578 standalone { 579 if {[string is boolean]} { 580 catch {unset xmldecl} 581 array set xmldecl $node(document:xmldecl) 582 if {[string is true $value]} { 583 set xmldecl(standalone) yes 584 } else { 585 set xmldecl(standalone) no 586 } 587 set node(document:xmldecl) [array get xmldecl] 588 } else { 589 return -code error "unsupported value for option \"$option\" - must be boolean" 590 } 591 } 592 version { 593 if {$value == "1.0"} { 594 catch {unset xmldecl} 595 array set xmldecl $node(document:xmldecl) 596 set xmldecl(version) $value 597 set node(document:xmldecl) [array get xmldecl] 598 } else { 599 return -code error "unsupported value for option \"$option\"" 600 } 601 } 602 default { 603 set node(document:$opt) $value 604 } 605 } 606 } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} { 607 return -code error "attribute \"$option\" is read-only" 608 } else { 609 return -code error "unknown option \"$option\"" 610 } 611 } 612 } 613 614 set $token [array get node] 615 616 } 617 618 createElement { 619 if {[llength $args] != 1} { 620 return -code error "wrong number of arguments" 621 } 622 623 # Check that the element name is kosher 624 if {![regexp ^$::xml::Name\$ [lindex $args 0]]} { 625 return -code error "invalid element name \"[lindex $args 0]\"" 626 } 627 628 # Invoke internal factory function 629 set result [CreateElement $token [lindex $args 0] {}] 630 631 } 632 createDocumentFragment { 633 if {[llength $args]} { 634 return -code error "wrong number of arguments" 635 } 636 637 set result [CreateGeneric $token node:nodeType documentFragment node:nodeName #document-fragment node:nodeValue {}] 638 } 639 createTextNode { 640 if {[llength $args] != 1} { 641 return -code error "wrong number of arguments" 642 } 643 644 set result [CreateTextNode $token [lindex $args 0]] 645 } 646 createComment { 647 if {[llength $args] != 1} { 648 return -code error "wrong number of arguments" 649 } 650 651 set result [CreateGeneric $token node:nodeType comment node:nodeName #comment node:nodeValue [lindex $args 0]] 652 } 653 createCDATASection { 654 if {[llength $args] != 1} { 655 return -code error "wrong number of arguments" 656 } 657 658 set result [CreateTextNode $token [lindex $args 0]] 659 node configure $result -cdatasection 1 660 } 661 createProcessingInstruction { 662 if {[llength $args] != 2} { 663 return -code error "wrong number of arguments" 664 } 665 666 set result [CreateGeneric $token node:nodeType processingInstruction \ 667 node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]] 668 } 669 createAttribute { 670 if {[llength $args] != 1} { 671 return -code error "wrong number of arguments" 672 } 673 674 # Check that the attribute name is kosher 675 if {![regexp ^$::xml::Name\$ [lindex $args 0]]} { 676 return -code error "invalid attribute name \"[lindex $args 0]\"" 677 } 678 679 set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]] 680 } 681 createEntity { 682 set result [CreateGeneric $token node:nodeType entity] 683 } 684 createEntityReference { 685 if {[llength $args] != 1} { 686 return -code error "wrong number of arguments" 687 } 688 set result [CreateGeneric $token node:nodeType entityReference node:nodeName [lindex $args 0]] 689 } 690 691 createDocTypeDecl { 692 # This is not a standard DOM 1.0 method 693 # Deprecated - see DOMImplementation createDocumentType 694 695 if {[llength $args] < 1 || [llength $args] > 5} { 696 return -code error "wrong number of arguments" 697 } 698 699 foreach {name extid dtd entities notations} $args break 700 set result [CreateDocType $token $name $extid] 701 document configure $token -doctype $result 702 documenttype configure $result -internalsubset $dtd 703 documenttype configure $result -entities $entities 704 documenttype configure $result -notations $notations 705 } 706 707 importNode { 708 # Introduced in DOM Level 2 709 710 return -code error "not yet implemented" 711 } 712 713 createElementNS { 714 # Introduced in DOM Level 2 715 716 if {[llength $args] != 2} { 717 return -code error "wrong number of arguments, should be: createElementNS nsuri qualname" 718 } 719 720 # Check that the qualified name is kosher 721 if {[catch {foreach {prefix localname} [::xml::qnamesplit [lindex $args 1]] break} err]} { 722 return -code error "invalid qualified name \"[lindex $args 1]\" due to \"$err\"" 723 } 724 725 # Invoke internal factory function 726 set result [CreateElement $token [lindex $args 1] {} -prefix $prefix -namespace [lindex $args 0] -localname $localname] 727 } 728 729 createAttributeNS { 730 # Introduced in DOM Level 2 731 732 return -code error "not yet implemented" 733 } 734 735 getElementsByTagNameNS { 736 # Introduced in DOM Level 2 737 738 return -code error "not yet implemented" 739 } 740 741 getElementsById { 742 # Introduced in DOM Level 2 743 744 return -code error "not yet implemented" 745 } 746 747 createEvent { 748 # Introduced in DOM Level 2 749 750 if {[llength $args] != 1} { 751 return -code error "wrong number of arguments" 752 } 753 754 set result [CreateEvent $token [lindex $args 0]] 755 756 } 757 758 getElementsByTagName { 759 if {[llength $args] < 1} { 760 return -code error "wrong number of arguments" 761 } 762 763 return [eval Element:GetByTagName [list $token [lindex $args 0]] \ 764 [lrange $args 1 end]] 765 } 766 767 default { 768 return -code error "unknown method \"$method\"" 769 } 770 771 } 772 773 # Dispatch events 774 775 # Node insertion events are generated here instead of the 776 # internal factory procedures. This is because the factory 777 # procedures are meant to be mean-and-lean during the parsing 778 # phase, and dispatching events at that time would be an 779 # excessive overhead. The factory methods here are pretty 780 # heavyweight anyway. 781 782 if {[string match create* $method] && [string compare $method "createEvent"]} { 783 784 event postMutationEvent $result DOMNodeInserted -relatedNode $token 785 event postMutationEvent $result DOMNodeInsertedIntoDocument 786 event postMutationEvent $token DOMSubtreeModified 787 788 } 789 790 return $result 791} 792 793### Factory methods 794### 795### These are lean-and-mean for fastest possible tree building 796 797# dom::tcl::CreateElement -- 798# 799# Append an element to the given (parent) node (if any) 800# 801# Arguments: 802# token parent node 803# name element name (no checking performed here) 804# aList attribute list 805# args configuration options 806# 807# Results: 808# New node created, parent optionally modified 809 810proc dom::tcl::CreateElement {token name aList args} { 811 array set opts $args 812 813 if {[string length $token]} { 814 array set parent [set $token] 815 upvar #0 $parent(docArray) docArray 816 set docArrayName $parent(docArray) 817 } else { 818 upvar #0 $opts(-docarray) docArray 819 set docArrayName $opts(-docarray) 820 } 821 822 set id node[incr docArray(counter)] 823 set child ${docArrayName}($id) 824 825 # Create the new node 826 # NB. normally we'd use Node:create here, 827 # but inline it instead for performance 828 set docArray($id) [list id $id docArray $docArrayName \ 829 node:parentNode $token \ 830 node:childNodes ${docArrayName}var$docArray(counter) \ 831 node:nodeType element \ 832 node:nodeName $name \ 833 node:namespaceURI {} \ 834 node:prefix {} \ 835 node:localName $name \ 836 node:nodeValue {} \ 837 element:attributeList ${docArrayName}arr$docArray(counter) \ 838 element:attributeNodes {} \ 839 ] 840 841 catch {lappend docArray($id) node:namespaceURI $opts(-namespace)} 842 catch {lappend docArray($id) node:localName $opts(-localname)} 843 catch {lappend docArray($id) node:prefix $opts(-prefix)} 844 845 # Initialise associated variables 846 set ${docArrayName}var$docArray(counter) {} 847 array set ${docArrayName}arr$docArray(counter) $aList 848 catch { 849 foreach {ns nsAttrList} $opts(-namespaceattributelists) { 850 foreach {attrName attrValue} $nsAttrList { 851 array set ${docArrayName}arr$docArray(counter) [list $ns^$attrName $attrValue] 852 } 853 } 854 } 855 856 # Update parent record 857 858 # Does this element qualify as the document element? 859 # If so, then has a document element already been set? 860 861 if {[string length $token]} { 862 863 if {![string compare $parent(node:nodeType) documentFragment]} { 864 if {$parent(id) == $parent(documentFragment:masterDoc)} { 865 if {[info exists parent(document:documentElement)] && \ 866 [string length $parent(document:documentElement)]} { 867 unset docArray($id) 868 return -code error "document element already exists" 869 } else { 870 871 # Check against document type decl 872 if {[string length $parent(document:doctype)]} { 873 array set doctypedecl [set $parent(document:doctype)] 874 if {[string compare $name $doctypedecl(doctype:name)]} { 875 return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\"" 876 } 877 878 } else { 879 # Synthesize document type declaration 880 CreateDocType $token $name {} {} 881 # Resynchronise parent record 882 array set parent [set $token] 883 } 884 885 set parent(document:documentElement) $child 886 set $token [array get parent] 887 } 888 } 889 } 890 891 lappend $parent(node:childNodes) $child 892 893 } 894 895 return $child 896} 897 898# dom::tcl::CreateTextNode -- 899# 900# Append a textNode node to the given (parent) node (if any). 901# 902# This factory function can also be performed by 903# CreateGeneric, but text nodes are created so often 904# that this specific factory procedure speeds things up. 905# 906# Arguments: 907# token parent node 908# text initial text 909# args additional configuration options 910# 911# Results: 912# New node created, parent optionally modified 913 914proc dom::tcl::CreateTextNode {token text args} { 915 if {[string length $token]} { 916 array set parent [set $token] 917 upvar #0 $parent(docArray) docArray 918 set docArrayName $parent(docArray) 919 } else { 920 array set opts $args 921 upvar #0 $opts(-docarray) docArray 922 set docArrayName $opts(-docarray) 923 } 924 925 set id node[incr docArray(counter)] 926 set child ${docArrayName}($id) 927 928 # Create the new node 929 # NB. normally we'd use Node:create here, 930 # but inline it instead for performance 931 932 # Text nodes never have children, so don't create a variable 933 934 set docArray($id) [list id $id docArray $docArrayName \ 935 node:parentNode $token \ 936 node:childNodes {} \ 937 node:nodeType textNode \ 938 node:nodeValue $text \ 939 node:nodeName #text \ 940 node:cdatasection 0 \ 941 ] 942 943 if {[string length $token]} { 944 # Update parent record 945 lappend $parent(node:childNodes) $child 946 set $token [array get parent] 947 } 948 949 return $child 950} 951 952# dom::tcl::CreateGeneric -- 953# 954# This is a template used for type-specific factory procedures 955# 956# Arguments: 957# token parent node 958# args optional values 959# 960# Results: 961# New node created, parent modified 962 963proc dom::tcl::CreateGeneric {token args} { 964 if {[string length $token]} { 965 array set parent [set $token] 966 upvar #0 $parent(docArray) docArray 967 set docArrayName $parent(docArray) 968 } else { 969 array set opts $args 970 upvar #0 $opts(-docarray) docArray 971 set docArrayName $opts(-docarray) 972 array set tmp [array get opts] 973 foreach opt [array names tmp -*] { 974 unset tmp($opt) 975 } 976 set args [array get tmp] 977 } 978 979 set id node[incr docArray(counter)] 980 set child ${docArrayName}($id) 981 982 # Create the new node 983 # NB. normally we'd use Node:create here, 984 # but inline it instead for performance 985 set docArray($id) [eval list [list id $id docArray $docArrayName \ 986 node:parentNode $token \ 987 node:childNodes ${docArrayName}var$docArray(counter)] \ 988 $args 989 ] 990 set ${docArrayName}var$docArray(counter) {} 991 992 catch {unset opts} 993 array set opts $args 994 switch -glob -- [string length $token],$opts(node:nodeType) { 995 0,* - 996 *,attribute - 997 *,namespace { 998 # These type of nodes are not children of their parent 999 } 1000 1001 default { 1002 # Update parent record 1003 lappend $parent(node:childNodes) $child 1004 set $token [array get parent] 1005 } 1006 } 1007 1008 return $child 1009} 1010 1011### Specials 1012 1013# dom::tcl::CreateDocType -- 1014# 1015# Create a Document Type Declaration node. 1016# 1017# Arguments: 1018# token node id for the document node 1019# name root element type 1020# extid external entity id 1021# dtd internal DTD subset 1022# 1023# Results: 1024# Returns node id of the newly created node. 1025 1026proc dom::tcl::CreateDocType {token name {extid {}} {dtd {}} {entities {}} {notations {}}} { 1027 array set doc [set $token] 1028 upvar #0 $doc(docArray) docArray 1029 1030 set id node[incr docArray(counter)] 1031 set child $doc(docArray)($id) 1032 1033 if {[llength $dtd] == 1 && [string length [lindex $dtd 0]] == 0} { 1034 set dtd {} 1035 } 1036 1037 set docArray($id) [list \ 1038 id $id docArray $doc(docArray) \ 1039 node:parentNode $token \ 1040 node:childNodes {} \ 1041 node:nodeType docType \ 1042 node:nodeName {} \ 1043 node:nodeValue {} \ 1044 doctype:name $name \ 1045 doctype:entities {} \ 1046 doctype:notations {} \ 1047 doctype:externalid $extid \ 1048 doctype:internaldtd $dtd \ 1049 ] 1050 # NB. externalid and internaldtd are not standard DOM 1.0 attributes 1051 1052 # Update parent 1053 1054 set doc(document:doctype) $child 1055 1056 # BUG: The doc type is NOT a child of the document node. 1057 # This behaviour has been removed. 1058 ##Add this node to the parent's child list 1059 ## This must come before the document element, 1060 ## so this implementation may be buggy 1061 #lappend $doc(node:childNodes) $child 1062 1063 set $token [array get doc] 1064 1065 return $child 1066} 1067 1068# dom::tcl::node -- 1069# 1070# Functions for a general node. 1071# 1072# Implements EventTarget Interface - introduced in DOM Level 2 1073# 1074# Arguments: 1075# method method to invoke 1076# token token for node 1077# args arguments for method 1078# 1079# Results: 1080# Depends on method used. 1081 1082namespace eval dom::tcl { 1083 variable nodeOptionsRO nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes|namespaceURI|prefix|localName|ownerDocument 1084 variable nodeOptionsRW nodeValue|cdatasection 1085 1086 # Allowing nodeName to be rw is not standard DOM. 1087 # A validating implementation would have to be very careful 1088 # in allowing this feature 1089 if {$::dom::strictDOM} { 1090 append nodeOptionsRO |nodeName 1091 } else { 1092 append nodeOptionsRW |nodeName 1093 } 1094} 1095# NB. cdatasection is not a standard DOM option 1096 1097proc dom::tcl::node {method token args} { 1098 variable nodeOptionsRO 1099 variable nodeOptionsRW 1100 1101 if {[catch {array set node [set $token]}]} { 1102 return -code error "token not found" 1103 } 1104 1105 set result {} 1106 1107 switch -glob -- $method { 1108 cg* { 1109 # cget 1110 1111 # Some read-only configuration options are computed 1112 if {[llength $args] != 1} { 1113 return -code error "too many arguments" 1114 } 1115 if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} { 1116 switch $option { 1117 nodeName { 1118 set result $node(node:nodeName) 1119 switch $node(node:nodeType) { 1120 textNode { 1121 catch {set result [expr {$node(node:cdatasection) ? "#cdata-section" : $node(node:nodeName)}]} 1122 } 1123 default { 1124 } 1125 } 1126 } 1127 childNodes { 1128 # How are we going to handle documentElement? 1129 set result $node(node:childNodes) 1130 } 1131 firstChild { 1132 upvar #0 $node(node:childNodes) children 1133 switch $node(node:nodeType) { 1134 documentFragment { 1135 set result [lindex $children 0] 1136 catch {set result $node(document:documentElement)} 1137 } 1138 default { 1139 set result [lindex $children 0] 1140 } 1141 } 1142 } 1143 lastChild { 1144 upvar #0 $node(node:childNodes) children 1145 switch $node(node:nodeType) { 1146 documentFragment { 1147 set result [lindex $children end] 1148 catch {set result $node(document:documentElement)} 1149 } 1150 default { 1151 set result [lindex $children end] 1152 } 1153 } 1154 } 1155 previousSibling { 1156 # BUG: must take documentElement into account 1157 # Find the parent node 1158 array set parent [set $node(node:parentNode)] 1159 upvar #0 $parent(node:childNodes) children 1160 set idx [lsearch $children $token] 1161 if {$idx >= 0} { 1162 set sib [lindex $children [incr idx -1]] 1163 if {[llength $sib]} { 1164 set result $sib 1165 } else { 1166 set result {} 1167 } 1168 } else { 1169 set result {} 1170 } 1171 } 1172 nextSibling { 1173 # BUG: must take documentElement into account 1174 # Find the parent node 1175 array set parent [set $node(node:parentNode)] 1176 upvar #0 $parent(node:childNodes) children 1177 set idx [lsearch $children $token] 1178 if {$idx >= 0} { 1179 set sib [lindex $children [incr idx]] 1180 if {[llength $sib]} { 1181 set result $sib 1182 } else { 1183 set result {} 1184 } 1185 } else { 1186 set result {} 1187 } 1188 } 1189 attributes { 1190 if {[string compare $node(node:nodeType) element]} { 1191 set result {} 1192 } else { 1193 set result $node(element:attributeList) 1194 } 1195 } 1196 ownerDocument { 1197 if {[string compare $node(node:parentNode) {}]} { 1198 return $node(docArray)(node1) 1199 } else { 1200 return $token 1201 } 1202 } 1203 default { 1204 return [GetField node(node:$option)] 1205 } 1206 } 1207 } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} { 1208 return [GetField node(node:$option)] 1209 } else { 1210 return -code error "unknown option \"[lindex $args 0]\"" 1211 } 1212 } 1213 co* { 1214 # configure 1215 1216 if {[llength $args] == 1} { 1217 return [node cget $token [lindex $args 0]] 1218 } elseif {[expr [llength $args] % 2]} { 1219 return -code error "wrong \# args: should be \"::dom::node configure node option\"" 1220 } else { 1221 foreach {option value} $args { 1222 if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} { 1223 1224 switch $opt,$node(node:nodeType) { 1225 nodeValue,textNode - 1226 nodeValue,processingInstruction { 1227 # Dispatch event 1228 set evid [CreateEvent $token DOMCharacterDataModified] 1229 event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $node(node:nodeValue) $value {} 1230 set node(node:nodeValue) $value 1231 node dispatchEvent $token $evid 1232 DOMImplementation destroy $evid 1233 } 1234 default { 1235 set node(node:$opt) $value 1236 } 1237 } 1238 1239 } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} { 1240 return -code error "attribute \"$option\" is read-only" 1241 } else { 1242 return -code error "unknown option \"$option\"" 1243 } 1244 } 1245 } 1246 } 1247 1248 in* { 1249 1250 # insertBefore 1251 1252 # Previous and next sibling relationships are OK, 1253 # because they are dynamically determined 1254 1255 if {[llength $args] < 1 || [llength $args] > 2} { 1256 return -code error "wrong number of arguments" 1257 } 1258 1259 array set newChild [set [lindex $args 0]] 1260 if {[string compare $newChild(docArray) $node(docArray)]} { 1261 return -code error "new node must be in the same document" 1262 } 1263 1264 switch [llength $args] { 1265 1 { 1266 # Append as the last node 1267 if {[string length $newChild(node:parentNode)]} { 1268 node removeChild $newChild(node:parentNode) [lindex $args 0] 1269 } 1270 lappend $node(node:childNodes) [lindex $args 0] 1271 set newChild(node:parentNode) $token 1272 } 1273 2 { 1274 1275 array set refChild [set [lindex $args 1]] 1276 if {[string compare $refChild(docArray) $newChild(docArray)]} { 1277 return -code error "nodes must be in the same document" 1278 } 1279 set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] 1280 if {$idx < 0} { 1281 return -code error "no such reference child" 1282 } else { 1283 1284 # Remove from previous parent 1285 if {[string length $newChild(node:parentNode)]} { 1286 node removeChild $newChild(node:parentNode) [lindex $args 0] 1287 } 1288 1289 # Insert into new node 1290 set $node(node:childNodes) \ 1291 [linsert [set $node(node:childNodes)] $idx [lindex $args 0]] 1292 set newChild(node:parentNode) $token 1293 } 1294 } 1295 } 1296 set [lindex $args 0] [array get newChild] 1297 1298 event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token 1299 FireNodeInsertedEvents [lindex $args 0] 1300 event postMutationEvent $token DOMSubtreeModified 1301 1302 } 1303 1304 rep* { 1305 1306 # replaceChild 1307 1308 if {[llength $args] != 2} { 1309 return -code error "wrong number of arguments" 1310 } 1311 1312 array set newChild [set [lindex $args 0]] 1313 array set oldChild [set [lindex $args 1]] 1314 1315 # Find where to insert new child 1316 set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]] 1317 if {$idx < 0} { 1318 return -code error "no such old child" 1319 } 1320 1321 # Remove new child from current parent 1322 if {[string length $newChild(node:parentNode)]} { 1323 node removeChild $newChild(node:parentNode) [lindex $args 0] 1324 } 1325 1326 set $node(node:childNodes) \ 1327 [lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]] 1328 set newChild(node:parentNode) $token 1329 1330 # Update old child to reflect lack of parentage 1331 set oldChild(node:parentNode) {} 1332 1333 set [lindex $args 1] [array get oldChild] 1334 set [lindex $args 0] [array get newChild] 1335 1336 set result [lindex $args 0] 1337 1338 event postMutationEvent [lindex $args 0] DOMNodeInserted -relatedNode $token 1339 FireNodeInsertedEvents [lindex $args 0] 1340 event postMutationEvent $token DOMSubtreeModified 1341 1342 } 1343 1344 rem* { 1345 1346 # removeChild 1347 1348 if {[llength $args] != 1} { 1349 return -code error "wrong number of arguments" 1350 } 1351 array set oldChild [set [lindex $args 0]] 1352 if {$oldChild(docArray) != $node(docArray)} { 1353 return -code error "node \"[lindex $args 0]\" is not a child" 1354 } 1355 1356 # Remove the child from the parent 1357 upvar #0 $node(node:childNodes) myChildren 1358 if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} { 1359 return -code error "node \"[lindex $args 0]\" is not a child" 1360 } 1361 set myChildren [lreplace $myChildren $idx $idx] 1362 1363 # Update the child to reflect lack of parentage 1364 set oldChild(node:parentNode) {} 1365 set [lindex $args 0] [array get oldChild] 1366 1367 set result [lindex $args 0] 1368 1369 # Event propagation has a problem here: 1370 # Nodes that until recently were ancestors may 1371 # want to capture the event, but we've just removed 1372 # the parentage information. They get a DOMSubtreeModified 1373 # instead. 1374 event postMutationEvent [lindex $args 0] DOMNodeRemoved -relatedNode $token 1375 FireNodeRemovedEvents [lindex $args 0] 1376 event postMutationEvent $token DOMSubtreeModified 1377 1378 } 1379 1380 ap* { 1381 1382 # appendChild 1383 1384 if {[llength $args] != 1} { 1385 return -code error "wrong number of arguments" 1386 } 1387 1388 # Add to new parent 1389 node insertBefore $token [lindex $args 0] 1390 1391 } 1392 1393 hasChildNodes { 1394 set result [Min 1 [llength [set $node(node:childNodes)]]] 1395 } 1396 1397 isSameNode { 1398 # Introduced in DOM Level 3 1399 switch [llength $args] { 1400 1 { 1401 return [expr {$token == [lindex $args 0]}] 1402 } 1403 default { 1404 return -code error "wrong # arguments: should be dom::node isSameNode token ref" 1405 } 1406 } 1407 } 1408 1409 cl* { 1410 # cloneNode 1411 1412 # May need to pay closer attention to generation of events here 1413 1414 set deep 0 1415 switch [llength $args] { 1416 0 { 1417 } 1418 1 { 1419 set deep [Boolean [lindex $args 0]] 1420 } 1421 default { 1422 return -code error "too many arguments" 1423 } 1424 } 1425 1426 switch $node(node:nodeType) { 1427 element { 1428 set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)] 1429 if {$deep} { 1430 foreach child [set $node(node:childNodes)] { 1431 node appendChild $result [node cloneNode $child] 1432 } 1433 } 1434 } 1435 textNode { 1436 set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)] 1437 } 1438 document - 1439 documentFragment - 1440 default { 1441 set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)] 1442 if {$deep} { 1443 foreach child [set $node(node:childNodes)] { 1444 node appendChild $result [node cloneNode $child] 1445 } 1446 } 1447 } 1448 } 1449 1450 } 1451 1452 ch* { 1453 # children -- non-standard method 1454 1455 # If this is a textNode, then catch the error 1456 set result {} 1457 catch {set result [set $node(node:childNodes)]} 1458 1459 } 1460 1461 par* { 1462 # parent -- non-standard method 1463 1464 return $node(node:parentNode) 1465 1466 } 1467 1468 pat* { 1469 # path -- non-standard method 1470 1471 for { 1472 set ancestor $token 1473 set result {} 1474 catch {unset ancNode} 1475 array set ancNode [set $ancestor] 1476 } {[string length $ancNode(node:parentNode)]} { 1477 set ancestor $ancNode(node:parentNode) 1478 catch {unset ancNode} 1479 array set ancNode [set $ancestor] 1480 } { 1481 set result [linsert $result 0 $ancestor] 1482 } 1483 # The last node is the document node 1484 set result [linsert $result 0 $ancestor] 1485 1486 } 1487 1488 createNode { 1489 # createNode -- non-standard method 1490 1491 # Creates node(s) in this document given an XPath expression. 1492 # Relative location paths have this node as their initial context. 1493 1494 if {[llength $args] != 1} { 1495 return -code error "wrong number of arguments" 1496 } 1497 1498 package require xpath 1499 1500 return [XPath:CreateNode $token [lindex $args 0]] 1501 } 1502 1503 selectNode { 1504 # selectNode -- non-standard method 1505 1506 # Returns nodeset in this document matching an XPath expression. 1507 # Relative location paths have this node as their initial context. 1508 1509 if {[llength $args] != 1} { 1510 return -code error "wrong number of arguments" 1511 } 1512 1513 package require xpath 1514 1515 return [XPath:SelectNode $token [lindex $args 0]] 1516 } 1517 1518 stringValue { 1519 # stringValue -- non-standard method 1520 # Returns string value of a node, as defined by XPath Rec. 1521 1522 switch $node(node:nodeType) { 1523 document - 1524 documentFragment - 1525 element { 1526 set value {} 1527 foreach child [set $node(node:childNodes)] { 1528 switch [node cget $child -nodeType] { 1529 element - 1530 textNode { 1531 append value [node stringValue $child] 1532 } 1533 default { 1534 # Other nodes are not considered 1535 } 1536 } 1537 } 1538 return $value 1539 } 1540 attribute - 1541 textNode - 1542 processingInstruction - 1543 comment { 1544 return $node(node:nodeValue) 1545 } 1546 default { 1547 return {} 1548 } 1549 } 1550 1551 } 1552 1553 addEv* { 1554 # addEventListener -- introduced in DOM Level 2 1555 1556 if {[llength $args] < 2} { 1557 return -code error "wrong number of arguments" 1558 } 1559 1560 set type [string tolower [lindex $args 0]] 1561 set listener [lindex $args 1] 1562 array set opts {-usecapture 0} 1563 array set opts [lrange $args 2 end] 1564 set opts(-usecapture) [Boolean $opts(-usecapture)] 1565 set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}] 1566 1567 if {![info exists node(event:$type:$listenerType)] || \ 1568 [lsearch $node(event:$type:$listenerType) $listener] < 0} { 1569 lappend node(event:$type:$listenerType) $listener 1570 } 1571 # else avoid registering same listener twice 1572 1573 } 1574 1575 removeEv* { 1576 # removeEventListener -- introduced in DOM Level 2 1577 1578 if {[llength $args] < 2} { 1579 return -code error "wrong number of arguments" 1580 } 1581 1582 set type [string tolower [lindex $args 0]] 1583 set listener [lindex $args 1] 1584 array set opts {-usecapture 0} 1585 array set opts [lrange $args 2 end] 1586 set opts(-usecapture) [Boolean $opts(-usecapture)] 1587 set listenerType [expr {$opts(-usecapture) ? "capturer" : "listener"}] 1588 1589 set idx [lsearch $node(event:$type:$listenerType) $listener] 1590 if {$idx >= 0} { 1591 set node(event:$type:$listenerType) [lreplace $node(event:$type:$listenerType) $idx $idx] 1592 } 1593 1594 } 1595 1596 disp* { 1597 # dispatchEvent -- introduced in DOM Level 2 1598 1599 # This is where the fun happens! 1600 # Check to see if there one or more event listener, 1601 # if so trigger the listener(s). 1602 # Then pass the event up to the ancestor. 1603 # This may be modified by event capturing and bubbling. 1604 1605 if {[llength $args] != 1} { 1606 return -code error "wrong number of arguments" 1607 } 1608 1609 set eventId [lindex $args 0] 1610 array set event [set $eventId] 1611 set type $event(type) 1612 1613 if {![string length $event(eventPhase)]} { 1614 1615 # This is the initial dispatch of the event. 1616 # First trigger any capturing event listeners 1617 # Starting from the root, proceed downward 1618 1619 set event(eventPhase) capturing_phase 1620 set event(target) $token 1621 set $eventId [array get event] 1622 1623 # DOM L2 specifies that the ancestors are determined 1624 # at the moment of event dispatch, so using a static 1625 # list is the correct thing to do 1626 1627 foreach ancestor [lreplace [node path $token] end end] { 1628 array get event [set $eventId] 1629 set event(currentNode) $ancestor 1630 set $eventId [array get event] 1631 1632 catch {unset ancNode} 1633 array set ancNode [set $ancestor] 1634 1635 if {[info exists ancNode(event:$type:capturer)]} { 1636 foreach capturer $ancNode(event:$type:capturer) { 1637 if {[catch {uplevel #0 $capturer [list $eventId]} capturerError]} { 1638 bgerror "error in capturer \"$capturerError\"" 1639 } 1640 } 1641 1642 # A listener may stop propagation, 1643 # but we check here to let all of the 1644 # listeners at that level complete 1645 1646 array set event [set $eventId] 1647 if {$event(cancelable) && $event(stopPropagation)} { 1648 break 1649 } 1650 } 1651 } 1652 1653 # Prepare for next phase 1654 set event(eventPhase) at_target 1655 1656 } 1657 1658 set event(currentNode) $token 1659 set $eventId [array get event] 1660 1661 if {[info exists node(event:$type:listener)]} { 1662 foreach listener $node(event:$type:listener) { 1663 if {[catch {uplevel #0 $listener [list $eventId]} listenerError]} { 1664 bgerror "error in listener \"$listenerError\"" 1665 } 1666 } 1667 } 1668 1669 array set event [set $eventId] 1670 set event(eventPhase) bubbling_phase 1671 set $eventId [array get event] 1672 1673 # Now propagate the event 1674 if {$event(cancelable) && $event(stopPropagation)} { 1675 # Event has been cancelled 1676 } elseif {[llength $node(node:parentNode)]} { 1677 # Go ahead and propagate 1678 node dispatchEvent $node(node:parentNode) $eventId 1679 } 1680 1681 set event(dispatched) 1 1682 set $eventId [array get event] 1683 1684 } 1685 1686 default { 1687 return -code error "unknown method \"$method\"" 1688 } 1689 1690 } 1691 1692 set $token [array get node] 1693 1694 return $result 1695} 1696 1697# dom::tcl::Node:create -- 1698# 1699# Generic node creation. 1700# See also CreateElement, CreateTextNode, CreateGeneric. 1701# 1702# Arguments: 1703# pVar array in caller which contains parent details 1704# args configuration options 1705# 1706# Results: 1707# New child node created. 1708 1709proc dom::tcl::Node:create {pVar args} { 1710 upvar $pVar parent 1711 1712 array set opts {-name {} -value {}} 1713 array set opts $args 1714 1715 upvar #0 $parent(docArray) docArray 1716 1717 # Create new node 1718 if {![info exists opts(-id)]} { 1719 set opts(-id) node[incr docArray(counter)] 1720 } 1721 set docArray($opts(-id)) [list id $opts(-id) \ 1722 docArray $parent(docArray) \ 1723 node:parentNode $opts(-parent) \ 1724 node:childNodes $parent(docArray)var$docArray(counter) \ 1725 node:nodeType $opts(-type) \ 1726 node:nodeName $opts(-name) \ 1727 node:nodeValue $opts(-value) \ 1728 element:attributeList $parent(docArray)arr$docArray(counter) \ 1729 ] 1730 set $parent(docArray)var$docArray(counter) {} 1731 array set $parent(docArray)arr$docArray(counter) {} 1732 1733 # Update parent node 1734 if {![info exists parent(document:documentElement)]} { 1735 lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)] 1736 } 1737 1738 return $parent(docArray)($opts(-id)) 1739 1740} 1741 1742# dom::tcl::Node:set -- 1743# 1744# Generic node update 1745# 1746# Arguments: 1747# token node token 1748# args configuration options 1749# 1750# Results: 1751# Node modified. 1752 1753proc dom::tcl::Node:set {token args} { 1754 upvar $token node 1755 1756 foreach {key value} $args { 1757 set node($key) $value 1758 } 1759 1760 set $token [array get node] 1761 1762 return {} 1763} 1764 1765# dom::tcl::FireNodeInsertedEvents -- 1766# 1767# Recursively descend the tree triggering DOMNodeInserted 1768# events as we go. 1769# 1770# Arguments: 1771# nodeid Node ID 1772# 1773# Results: 1774# DOM L2 DOMNodeInserted events posted 1775 1776proc dom::tcl::FireNodeInsertedEvents nodeid { 1777 event postMutationEvent $nodeid DOMNodeInsertedIntoDocument 1778 foreach child [node children $nodeid] { 1779 FireNodeInsertedEvents $child 1780 } 1781 1782 return {} 1783} 1784 1785# dom::tcl::FireNodeRemovedEvents -- 1786# 1787# Recursively descend the tree triggering DOMNodeRemoved 1788# events as we go. 1789# 1790# Arguments: 1791# nodeid Node ID 1792# 1793# Results: 1794# DOM L2 DOMNodeRemoved events posted 1795 1796proc dom::tcl::FireNodeRemovedEvents nodeid { 1797 event postMutationEvent $nodeid DOMNodeRemovedFromDocument 1798 foreach child [node children $nodeid] { 1799 FireNodeRemovedEvents $child 1800 } 1801 1802 return {} 1803} 1804 1805# dom::tcl::element -- 1806# 1807# Functions for an element. 1808# 1809# Arguments: 1810# method method to invoke 1811# token token for node 1812# args arguments for method 1813# 1814# Results: 1815# Depends on method used. 1816 1817namespace eval dom::tcl { 1818 variable elementOptionsRO tagName|empty 1819 variable elementOptionsRW {} 1820} 1821 1822proc dom::tcl::element {method token args} { 1823 variable elementOptionsRO 1824 variable elementOptionsRW 1825 1826 array set node [set $token] 1827 1828 if {[string compare $node(node:nodeType) "element"]} { 1829 return -code error "not an element type node" 1830 } 1831 set result {} 1832 1833 switch -- $method { 1834 1835 cget { 1836 # Some read-only configuration options are computed 1837 if {[llength $args] != 1} { 1838 return -code error "too many arguments" 1839 } 1840 if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { 1841 switch $option { 1842 tagName { 1843 set result [lindex $node(node:nodeName) 0] 1844 } 1845 empty { 1846 if {![info exists node(element:empty)]} { 1847 return 0 1848 } else { 1849 return $node(element:empty) 1850 } 1851 } 1852 default { 1853 return $node(node:$option) 1854 } 1855 } 1856 } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { 1857 return $node(node:$option) 1858 } else { 1859 return -code error "unknown option \"[lindex $args 0]\"" 1860 } 1861 } 1862 configure { 1863 if {[llength $args] == 1} { 1864 return [document cget $token [lindex $args 0]] 1865 } elseif {[expr [llength $args] % 2]} { 1866 return -code error "no value specified for option \"[lindex $args end]\"" 1867 } else { 1868 foreach {option value} $args { 1869 if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { 1870 return -code error "attribute \"$option\" is read-only" 1871 } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { 1872 return -code error "not implemented" 1873 } else { 1874 return -code error "unknown option \"$option\"" 1875 } 1876 } 1877 } 1878 } 1879 1880 getAttribute { 1881 if {[llength $args] != 1} { 1882 return -code error "wrong number of arguments" 1883 } 1884 1885 set result {} 1886 1887 upvar #0 $node(element:attributeList) attrList 1888 catch {set result $attrList([lindex $args 0])} 1889 1890 return $result 1891 1892 } 1893 1894 setAttribute { 1895 if {[llength $args] != 2} { 1896 return -code error "wrong number of arguments" 1897 } 1898 1899 # Check that the attribute name is kosher 1900 if {![regexp ^$::xml::Name\$ [lindex $args 0]]} { 1901 return -code error "invalid attribute name \"[lindex $args 0]\"" 1902 } 1903 1904 upvar #0 $node(element:attributeList) attrList 1905 set evid [CreateEvent $token DOMAttrModified] 1906 set oldValue {} 1907 catch {set oldValue $attrList([lindex $args 0])} 1908 event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 1] [lindex $args 0] 1909 set result [set attrList([lindex $args 0]) [lindex $args 1]] 1910 node dispatchEvent $token $evid 1911 DOMImplementation destroy $evid 1912 1913 } 1914 1915 removeAttribute { 1916 if {[llength $args] != 1} { 1917 return -code error "wrong number of arguments" 1918 } 1919 1920 upvar #0 $node(element:attributeList) attrList 1921 catch {unset attrList([lindex $args 0])} 1922 1923 event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0] 1924 1925 } 1926 1927 getAttributeNS { 1928 if {[llength $args] != 2} { 1929 return -code error "wrong number of arguments" 1930 } 1931 1932 set result {} 1933 upvar #0 $node(element:attributeList) attrList 1934 catch {set result $attrList([lindex $args 0]^[lindex $args 1])} 1935 1936 return $result 1937 1938 } 1939 1940 setAttributeNS { 1941 if {[llength $args] != 3} { 1942 return -code error "wrong number of arguments" 1943 } 1944 1945 # Check that the attribute name is kosher 1946 if {![regexp ^$::xml::QName\$ [lindex $args 1] discard prefix localName]} { 1947 return -code error "invalid qualified attribute name \"[lindex $args 1]\"" 1948 } 1949 1950 # BUG: At the moment the prefix is ignored 1951 1952 upvar #0 $node(element:attributeList) attrList 1953 set evid [CreateEvent $token DOMAttrModified] 1954 set oldValue {} 1955 catch {set oldValue $attrList([lindex $args 0]^$localName)} 1956 event initMutationEvent $evid DOMAttrModified 1 0 $token $oldValue [lindex $args 2] [lindex $args 0]^localName 1957 set result [set attrList([lindex $args 0]^$localName) [lindex $args 2]] 1958 node dispatchEvent $token $evid 1959 DOMImplementation destroy $evid 1960 1961 } 1962 1963 removeAttributeNS { 1964 if {[llength $args] != 2} { 1965 return -code error "wrong number of arguments" 1966 } 1967 1968 upvar #0 $node(element:attributeList) attrList 1969 catch {unset attrList([lindex $args 0]^[lindex $args 1])} 1970 1971 event postMutationEvent $token DOMAttrRemoved -attrName [lindex $args 0]^[lindex $args 1] 1972 1973 } 1974 1975 getAttributeNode { 1976 array set tmp [array get $node(element:attributeList)] 1977 if {![info exists tmp([lindex $args 0])]} { 1978 return {} 1979 } 1980 1981 # Synthesize an attribute node if one doesn't already exist 1982 array set attrNodes $node(element:attributeNodes) 1983 if {[catch {set result $attrNodes([lindex $args 0])}]} { 1984 set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0] node:nodeValue $tmp([lindex $args 0])] 1985 lappend node(element:attributeNodes) [lindex $args 0] $result 1986 } 1987 } 1988 1989 setAttributeNode - 1990 removeAttributeNode - 1991 getAttributeNodeNS - 1992 setAttributeNodeNS - 1993 removeAttributeNodeNS { 1994 return -code error "not yet implemented" 1995 } 1996 1997 getElementsByTagName { 1998 if {[llength $args] < 1} { 1999 return -code error "wrong number of arguments" 2000 } 2001 2002 return [eval Element:GetByTagName [list $token [lindex $args 0]] \ 2003 [lrange $args 1 end]] 2004 } 2005 2006 normalize { 2007 if {[llength $args]} { 2008 return -code error "wrong number of arguments" 2009 } 2010 2011 Element:Normalize node [set $node(node:childNodes)] 2012 } 2013 2014 default { 2015 return -code error "unknown method \"$method\"" 2016 } 2017 2018 } 2019 2020 set $token [array get node] 2021 2022 return $result 2023} 2024 2025# dom::tcl::Element:GetByTagName -- 2026# 2027# Search for (child) elements 2028# 2029# This used to be non-recursive, but then I read the DOM spec 2030# properly and discovered that it should recurse. The -deep 2031# option allows for backward-compatibility, and defaults to the 2032# DOM-specified value of true. 2033# 2034# Arguments: 2035# token parent node 2036# name element type to search for 2037# args configuration options 2038# 2039# Results: 2040# The name of the variable containing the list of matching node tokens 2041 2042proc dom::tcl::Element:GetByTagName {token name args} { 2043 array set node [set $token] 2044 upvar \#0 $node(docArray) docArray 2045 2046 array set cfg {-deep 1} 2047 array set cfg $args 2048 set cfg(-deep) [Boolean $cfg(-deep)] 2049 2050 # Guard against arbitrary glob characters 2051 # Checking that name is a legal XML Name does this 2052 # However, '*' is permitted 2053 if {![regexp ^$::xml::Name\$ $name] && [string compare $name "*"]} { 2054 return -code error "invalid element name" 2055 } 2056 2057 # Allocate variable name for this search 2058 set searchVar $node(docArray)search[incr docArray(counter)] 2059 upvar \#0 $searchVar search 2060 2061 # Make list live by interposing on variable reads 2062 # I don't think we need to interpose on unsets, 2063 # and writing to this variable by the application is 2064 # not permitted. 2065 2066 trace variable $searchVar w [namespace code Element:GetByTagName:Error] 2067 2068 if {[string compare $node(node:nodeType) "documentFragment"]} { 2069 trace variable $searchVar r [namespace code [list Element:GetByTagName:Search [set $node(node:childNodes)] $name $cfg(-deep)]] 2070 } elseif {[llength $node(document:documentElement)]} { 2071 # Document Element must exist and must be an element type node 2072 trace variable $searchVar r [namespace code [list Element:GetByTagName:Search $node(document:documentElement) $name $cfg(-deep)]] 2073 } 2074 2075 return $searchVar 2076} 2077 2078# dom::tcl::Element:GetByTagName:Search -- 2079# 2080# Search for elements. This does the real work. 2081# Because this procedure is invoked everytime 2082# the variable is read, it returns the live list. 2083# 2084# Arguments: 2085# tokens nodes to search (inclusive) 2086# name element type to search for 2087# deep whether to search recursively 2088# name1 \ 2089# name2 > appended by trace command 2090# op / 2091# 2092# Results: 2093# List of matching node tokens 2094 2095proc dom::tcl::Element:GetByTagName:Search {tokens name deep name1 name2 op} { 2096 set result {} 2097 2098 foreach tok $tokens { 2099 catch {unset nodeInfo} 2100 array set nodeInfo [set $tok] 2101 switch -- $nodeInfo(node:nodeType) { 2102 element { 2103 if {[string match $name [GetField nodeInfo(node:nodeName)]]} { 2104 lappend result $tok 2105 } 2106 if {$deep} { 2107 set childResult [Element:GetByTagName:Search [set $nodeInfo(node:childNodes)] $name $deep {} {} {}] 2108 if {[llength $childResult]} { 2109 eval lappend result $childResult 2110 } 2111 } 2112 } 2113 } 2114 } 2115 2116 if {[string length $name1]} { 2117 set $name1 $result 2118 return {} 2119 } else { 2120 return $result 2121 } 2122} 2123 2124# dom::tcl::Element:GetByTagName:Error -- 2125# 2126# Complain about the application writing to a variable 2127# that this package maintains. 2128# 2129# Arguments: 2130# name1 \ 2131# name2 > appended by trace command 2132# op / 2133# 2134# Results: 2135# Error code returned. 2136 2137proc dom::tcl::Element:GetByTagName:Error {name1 name2 op} { 2138 return -code error "dom: Read-only variable" 2139} 2140 2141# dom::tcl::Element:Normalize -- 2142# 2143# Normalize the text nodes 2144# 2145# Arguments: 2146# pVar parent array variable in caller 2147# nodes list of node tokens 2148# 2149# Results: 2150# Adjacent text nodes are coalesced 2151 2152proc dom::tcl::Element:Normalize {pVar nodes} { 2153 upvar $pVar parent 2154 2155 set textNode {} 2156 2157 foreach n $nodes { 2158 array set child [set $n] 2159 set cleanup {} 2160 2161 switch $child(node:nodeType) { 2162 textNode { 2163 if {[llength $textNode]} { 2164 2165 # Coalesce into previous node 2166 set evid [CreateEvent $n DOMCharacterDataModified] 2167 event initMutationEvent $evid DOMCharacterDataModified 1 0 {} $text(node:nodeValue) $text(node:nodeValue)$child(node:nodeValue) {} 2168 append text(node:nodeValue) $child(node:nodeValue) 2169 node dispatchEvent $n $evid 2170 DOMImplementation destroy $evid 2171 2172 # Remove this child 2173 upvar #0 $parent(node:childNodes) childNodes 2174 set idx [lsearch $childNodes $n] 2175 set childNodes [lreplace $childNodes $idx $idx] 2176 unset $n 2177 set cleanup [list event postMutationEvent [node parent $n] DOMSubtreeModified] 2178 event postMutationEvent $n DOMNodeRemoved 2179 2180 set $textNode [array get text] 2181 } else { 2182 set textNode $n 2183 catch {unset text} 2184 array set text [array get child] 2185 } 2186 } 2187 element - 2188 document - 2189 documentFragment { 2190 set textNode {} 2191 Element:Normalize child [set $child(node:childNodes)] 2192 } 2193 default { 2194 set textNode {} 2195 } 2196 } 2197 2198 eval $cleanup 2199 } 2200 2201 return {} 2202} 2203 2204# dom::tcl::processinginstruction -- 2205# 2206# Functions for a processing intruction. 2207# 2208# Arguments: 2209# method method to invoke 2210# token token for node 2211# args arguments for method 2212# 2213# Results: 2214# Depends on method used. 2215 2216namespace eval dom::tcl { 2217 variable piOptionsRO target 2218 variable piOptionsRW data 2219} 2220 2221proc dom::tcl::processinginstruction {method token args} { 2222 variable piOptionsRO 2223 variable piOptionsRW 2224 2225 array set node [set $token] 2226 2227 set result {} 2228 2229 switch -- $method { 2230 2231 cget { 2232 # Some read-only configuration options are computed 2233 if {[llength $args] != 1} { 2234 return -code error "too many arguments" 2235 } 2236 if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} { 2237 switch $option { 2238 target { 2239 set result [lindex $node(node:nodeName) 0] 2240 } 2241 default { 2242 return $node(node:$option) 2243 } 2244 } 2245 } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} { 2246 switch $option { 2247 data { 2248 return $node(node:nodeValue) 2249 } 2250 default { 2251 return $node(node:$option) 2252 } 2253 } 2254 } else { 2255 return -code error "unknown option \"[lindex $args 0]\"" 2256 } 2257 } 2258 configure { 2259 if {[llength $args] == 1} { 2260 return [document cget $token [lindex $args 0]] 2261 } elseif {[expr [llength $args] % 2]} { 2262 return -code error "no value specified for option \"[lindex $args end]\"" 2263 } else { 2264 foreach {option value} $args { 2265 if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} { 2266 return -code error "attribute \"$option\" is read-only" 2267 } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} { 2268 switch $opt { 2269 data { 2270 set evid [CreateEvent $token DOMCharacterDataModified] 2271 event initMutationEvent $evid DOMCharacterModified 1 0 {} $node(node:nodeValue) $value {} 2272 set node(node:nodeValue) $value 2273 node dispatchEvent $token $evid 2274 DOMImplementation destroy $evid 2275 } 2276 default { 2277 set node(node:$opt) $value 2278 } 2279 } 2280 } else { 2281 return -code error "unknown option \"$option\"" 2282 } 2283 } 2284 } 2285 } 2286 2287 default { 2288 return -code error "unknown method \"$method\"" 2289 } 2290 2291 } 2292 2293 set $token [array get node] 2294 2295 return $result 2296} 2297 2298################################################# 2299# 2300# DOM Level 2 Interfaces 2301# 2302################################################# 2303 2304# dom::tcl::event -- 2305# 2306# Implements Event Interface 2307# 2308# Subclassed Interfaces are also defined here, 2309# such as UIEvents. 2310# 2311# Arguments: 2312# method method to invoke 2313# token token for event 2314# args arguments for method 2315# 2316# Results: 2317# Depends on method used. 2318 2319namespace eval dom::tcl { 2320 variable eventOptionsRO type|target|currentNode|eventPhase|bubbles|cancelable|timeStamp|detail|view|screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode|prevValue|newValue|attrName 2321 variable eventOptionsRW {} 2322 2323 # Issue: should the attributes belonging to the subclassed Interface 2324 # be separated out? 2325 2326 variable uieventOptionsRO detail|view 2327 variable uieventOptionsRW {} 2328 2329 variable mouseeventOptionsRO screenX|screenY|clientX|clientY|ctrlKey|shiftKey|altKey|metaKey|button|relatedNode 2330 variable mouseeventOptionsRW {} 2331 2332 variable mutationeventOptionsRO relatedNode|prevValue|newValue|attrName 2333 variable mutationeventOptionsRW {} 2334} 2335 2336proc dom::tcl::event {method token args} { 2337 variable eventOptionsRO 2338 variable eventOptionsRW 2339 2340 array set event [set $token] 2341 2342 set result {} 2343 2344 switch -glob -- $method { 2345 2346 cg* { 2347 # cget 2348 2349 if {[llength $args] != 1} { 2350 return -code error "too many arguments" 2351 } 2352 if {[regexp [format {^-(%s)$} $eventOptionsRO] [lindex $args 0] discard option]} { 2353 return $event($option) 2354 } elseif {[regexp [format {^-(%s)$} $eventOptionsRW] [lindex $args 0] discard option]} { 2355 return $event($option) 2356 } else { 2357 return -code error "unknown option \"[lindex $args 0]\"" 2358 } 2359 } 2360 2361 co* { 2362 # configure 2363 2364 if {[llength $args] == 1} { 2365 return [event cget $token [lindex $args 0]] 2366 } elseif {[expr [llength $args] % 2]} { 2367 return -code error "no value specified for option \"[lindex $args end]\"" 2368 } else { 2369 foreach {option value} $args { 2370 if {[regexp [format {^-(%s)$} $eventOptionsRW] $option discard opt]} { 2371 set event($opt) $value 2372 } elseif {[regexp [format {^-(%s)$} $eventOptionsRO] $option discard opt]} { 2373 return -code error "attribute \"$option\" is read-only" 2374 } else { 2375 return -code error "unknown option \"$option\"" 2376 } 2377 } 2378 } 2379 2380 set $token [array get event] 2381 2382 } 2383 2384 st* { 2385 # stopPropagation 2386 2387 set event(stopPropagation) 1 2388 set $token [array get event] 2389 2390 } 2391 2392 pr* { 2393 # preventDefault 2394 2395 set event(preventDefault) 1 2396 set $token [array get event] 2397 2398 } 2399 2400 initE* { 2401 # initEvent 2402 2403 if {[llength $args] != 3} { 2404 return -code error "wrong number of arguments" 2405 } 2406 2407 if {$event(dispatched)} { 2408 return -code error "event has been dispatched" 2409 } 2410 2411 foreach {event(type) event(bubbles) event(cancelable)} $args break 2412 set event(type) [string tolower $event(type)] 2413 2414 set $token [array get event] 2415 2416 } 2417 2418 initU* { 2419 # initUIEvent 2420 2421 if {[llength $args] < 4 || [llength $args] > 5} { 2422 return -code error "wrong number of arguments" 2423 } 2424 2425 if {$event(dispatched)} { 2426 return -code error "event has been dispatched" 2427 } 2428 2429 set event(detail) 0 2430 foreach {event(type) event(bubbles) event(cancelable) event(view) event(detail)} $args break 2431 set event(type) [string tolower $event(type)] 2432 2433 set $token [array get event] 2434 2435 } 2436 2437 initMo* { 2438 # initMouseEvent 2439 2440 if {[llength $args] != 15} { 2441 return -code error "wrong number of arguments" 2442 } 2443 2444 if {$event(dispatched)} { 2445 return -code error "event has been dispatched" 2446 } 2447 2448 set event(detail) 1 2449 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 2450 set event(type) [string tolower $event(type)] 2451 2452 set $token [array get event] 2453 2454 } 2455 2456 initMu* { 2457 # initMutationEvent 2458 2459 if {[llength $args] != 7} { 2460 return -code error "wrong number of arguments" 2461 } 2462 2463 if {$event(dispatched)} { 2464 return -code error "event has been dispatched" 2465 } 2466 2467 foreach {event(type) event(bubbles) event(cancelable) event(relatedNode) event(prevValue) event(newValue) event(attrName)} $args break 2468 set event(type) [string tolower $event(type)] 2469 2470 set $token [array get event] 2471 2472 } 2473 2474 postUI* { 2475 # postUIEvent, non-standard convenience method 2476 2477 set evType [lindex $args 0] 2478 array set evOpts [list \ 2479 -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \ 2480 -view {} \ 2481 -detail {} \ 2482 ] 2483 array set evOpts [lrange $args 1 end] 2484 2485 set evid [CreateEvent $token $evType] 2486 event initUIEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-view) $evOpts(-detail) 2487 node dispatchEvent $token $evid 2488 DOMImplementation destroy $evid 2489 2490 } 2491 2492 postMo* { 2493 # postMouseEvent, non-standard convenience method 2494 2495 set evType [lindex $args 0] 2496 array set evOpts [list \ 2497 -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \ 2498 -view {} \ 2499 -detail {} \ 2500 -screenX {} \ 2501 -screenY {} \ 2502 -clientX {} \ 2503 -clientY {} \ 2504 -ctrlKey {} \ 2505 -altKey {} \ 2506 -shiftKey {} \ 2507 -metaKey {} \ 2508 -button {} \ 2509 -relatedNode {} \ 2510 ] 2511 array set evOpts [lrange $args 1 end] 2512 2513 set evid [CreateEvent $token $evType] 2514 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) 2515 node dispatchEvent $token $evid 2516 DOMImplementation destroy $evid 2517 2518 } 2519 2520 postMu* { 2521 # postMutationEvent, non-standard convenience method 2522 2523 set evType [lindex $args 0] 2524 array set evOpts [list \ 2525 -bubbles $::dom::bubbles($evType) -cancelable $::dom::cancelable($evType) \ 2526 -relatedNode {} \ 2527 -prevValue {} -newValue {} \ 2528 -attrName {} \ 2529 ] 2530 array set evOpts [lrange $args 1 end] 2531 2532 set evid [CreateEvent $token $evType] 2533 event initMutationEvent $evid $evType $evOpts(-bubbles) $evOpts(-cancelable) $evOpts(-relatedNode) $evOpts(-prevValue) $evOpts(-newValue) $evOpts(-attrName) 2534 node dispatchEvent $token $evid 2535 DOMImplementation destroy $evid 2536 2537 } 2538 2539 default { 2540 return -code error "unknown method \"$method\"" 2541 } 2542 } 2543 2544 return $result 2545} 2546 2547# dom::tcl::CreateEvent -- 2548# 2549# Create an event object 2550# 2551# Arguments: 2552# token parent node 2553# type event type 2554# args configuration options 2555# 2556# Results: 2557# Returns event token 2558 2559proc dom::tcl::CreateEvent {token type args} { 2560 if {[string length $token]} { 2561 array set parent [set $token] 2562 upvar #0 $parent(docArray) docArray 2563 set docArrayName $parent(docArray) 2564 } else { 2565 array set opts $args 2566 upvar #0 $opts(-docarray) docArray 2567 set docArrayName $opts(-docarray) 2568 } 2569 2570 set id event[incr docArray(counter)] 2571 set child ${docArrayName}($id) 2572 2573 # Create the event 2574 set docArray($id) [list id $id docArray $docArrayName \ 2575 node:nodeType event \ 2576 type $type \ 2577 cancelable 1 \ 2578 stopPropagation 0 \ 2579 preventDefault 0 \ 2580 dispatched 0 \ 2581 bubbles 1 \ 2582 eventPhase {} \ 2583 timeStamp [clock clicks -milliseconds] \ 2584 ] 2585 2586 return $child 2587} 2588 2589################################################# 2590# 2591# Serialisation 2592# 2593################################################# 2594 2595# dom::tcl::Serialize:documentFragment -- 2596# 2597# Produce text for documentFragment. 2598# 2599# Arguments: 2600# token node token 2601# args configuration options 2602# 2603# Results: 2604# XML format text. 2605 2606proc dom::tcl::Serialize:documentFragment {token args} { 2607 array set node [set $token] 2608 2609 if {[string compare "node1" $node(documentFragment:masterDoc)]} { 2610 return [eval [list Serialize:node $token] $args] 2611 } else { 2612 if {[string compare {} [GetField node(document:documentElement)]]} { 2613 return [eval Serialize:document [list $token] $args] 2614 } else { 2615 return -code error "document has no document element" 2616 } 2617 } 2618 2619} 2620 2621# dom::tcl::Serialize:document -- 2622# 2623# Produce text for document. 2624# 2625# Arguments: 2626# token node token 2627# args configuration options 2628# 2629# Results: 2630# XML format text. 2631 2632proc dom::tcl::Serialize:document {token args} { 2633 array set node [set $token] 2634 array set opts { 2635 -showxmldecl 1 2636 -showdoctypedecl 1 2637 } 2638 array set opts $args 2639 2640 if {![info exists node(document:documentElement)]} { 2641 return -code error "document has no document element" 2642 } elseif {![string length node(document:doctype)]} { 2643 return -code error "no document type declaration given" 2644 } else { 2645 2646 array set doctype [set $node(document:doctype)] 2647 2648 # Bug fix: can't use Serialize:attributeList for XML declaration, 2649 # since attributes must occur in a given order (XML 2.8 [23]) 2650 2651 set result {} 2652 2653 if {$opts(-showxmldecl)} { 2654 append result <?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n 2655 } 2656 if {$opts(-showdoctypedecl)} { 2657 # Is document element in an XML Namespace? 2658 # If so then include prefix in doctype decl 2659 foreach {prefix localName} [::xml::qnamesplit $doctype(doctype:name)] break 2660 if {![string length $prefix]} { 2661 # The prefix may not have been allocated yet 2662 array set docel [set $node(document:documentElement)] 2663 if {[info exists docel(node:namespaceURI)] && \ 2664 [string length $docel(node:namespaceURI)]} { 2665 set declPrefix [GetNamespacePrefix $node(document:documentElement) $docel(node:namespaceURI)] 2666 set docelName $declPrefix:$doctype(doctype:name) 2667 } else { 2668 set docelName $doctype(doctype:name) 2669 } 2670 } else { 2671 set docelName $doctype(doctype:name) 2672 } 2673 # Applied patch by Marco Gonnelli, bug #590914 2674 append result <!DOCTYPE\ $docelName[Serialize:ExternalID $doctype(doctype:externalid)][expr {[string length $doctype(doctype:internaldtd)] ? " \[[string trim $doctype(doctype:internaldtd) \{\} ]\]" : {}}]>\n 2675 } 2676 2677 # BUG #525505: Want to serialize all children including the 2678 # document element. 2679 2680 foreach child [set $node(node:childNodes)] { 2681 append result [eval Serialize:[node cget $child -nodeType] [list $child] $args] 2682 } 2683 2684 return $result 2685 } 2686 2687} 2688 2689# dom::tcl::Serialize:ExternalID -- 2690# 2691# Returned appropriately quoted external identifiers 2692# 2693# Arguments: 2694# id external indentifiers 2695# 2696# Results: 2697# text 2698 2699proc dom::tcl::Serialize:ExternalID id { 2700 set publicid {} 2701 set systemid {} 2702 foreach {publicid systemid} $id break 2703 2704 switch -glob -- [string length $publicid],[string length $systemid] { 2705 0,0 { 2706 return {} 2707 } 2708 0,* { 2709 return " SYSTEM \"$systemid\"" 2710 } 2711 *,* { 2712 # Patch from c.l.t., Richard Calmbach (rc@hnc.com ) 2713 return " PUBLIC \"$publicid\" \"$systemid\"" 2714 } 2715 } 2716 2717 return {} 2718} 2719 2720# dom::tcl::Serialize:XMLDecl -- 2721# 2722# Produce text for XML Declaration attribute. 2723# Order is determine by document serialisation procedure. 2724# 2725# Arguments: 2726# attr required attribute 2727# attList attribute list 2728# 2729# Results: 2730# XML format text. 2731 2732proc dom::tcl::Serialize:XMLDecl {attr attrList} { 2733 array set data $attrList 2734 if {![info exists data($attr)]} { 2735 return {} 2736 } elseif {[string length $data($attr)]} { 2737 return " $attr='$data($attr)'" 2738 } else { 2739 return {} 2740 } 2741} 2742 2743# dom::tcl::Serialize:node -- 2744# 2745# Produce text for an arbitrary node. 2746# This simply serializes the child nodes of the node. 2747# 2748# Arguments: 2749# token node token 2750# args configuration options 2751# 2752# Results: 2753# XML format text. 2754 2755proc dom::tcl::Serialize:node {token args} { 2756 array set node [set $token] 2757 array set opts $args 2758 2759 if {[info exists opts(-indent)]} { 2760 # NB. 0|1 cannot be used as booleans - mention this in docn 2761 if {[regexp {^false|no|off$} $opts(-indent)]} { 2762 # No action required 2763 } elseif {[regexp {^true|yes|on$} $opts(-indent)]} { 2764 set opts(-indent) 1 2765 } else { 2766 incr opts(-indent) 2767 } 2768 } 2769 2770 set result {} 2771 foreach childToken [set $node(node:childNodes)] { 2772 catch {unset child} 2773 array set child [set $childToken] 2774 append result [eval [list Serialize:$child(node:nodeType) $childToken] [array get opts]] 2775 } 2776 2777 return $result 2778} 2779 2780# dom::tcl::Serialize:element -- 2781# 2782# Produce text for an element. 2783# 2784# Arguments: 2785# token node token 2786# args configuration options 2787# 2788# Results: 2789# XML format text. 2790 2791proc dom::tcl::Serialize:element {token args} { 2792 array set node [set $token] 2793 array set opts {-newline {}} 2794 array set opts $args 2795 2796 set result {} 2797 set newline {} 2798 if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} { 2799 append result \n 2800 set newline \n 2801 } 2802 append result [eval Serialize:Indent [array get opts]] 2803 switch [info exists node(node:namespaceURI)],[info exists node(node:prefix)] { 2804 2805 1,1 { 2806 # XML Namespace is in scope, prefix supplied 2807 if {[string length $node(node:prefix)]} { 2808 # Make sure that there's a declaration for this XML Namespace 2809 set declPrefix [GetNamespacePrefix $token $node(node:namespaceURI) -prefix $node(node:prefix)] 2810 # ASSERTION: $declPrefix == $node(node:prefix) 2811 set nsPrefix $node(node:prefix): 2812 } elseif {[string length $node(node:namespaceURI)]} { 2813 set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]: 2814 } else { 2815 set nsPrefix {} 2816 } 2817 } 2818 2819 1,0 { 2820 # XML Namespace is in scope, no prefix 2821 set nsPrefix [GetNamespacePrefix $token $node(node:namespaceURI)]: 2822 if {![string compare $nsPrefix :]} { 2823 set nsPrefix {} 2824 } 2825 } 2826 2827 0,1 { 2828 # Internal error 2829 set nsPrefix {} 2830 } 2831 2832 0,0 - 2833 default { 2834 # No XML Namespace is in scope 2835 set nsPrefix {} 2836 } 2837 } 2838 append result <$nsPrefix$node(node:localName) 2839 2840 append result [Serialize:attributeList [array get $node(element:attributeList)]] 2841 2842 if {![llength [set $node(node:childNodes)]]} { 2843 2844 append result />$newline 2845 2846 } else { 2847 2848 append result >$newline 2849 2850 # Do the children 2851 if {[hasmixedcontent $token]} { 2852 set opts(-indent) no 2853 } 2854 append result [eval Serialize:node [list $token] [array get opts]] 2855 2856 append result [eval Serialize:Indent [array get opts]] 2857 append result "$newline</$nsPrefix$node(node:localName)>$newline" 2858 2859 } 2860 2861 return $result 2862} 2863 2864# dom::tcl::GetNamespacePrefix -- 2865# 2866# Determine the XML Namespace prefix for a Namespace URI 2867# 2868# Arguments: 2869# token node token 2870# nsuri XML Namespace URI 2871# args configuration options 2872# 2873# Results: 2874# Returns prefix. 2875# May add prefix information to node 2876 2877proc dom::tcl::GetNamespacePrefix {token nsuri args} { 2878 array set options $args 2879 array set node [set $token] 2880 2881 GetNamespaceDecl $token $nsuri declNode prefix 2882 2883 if {[llength $declNode]} { 2884 # A declaration was found for this Namespace URI 2885 return $prefix 2886 } else { 2887 # No declaration found. Allocate a prefix 2888 # and add XML Namespace declaration 2889 set prefix {} 2890 catch {set prefix $options(-prefix)} 2891 if {![string compare $prefix {}]} { 2892 upvar \#0 $node(docArray) docArray 2893 set prefix ns[incr docArray(counter)] 2894 } 2895 set node(node:prefix) $prefix 2896 upvar \#0 $node(element:attributeList) attrs 2897 set attrs(${::dom::xmlnsURI}^$prefix) $nsuri 2898 2899 return $prefix 2900 } 2901} 2902 2903# dom::tcl::GetNamespaceDecl -- 2904# 2905# Find the XML Namespace declaration. 2906# 2907# Arguments: 2908# token node token 2909# nsuri XML Namespace URI 2910# nodeVar Variable name for declaration 2911# prefVar Variable for prefix 2912# 2913# Results: 2914# If the declaration is found returns node and prefix 2915 2916proc dom::tcl::GetNamespaceDecl {token nsuri nodeVar prefVar} { 2917 upvar $nodeVar declNode 2918 upvar $prefVar prefix 2919 2920 array set nodeinfo [set $token] 2921 while {[string length $nodeinfo(node:parentNode)]} { 2922 2923 # Check this node's XML Namespace declarations 2924 catch {unset attrs} 2925 array set attrs [array get $nodeinfo(element:attributeList)] 2926 foreach {nsdecl decluri} [array get attrs ${::dom::xmlnsURI}^*] { 2927 if {![string compare $decluri $nsuri]} { 2928 regexp [format {%s\^(.*)} $::dom::xmlnsURI] $nsdecl dummy prefix 2929 set declNode $token 2930 return 2931 } 2932 } 2933 2934 # Move up to parent 2935 set token $nodeinfo(node:parentNode) 2936 array set nodeinfo [set $token] 2937 } 2938 2939 # Got to Document node and didn't find XML NS decl 2940 set prefix {} 2941 set declNode {} 2942} 2943 2944# dom::tcl::Serialize:textNode -- 2945# 2946# Produce text for a text node. This procedure may 2947# return a CDATA section where appropriate. 2948# 2949# Arguments: 2950# token node token 2951# args configuration options 2952# 2953# Results: 2954# XML format text. 2955 2956proc dom::tcl::Serialize:textNode {token args} { 2957 array set node [set $token] 2958 2959 if {$node(node:cdatasection)} { 2960 return [Serialize:CDATASection $node(node:nodeValue)] 2961 } elseif {[Serialize:ExceedsThreshold $node(node:nodeValue)]} { 2962 return [Serialize:CDATASection $node(node:nodeValue)] 2963 } else { 2964 return [Encode $node(node:nodeValue)] 2965 } 2966} 2967 2968# dom::tcl::Serialize:ExceedsThreshold -- 2969# 2970# Applies heuristic(s) to determine whether a text node 2971# should be formatted as a CDATA section. 2972# 2973# Arguments: 2974# text node text 2975# 2976# Results: 2977# Boolean. 2978 2979proc dom::tcl::Serialize:ExceedsThreshold {text} { 2980 return [expr {[regsub -all {[<>&]} $text {} discard] > $::dom::maxSpecials}] 2981} 2982 2983# dom::tcl::Serialize:CDATASection -- 2984# 2985# Formats a CDATA section. 2986# 2987# Arguments: 2988# text node text 2989# 2990# Results: 2991# XML text. 2992 2993proc dom::tcl::Serialize:CDATASection {text} { 2994 set result {} 2995 while {[regexp {(.*)]]>(.*)} $text discard text trailing]} { 2996 set result \]\]>\;<!\[CDATA\[$trailing\]\]>$result 2997 } 2998 return <!\[CDATA\[$text\]\]>$result 2999} 3000 3001# dom::tcl::Serialize:processingInstruction -- 3002# 3003# Produce text for a PI node. 3004# 3005# Arguments: 3006# token node token 3007# args configuration options 3008# 3009# Results: 3010# XML format text. 3011 3012proc dom::tcl::Serialize:processingInstruction {token args} { 3013 array set node [set $token] 3014 3015 return "[eval Serialize:Indent $args]<?$node(node:nodeName)[expr {$node(node:nodeValue) == "" ? "" : " $node(node:nodeValue)"}]?>" 3016} 3017 3018# dom::tcl::Serialize:comment -- 3019# 3020# Produce text for a comment node. 3021# 3022# Arguments: 3023# token node token 3024# args configuration options 3025# 3026# Results: 3027# XML format text. 3028 3029proc dom::tcl::Serialize:comment {token args} { 3030 array set node [set $token] 3031 3032 return [eval Serialize:Indent $args]<!--$node(node:nodeValue)--> 3033} 3034 3035# dom::tcl::Serialize:entityReference -- 3036# 3037# Produce text for an entity reference. 3038# 3039# Arguments: 3040# token node token 3041# args configuration options 3042# 3043# Results: 3044# XML format text. 3045 3046proc dom::tcl::Serialize:entityReference {token args} { 3047 array set node [set $token] 3048 3049 return &$node(node:nodeName)\; 3050} 3051 3052# dom::tcl::Encode -- 3053# 3054# Encode special characters 3055# 3056# Arguments: 3057# value text value 3058# 3059# Results: 3060# XML format text. 3061 3062proc dom::tcl::Encode value { 3063 array set Entity { 3064 $ $ 3065 < < 3066 > > 3067 & & 3068 \" " 3069 ' ' 3070 } 3071 3072 regsub -all {([$<>&"'])} $value {$Entity(\1)} value 3073 3074 return [subst -nocommand -nobackslash $value] 3075} 3076 3077# dom::tcl::Serialize:attributeList -- 3078# 3079# Produce text for an attribute list. 3080# 3081# Arguments: 3082# l name/value paired list 3083# 3084# Results: 3085# XML format text. 3086 3087proc dom::tcl::Serialize:attributeList {l} { 3088 3089 set result {} 3090 foreach {name value} $l { 3091 3092 if {[regexp {^([^^]+)\^(.*)$} $name discard nsuri prefix]} { 3093 if {[string compare $nsuri $::dom::xmlnsURI]} { 3094 # Need the node token to resolve the Namespace URI 3095 append result { } ?:$prefix = 3096 } else { 3097 # A Namespace declaration 3098 append result { } xmlns:$prefix = 3099 } 3100 } else { 3101 append result { } $name = 3102 } 3103 3104 # Handle special characters 3105 regsub -all & $value {\&} value 3106 regsub -all < $value {\<} value 3107 3108 if {![string match *\"* $value]} { 3109 append result \"$value\" 3110 } elseif {![string match *'* $value]} { 3111 append result '$value' 3112 } else { 3113 regsub -all \" $value {\"} value 3114 append result \"$value\" 3115 } 3116 3117 } 3118 3119 return $result 3120} 3121 3122# dom::tcl::Serialize:Indent -- 3123# 3124# Calculate the indentation required, if any 3125# 3126# Arguments: 3127# args configuration options, which may specify -indent 3128# 3129# Results: 3130# May return white space 3131 3132proc dom::tcl::Serialize:Indent args { 3133 array set opts [list -indentspec $::dom::indentspec] 3134 array set opts $args 3135 3136 if {![info exists opts(-indent)] || \ 3137 [regexp {^false|no|off$} $opts(-indent)]} { 3138 return {} 3139 } 3140 3141 if {[regexp {^true|yes|on$} $opts(-indent)]} { 3142 # Default indent level is 0 3143 return \n 3144 } 3145 3146 if {!$opts(-indent)} { 3147 return \n 3148 } 3149 3150 set ws [format \n%\ [expr $opts(-indent) * [lindex $opts(-indentspec) 0]]s { }] 3151 regsub -all [lindex [lindex $opts(-indentspec) 1] 0] $ws [lindex [lindex $opts(-indentspec) 1] 1] ws 3152 3153 return $ws 3154 3155} 3156 3157################################################# 3158# 3159# Parsing 3160# 3161################################################# 3162 3163# dom::tcl::ParseElementStart -- 3164# 3165# Push a new element onto the stack. 3166# 3167# Arguments: 3168# stateVar global state array variable 3169# name element name 3170# attrList attribute list 3171# args configuration options 3172# 3173# Results: 3174# An element is created within the currently open element. 3175 3176proc dom::tcl::ParseElementStart {stateVar name attrList args} { 3177 3178 upvar #0 $stateVar state 3179 array set opts $args 3180 3181 # Push namespace declarations 3182 # We need to be able to map namespaceURI's back to prefixes 3183 set nsattrlists {} 3184 catch { 3185 foreach {namespaceURI prefix} $opts(-namespacedecls) { 3186 lappend state(NS:$namespaceURI) $prefix 3187 3188 # Also, synthesize namespace declaration attributes 3189 # TclXML is a little too clever when it parses them away! 3190 3191 lappend nsattrlists $prefix $namespaceURI 3192 } 3193 lappend opts(-namespaceattributelists) $::dom::xmlnsURI $nsattrlists 3194 3195 } 3196 3197 set nsarg {} 3198 catch { 3199 lappend nsarg -namespace $opts(-namespace) 3200 lappend nsarg -localname $name 3201 lappend nsarg -prefix [lindex $state(NS:$opts(-namespace)) end] 3202 } 3203 3204 lappend state(current) \ 3205 [eval CreateElement [list [lindex $state(current) end] $name $attrList] $nsarg [array get opts -namespaceattributelists]] 3206 3207 if {[info exists opts(-empty)] && $opts(-empty)} { 3208 # Flag this node as being an empty element 3209 array set node [set [lindex $state(current) end]] 3210 set node(element:empty) 1 3211 set [lindex $state(current) end] [array get node] 3212 } 3213 3214 # Temporary: implement -progresscommand here, because of broken parser 3215 if {[string length $state(-progresscommand)]} { 3216 if {!([incr state(progCounter)] % $state(-chunksize))} { 3217 uplevel #0 $state(-progresscommand) 3218 } 3219 } 3220} 3221 3222# dom::tcl::ParseElementEnd -- 3223# 3224# Pop an element from the stack. 3225# 3226# Arguments: 3227# stateVar global state array variable 3228# name element name 3229# args configuration options 3230# 3231# Results: 3232# Currently open element is closed. 3233 3234proc dom::tcl::ParseElementEnd {stateVar name args} { 3235 upvar #0 $stateVar state 3236 3237 set state(current) [lreplace $state(current) end end] 3238} 3239 3240# dom::tcl::ParseCharacterData -- 3241# 3242# Add a textNode to the currently open element. 3243# 3244# Arguments: 3245# stateVar global state array variable 3246# data character data 3247# 3248# Results: 3249# A textNode is created. 3250 3251proc dom::tcl::ParseCharacterData {stateVar data} { 3252 upvar #0 $stateVar state 3253 3254 CreateTextNode [lindex $state(current) end] $data 3255} 3256 3257# dom::tcl::ParseProcessingInstruction -- 3258# 3259# Add a PI to the currently open element. 3260# 3261# Arguments: 3262# stateVar global state array variable 3263# name PI name 3264# target PI target 3265# 3266# Results: 3267# A processingInstruction node is created. 3268 3269proc dom::tcl::ParseProcessingInstruction {stateVar name target} { 3270 upvar #0 $stateVar state 3271 3272 CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target 3273} 3274 3275# dom::tcl::ParseXMLDeclaration -- 3276# 3277# Add information from the XML Declaration to the document. 3278# 3279# Arguments: 3280# stateVar global state array variable 3281# version version identifier 3282# encoding character encoding 3283# standalone standalone document declaration 3284# 3285# Results: 3286# Document node modified. 3287 3288proc dom::tcl::ParseXMLDeclaration {stateVar version encoding standalone} { 3289 upvar #0 $stateVar state 3290 3291 array set node [set $state(docNode)] 3292 array set xmldecl $node(document:xmldecl) 3293 3294 array set xmldecl [list version $version \ 3295 standalone $standalone \ 3296 encoding $encoding \ 3297 ] 3298 3299 set node(document:xmldecl) [array get xmldecl] 3300 set $state(docNode) [array get node] 3301 3302 return {} 3303} 3304 3305# dom::tcl::ParseDocType -- 3306# 3307# Add a Document Type Declaration node to the document. 3308# 3309# Arguments: 3310# stateVar global state array variable 3311# root root element type 3312# publit public identifier literal 3313# systemlist system identifier literal 3314# dtd internal DTD subset 3315# 3316# Results: 3317# DocType node added 3318 3319proc dom::tcl::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}} args} { 3320 upvar #0 $stateVar state 3321 3322 CreateDocType $state(docNode) $root [list $publit $systemlit] $dtd {} {} 3323 # Last two are entities and notaions (as namedNodeMap's) 3324 3325 return {} 3326} 3327 3328# dom::tcl::ParseComment -- 3329# 3330# Parse comment 3331# 3332# Arguments: 3333# stateVar state array 3334# data comment data 3335# 3336# Results: 3337# Comment node added to DOM tree 3338 3339proc dom::tcl::ParseComment {stateVar data} { 3340 upvar #0 $stateVar state 3341 3342 CreateGeneric [lindex $state(current) end] node:nodeType comment node:nodeValue $data 3343 3344 return {} 3345} 3346 3347# dom::tcl::ParseEntityReference -- 3348# 3349# Parse an entity reference 3350# 3351# Arguments: 3352# stateVar state variable 3353# ref entity 3354# 3355# Results: 3356# Entity reference node added to DOM tree 3357 3358proc dom::tcl::ParseEntityReference {stateVar ref} { 3359 upvar #0 $stateVar state 3360 3361 CreateGeneric [lindex $state(current) end] node:nodeType entityReference node:nodeName $ref 3362 3363 return {} 3364} 3365 3366################################################# 3367# 3368# Trim white space 3369# 3370################################################# 3371 3372# dom::tcl::Trim -- 3373# 3374# Remove textNodes that only contain white space 3375# 3376# Arguments: 3377# nodeid node to trim 3378# 3379# Results: 3380# textNode nodes may be removed (from descendants) 3381 3382proc dom::tcl::Trim nodeid { 3383 array set node [set $nodeid] 3384 3385 switch $node(node:nodeType) { 3386 3387 textNode { 3388 if {![string length [string trim $node(node:nodeValue)]]} { 3389 node removeChild $node(node:parentNode) $nodeid 3390 } 3391 } 3392 3393 default { 3394 # Some nodes have no child list. Reported by Jim Hollister <jhollister@objectspace.com> 3395 set children {} 3396 catch {set children [set $node(node:childNodes)]} 3397 foreach child $children { 3398 Trim $child 3399 } 3400 } 3401 3402 } 3403 3404 return {} 3405} 3406 3407################################################# 3408# 3409# Query function 3410# 3411################################################# 3412 3413# dom::tcl::Query -- 3414# 3415# Search DOM. 3416# 3417# DEPRECATED: This is obsoleted by XPath. 3418# 3419# Arguments: 3420# token node to search 3421# args query options 3422# 3423# Results: 3424# If query is found, return the node ID of the containing node. 3425# Otherwise, return empty string 3426 3427proc dom::tcl::Query {token args} { 3428 array set node [set $token] 3429 array set query $args 3430 3431 set found 0 3432 switch $node(node:nodeType) { 3433 document - 3434 documentFragment { 3435 foreach child [set $node(node:childNodes)] { 3436 if {[llength [set result [eval Query [list $child] $args]]]} { 3437 return $result 3438 } 3439 } 3440 } 3441 element { 3442 catch {set found [expr ![string compare $node(node:nodeName) $query(-tagname)]]} 3443 if {$found} { 3444 return $token 3445 } 3446 if {![catch {array set attributes [set $node(element:attributeList)]}]} { 3447 catch {set found [expr [lsearch [array names attributes] $query(-attrname)] >= 0]} 3448 catch {set found [expr $found || [lsearch [array get attributes] $query(-attrvalue)] >= 0]} 3449 } 3450 3451 if {$found} { 3452 return $token 3453 } 3454 3455 foreach child [set $node(node:childNodes)] { 3456 if {[llength [set result [eval Query [list $child] $args]]]} { 3457 return $result 3458 } 3459 } 3460 3461 } 3462 textNode - 3463 comment { 3464 catch { 3465 set querytext [expr {$node(node:nodeType) == "textNode" ? $query(-text) : $query(-comment)}] 3466 set found [expr [string match $node(node:nodeValue) $querytext] >= 0] 3467 } 3468 3469 if {$found} { 3470 return $token 3471 } 3472 } 3473 processingInstruction { 3474 catch {set found [expr ![string compare $node(node:nodeName) $query(-pitarget)]]} 3475 catch {set found [expr $found || ![string compare $node(node:nodeValue) $query(-pidata)]]} 3476 3477 if {$found} { 3478 return $token 3479 } 3480 } 3481 } 3482 3483 if {$found} { 3484 return $token 3485 } 3486 3487 return {} 3488} 3489 3490################################################# 3491# 3492# XPath support 3493# 3494################################################# 3495 3496# dom::tcl::XPath:CreateNode -- 3497# 3498# Given an XPath expression, create the node 3499# referred to by the expression. Nodes required 3500# as steps of the path are created if they do 3501# not exist. 3502# 3503# Arguments: 3504# node context node 3505# path location path 3506# 3507# Results: 3508# Node(s) created in the DOM tree. 3509# Returns token for deepest node in the expression. 3510 3511proc dom::tcl::XPath:CreateNode {node path} { 3512 3513 set root [::dom::node cget $node -ownerDocument] 3514 3515 set spath [::xpath::split $path] 3516 3517 if {[llength $spath] <= 1} { 3518 # / - do nothing 3519 return $root 3520 } 3521 3522 if {![llength [lindex $spath 0]]} { 3523 # Absolute location path 3524 set context $root 3525 set spath [lrange $spath 1 end] 3526 set contexttype document 3527 } else { 3528 set context $node 3529 set contexttype [::dom::node cget $node -nodeType] 3530 } 3531 3532 foreach step $spath { 3533 3534 # Sanity check on path 3535 switch $contexttype { 3536 document - 3537 documentFragment - 3538 element {} 3539 default { 3540 return -code error "node type \"$contexttype\" have no children" 3541 } 3542 } 3543 3544 switch [lindex $step 0] { 3545 3546 child { 3547 if {[llength [lindex $step 1]] > 1} { 3548 foreach {nodetype discard} [lindex $step 1] break 3549 3550 switch -- $nodetype { 3551 text { 3552 set posn [CreateNode:FindPosition [lindex $step 2]] 3553 3554 set count 0 3555 set targetNode {} 3556 foreach child [::dom::node children $context] { 3557 switch [::dom::node cget $child -nodeType] { 3558 textNode { 3559 incr count 3560 if {$count == $posn} { 3561 set targetNode $child 3562 break 3563 } 3564 } 3565 default {} 3566 } 3567 } 3568 3569 if {[string length $targetNode]} { 3570 set context $targetNode 3571 } else { 3572 # Creating sequential textNodes doesn't make sense 3573 set context [::dom::document createTextNode $context {}] 3574 } 3575 set contexttype textNode 3576 } 3577 default { 3578 return -code error "node type test \"${nodetype}()\" not supported" 3579 } 3580 } 3581 } else { 3582 # Find the child element 3583 set posn [CreateNode:FindPosition [lindex $step 2]] 3584 3585 set count 0 3586 set targetNode {} 3587 foreach child [::dom::node children $context] { 3588 switch [node cget $child -nodeType] { 3589 element { 3590 if {![string compare [lindex $step 1] [::dom::node cget $child -nodeName]]} { 3591 incr count 3592 if {$count == $posn} { 3593 set targetNode $child 3594 break 3595 } 3596 } 3597 } 3598 default {} 3599 } 3600 } 3601 3602 if {[string length $targetNode]} { 3603 set context $targetNode 3604 } else { 3605 # Didn't find it so create required elements 3606 while {$count < $posn} { 3607 set child [::dom::document createElement $context [lindex $step 1]] 3608 incr count 3609 } 3610 set context $child 3611 } 3612 set contexttype element 3613 3614 } 3615 } 3616 3617 default { 3618 return -code error "axis \"[lindex $step 0]\" is not supported" 3619 } 3620 } 3621 } 3622 3623 return $context 3624} 3625 3626# dom::tcl::CreateNode:FindPosition -- 3627 3628proc dom::tcl::CreateNode:FindPosition predicates { 3629 switch [llength $predicates] { 3630 0 { 3631 return 1 3632 } 3633 1 { 3634 # Fall-through 3635 } 3636 default { 3637 return -code error "multiple predicates not supported" 3638 } 3639 } 3640 set predicate [lindex $predicates 0] 3641 3642 switch -- [lindex [lindex $predicate 0] 0] { 3643 function { 3644 switch -- [lindex [lindex $predicate 0] 1] { 3645 position { 3646 if {[lindex $predicate 1] == "="} { 3647 if {[string compare [lindex [lindex $predicate 2] 0] "number"]} { 3648 return -code error "operand must be a number" 3649 } else { 3650 set posn [lindex [lindex $predicate 2] 1] 3651 } 3652 } else { 3653 return -code error "operator must be \"=\"" 3654 } 3655 } 3656 default { 3657 return -code error "predicate function \"[lindex [lindex $predicate 0] 1]\" not supported" 3658 } 3659 } 3660 } 3661 default { 3662 return -code error "predicate must be position() function" 3663 } 3664 } 3665 3666 return $posn 3667} 3668 3669# dom::tcl::XPath:SelectNode -- 3670# 3671# Match nodes with an XPath location path 3672# 3673# Arguments: 3674# ctxt context - Tcl list 3675# path location path 3676# 3677# Results: 3678# Returns Tcl list of matching nodes 3679 3680proc dom::tcl::XPath:SelectNode {ctxt path} { 3681 3682 if {![llength $ctxt]} { 3683 return {} 3684 } 3685 3686 set spath [xpath::split $path] 3687 3688 if {[string length [node parent [lindex $ctxt 0]]]} { 3689 array set nodearr [set [lindex $ctxt 0]] 3690 set root $nodearr(docArray)(node1) 3691 } else { 3692 set root [lindex $ctxt 0] 3693 } 3694 3695 if {[llength $spath] == 0} { 3696 return $root 3697 } 3698 if {[llength $spath] == 1 && [llength [lindex $spath 0]] == 0} { 3699 return $root 3700 } 3701 3702 if {![llength [lindex $spath 0]]} { 3703 set ctxt $root 3704 set spath [lrange $spath 1 end] 3705 } 3706 3707 return [XPath:SelectNode:Rel $ctxt $spath] 3708} 3709 3710# dom::tcl::XPath:SelectNode:Rel -- 3711# 3712# Match nodes with an XPath location path 3713# 3714# Arguments: 3715# ctxt context - Tcl list 3716# path split location path 3717# 3718# Results: 3719# Returns Tcl list of matching nodes 3720 3721proc dom::tcl::XPath:SelectNode:Rel {ctxt spath} { 3722 if {![llength $spath]} { 3723 return $ctxt 3724 } 3725 3726 set step [lindex $spath 0] 3727 set result {} 3728 switch [lindex $step 0] { 3729 3730 child { 3731 # All children are candidates 3732 set children {} 3733 foreach node [XPath:SN:GetElementTypeNodes $ctxt] { 3734 eval lappend children [node children $node] 3735 } 3736 3737 # Now apply node test to each child 3738 foreach node $children { 3739 if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} { 3740 lappend result $node 3741 } 3742 } 3743 3744 } 3745 3746 descendant-or-self { 3747 foreach node $ctxt { 3748 if {[XPath:SN:ApplyNodeTest $node [lindex $step 1]]} { 3749 lappend result $node 3750 } 3751 eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]] 3752 } 3753 } 3754 3755 descendant { 3756 foreach node $ctxt { 3757 eval lappend result [XPath:SN:DescendAndTest [node children $node] [lindex $step 1]] 3758 } 3759 } 3760 3761 attribute { 3762 if {[string compare [lindex $step 1] "*"]} { 3763 foreach node $ctxt { 3764 set attrNode [element getAttributeNode $node [lindex $step 1]] 3765 if {[llength $attrNode]} { 3766 lappend result $attrNode 3767 } 3768 } 3769 } else { 3770 # All attributes are returned 3771 foreach node $ctxt { 3772 foreach attrName [array names [node cget $node -attributes]] { 3773 set attrNode [element getAttributeNode $node $attrName] 3774 if {[llength $attrNode]} { 3775 lappend result $attrNode 3776 } 3777 } 3778 } 3779 } 3780 } 3781 3782 default { 3783 return -code error "axis \"[lindex $step 0]\" is not supported" 3784 } 3785 } 3786 3787 # Now apply predicates 3788 set result [XPath:ApplyPredicates $result [lindex $step 2]] 3789 3790 # Apply the next location step 3791 return [XPath:SelectNode:Rel $result [lrange $spath 1 end]] 3792} 3793 3794# dom::tcl::XPath:SN:GetElementTypeNodes -- 3795# 3796# Reduce nodeset to those nodes of element type 3797# 3798# Arguments: 3799# nodeset set of nodes 3800# 3801# Results: 3802# Returns nodeset in which all nodes are element type 3803 3804proc dom::tcl::XPath:SN:GetElementTypeNodes nodeset { 3805 set result {} 3806 foreach node $nodeset { 3807 switch [node cget $node -nodeType] { 3808 documentFragment - 3809 element { 3810 lappend result $node 3811 } 3812 default {} 3813 } 3814 } 3815 return $result 3816} 3817 3818# dom::tcl::XPath:SN:ApplyNodeTest -- 3819# 3820# Apply the node test to a node 3821# 3822# Arguments: 3823# node DOM node to test 3824# test node test 3825# 3826# Results: 3827# 1 if node passes, 0 otherwise 3828 3829proc dom::tcl::XPath:SN:ApplyNodeTest {node test} { 3830 if {[llength $test] > 1} { 3831 foreach {name typetest} $test break 3832 # Node type test 3833 switch -glob -- $name,[node cget $node -nodeType] { 3834 node,* { 3835 return 1 3836 } 3837 text,textNode - 3838 comment,comment - 3839 processing-instruction,processingInstruction { 3840 return 1 3841 } 3842 text,* - 3843 comment,* - 3844 processing-instruction,* { 3845 return 0 3846 } 3847 default { 3848 return -code error "illegal node type test \"[lindex $step 1]\"" 3849 } 3850 } 3851 } else { 3852 # Node name test 3853 switch -glob -- $test,[node cget $node -nodeType],[node cget $node -nodeName] \ 3854 \\*,element,* { 3855 return 1 3856 } \ 3857 \\*,* { 3858 return 0 3859 } \ 3860 *,element,$test { 3861 return 1 3862 } 3863 } 3864 3865 return 0 3866} 3867 3868# dom::tcl::XPath:SN:DescendAndTest -- 3869# 3870# Descend the element hierarchy, 3871# apply the node test as we go 3872# 3873# Arguments: 3874# nodeset nodes to be tested and descended 3875# test node test 3876# 3877# Results: 3878# Returned nodeset of nodes which pass the test 3879 3880proc dom::tcl::XPath:SN:DescendAndTest {nodeset test} { 3881 set result {} 3882 3883 foreach node $nodeset { 3884 if {[XPath:SN:ApplyNodeTest $node $test]} { 3885 lappend result $node 3886 } 3887 switch [node cget $node -nodeType] { 3888 documentFragment - 3889 element { 3890 eval lappend result [XPath:SN:DescendAndTest [node children $node] $test] 3891 } 3892 } 3893 } 3894 3895 return $result 3896} 3897 3898# dom::tcl::XPath:ApplyPredicates -- 3899# 3900# Filter a nodeset with predicates 3901# 3902# Arguments: 3903# ctxt current context nodeset 3904# preds list of predicates 3905# 3906# Results: 3907# Returns new (possibly reduced) context nodeset 3908 3909proc dom::tcl::XPath:ApplyPredicates {ctxt preds} { 3910 3911 set result {} 3912 foreach node $ctxt { 3913 set passed 1 3914 foreach predicate $preds { 3915 if {![XPath:ApplyPredicate $node $predicate]} { 3916 set passed 0 3917 break 3918 } 3919 } 3920 if {$passed} { 3921 lappend result $node 3922 } 3923 } 3924 3925 return $result 3926} 3927 3928# dom::tcl::XPath:ApplyPredicate -- 3929# 3930# Filter a node with a single predicate 3931# 3932# Arguments: 3933# node current context node 3934# pred predicate 3935# 3936# Results: 3937# Returns boolean 3938 3939proc dom::tcl::XPath:ApplyPredicate {node pred} { 3940 3941 switch -- [lindex $pred 0] { 3942 = - 3943 != - 3944 >= - 3945 <= - 3946 > - 3947 > { 3948 3949 if {[llength $pred] != 3} { 3950 return -code error "malformed expression" 3951 } 3952 3953 set operand1 [XPath:Pred:ResolveExpr $node [lindex $pred 1]] 3954 set operand2 [XPath:Pred:ResolveExpr $node [lindex $pred 2]] 3955 3956 # Convert operands to the correct type, if necessary 3957 switch -glob [lindex $operand1 0],[lindex $operand2 0] { 3958 literal,literal { 3959 return [XPath:Pred:CompareLiterals [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]] 3960 } 3961 3962 number,number - 3963 literal,number - 3964 number,literal { 3965 # Compare as numbers 3966 return [XPath:Pred:CompareNumbers [lindex $pred 0] [lindex $operand1 1] [lindex $operand2 1]] 3967 } 3968 3969 boolean,boolean { 3970 # Compare as booleans 3971 return -code error "boolean comparison not yet implemented" 3972 } 3973 3974 node,node { 3975 # Nodeset comparison 3976 return -code error "nodeset comparison not yet implemented" 3977 } 3978 3979 node,* { 3980 set value {} 3981 if {[llength [lindex $operand1 1]]} { 3982 set value [node stringValue [lindex [lindex $operand1 1] 0]] 3983 } 3984 return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand2 1]] 3985 } 3986 *,node { 3987 set value {} 3988 if {[llength [lindex $operand2 1]]} { 3989 set value [node stringValue [lindex [lindex $operand2 1] 0]] 3990 } 3991 return [XPath:Pred:CompareLiterals [lindex $pred 0] $value [lindex $operand1 1]] 3992 } 3993 3994 default { 3995 return -code error "can't compare [lindex $operand1 0] to [lindex $operand2 0]" 3996 } 3997 } 3998 } 3999 4000 function { 4001 return -code error "invalid predicate" 4002 } 4003 number - 4004 literal { 4005 return -code error "invalid predicate" 4006 } 4007 4008 path { 4009 set nodeset [XPath:SelectNode:Rel $node [lindex $pred 1]] 4010 return [expr {[llength $nodeset] > 0 ? 1 : 0}] 4011 } 4012 4013 } 4014 4015 return 1 4016} 4017 4018# dom::tcl::XPath:Pred:Compare -- 4019 4020proc dom::tcl::XPath:Pred:CompareLiterals {op operand1 operand2} { 4021 set result [string compare $operand1 $operand2] 4022 4023 # The obvious: 4024 #return [expr {$result $opMap($op) 0}] 4025 # doesn't compile 4026 4027 switch $op { 4028 = { 4029 return [expr {$result == 0}] 4030 } 4031 != { 4032 return [expr {$result != 0}] 4033 } 4034 <= { 4035 return [expr {$result <= 0}] 4036 } 4037 >= { 4038 return [expr {$result >= 0}] 4039 } 4040 < { 4041 return [expr {$result < 0}] 4042 } 4043 > { 4044 return [expr {$result > 0}] 4045 } 4046 } 4047 return -code error "internal error" 4048} 4049 4050# dom::tcl::XPath:Pred:ResolveExpr -- 4051 4052proc dom::tcl::XPath:Pred:ResolveExpr {node expr} { 4053 4054 switch [lindex $expr 0] { 4055 path { 4056 return [list node [XPath:SelectNode:Rel $node [lindex $expr 1]]] 4057 } 4058 4059 function - 4060 group { 4061 return -code error "[lindex $expr 0] not yet implemented" 4062 } 4063 literal - 4064 number - 4065 boolean { 4066 return $expr 4067 } 4068 4069 default { 4070 return -code error "internal error" 4071 } 4072 } 4073 4074 return {} 4075} 4076 4077################################################# 4078# 4079# Miscellaneous 4080# 4081################################################# 4082 4083# dom::tcl::hasmixedcontent -- 4084# 4085# Determine whether an element contains mixed content 4086# 4087# Arguments: 4088# token dom node 4089# 4090# Results: 4091# Returns 1 if element contains mixed content, 4092# 0 otherwise 4093 4094proc dom::tcl::hasmixedcontent token { 4095 array set node [set $token] 4096 4097 if {[string compare $node(node:nodeType) "element"]} { 4098 # Really undefined 4099 return 0 4100 } 4101 4102 foreach child [set $node(node:childNodes)] { 4103 catch {unset childnode} 4104 array set childnode [set $child] 4105 if {![string compare $childnode(node:nodeType) "textNode"]} { 4106 return 1 4107 } 4108 } 4109 4110 return 0 4111} 4112 4113# dom::tcl::prefix2namespaceURI -- 4114# 4115# Given an XML Namespace prefix, find the corresponding Namespace URI 4116# 4117# Arguments: 4118# node DOM Node 4119# prefix XML Namespace prefix 4120# 4121# Results: 4122# Returns URI 4123 4124proc dom::tcl::prefix2namespaceURI {node prefix} { 4125 4126 # Search this node and its ancestors for the appropriate 4127 # XML Namespace declaration 4128 4129 set parent [dom::node parent $node] 4130 set nsuri [dom::element getAttributeNS $node $::dom::xmlnsURI $prefix] 4131 if {[string length $parent] && ![string length $nsuri]} { 4132 set nsuri [dom::element getAttributeNS $parent $::dom::xmlnsURI $prefix] 4133 set parent [dom::node parent $parent] 4134 } 4135 4136 if {[string length $nsuri]} { 4137 return $nsuri 4138 } else { 4139 return -code error "unable to find namespace URI for prefix \"$prefix\"" 4140 } 4141 4142} 4143 4144# dom::tcl::namespaceURI2prefix -- 4145# 4146# Given an XML Namespace URI, find the corresponding prefix 4147# 4148# Arguments: 4149# node DOM Node 4150# nsuri XML Namespace URI 4151# 4152# Results: 4153# Returns prefix 4154 4155proc dom::tcl::namespaceURI2prefix {node nsuri} { 4156 4157 # Search this node and its ancestors for the desired 4158 # XML Namespace declaration 4159 4160 set found 0 4161 set prefix {} 4162 set parent [dom::node parent $node] 4163 while {[string length $parent]} { 4164 catch {unset nodeinfo} 4165 array set nodeinfo [set $node] 4166 catch {unset attrs} 4167 array set attrs [array get $nodeinfo(element:attributeList)] 4168 foreach {nsdecl declNSuri} [array get attrs ${::dom::xmlnsURI}^*] { 4169 if {![string compare $declNSuri $nsuri]} { 4170 set found 1 4171 set prefix [lindex [split $nsdecl ^] 1] 4172 break 4173 } 4174 } 4175 if {$found} { 4176 break 4177 } 4178 set node $parent 4179 set parent [dom::node parent $node] 4180 } 4181 4182 if {$found} { 4183 return $prefix 4184 } else { 4185 return -code error "unable to find prefix for namespace URI \"$nsuri\"" 4186 } 4187 4188} 4189 4190# dom::tcl::GetField -- 4191# 4192# Return a value, or empty string if not defined 4193# 4194# Arguments: 4195# var name of variable to return 4196# 4197# Results: 4198# Returns the value, or empty string if variable is not defined. 4199 4200proc dom::tcl::GetField var { 4201 upvar $var v 4202 if {[info exists v]} { 4203 return $v 4204 } else { 4205 return {} 4206 } 4207} 4208 4209# dom::tcl::Min -- 4210# 4211# Return the minimum of two numeric values 4212# 4213# Arguments: 4214# a a value 4215# b another value 4216# 4217# Results: 4218# Returns the value which is lower than the other. 4219 4220proc dom::tcl::Min {a b} { 4221 return [expr {$a < $b ? $a : $b}] 4222} 4223 4224# dom::tcl::Max -- 4225# 4226# Return the maximum of two numeric values 4227# 4228# Arguments: 4229# a a value 4230# b another value 4231# 4232# Results: 4233# Returns the value which is greater than the other. 4234 4235proc dom::tcl::Max {a b} { 4236 return [expr {$a > $b ? $a : $b}] 4237} 4238 4239# dom::tcl::Boolean -- 4240# 4241# Return a boolean value 4242# 4243# Arguments: 4244# b value 4245# 4246# Results: 4247# Returns 0 or 1 4248 4249proc dom::tcl::Boolean b { 4250 regsub -nocase {^(true|yes|1|on)$} $b 1 b 4251 regsub -nocase {^(false|no|0|off)$} $b 0 b 4252 return $b 4253} 4254 4255