1# domtext.tcl -- 2# 3# Megawidget to display a DOM document in a Text widget. 4# 5# This widget both generates and reacts to DOM Events. 6# 7# Copyright (c) 1999-2003 Zveno Pty Ltd 8# http://www.zveno.com/ 9# 10# Zveno makes this software and all associated data and documentation 11# ('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: domtext.tcl,v 1.4 2003/01/17 23:43:29 balls Exp $ 21 22package provide domtext 2.5 23 24# We need BWidgets 25 26package require BWidget 1.4 27 28# We need the DOM 29# V2.0 gives us Level 2 Events 30 31package require dom 2.5 32 33# Configuration options: 34# 35# -elementbgcolorlist {colour1 colour2 ...} 36# Specifies a list of colours to cycle through for 37# backgrounds of sucessive element content. 38# 39# -showtag text|tab|<empty> 40# "text" denotes that start and end tags are shown 41# as their XML text. "tab" denotes that start and 42# end tags are shown as an image. Empty value 43# denotes that start and end tags are not shown. 44 45namespace eval domtext { 46 Widget::tkinclude domtext text .text \ 47 remove {-command -state} 48 49 Widget::declare domtext { 50 {-highlightcolor String "#d9ffff" 0} 51 {-rootnode String "" 0} 52 {-state String "normal" 0} 53 {-tagcolor String "#18605a" 0} 54 {-commentcolor String "#660f91" 0} 55 {-entityrefcolor String "#0080c0" 0} 56 {-elementbgcolorlist String "" 0} 57 {-showxmldecl Boolean 1 0} 58 {-showdoctypedecl Boolean 1 0} 59 {-showtag String "text" 0} 60 } 61 62 proc ::domtext { path args } { return [eval domtext::create $path $args] } 63 proc use {} {} 64 65 # Define bindings for domtext widget class 66 67 # Certain mouse event bindings for the Text widget class must be overridden 68 69 bind domtext <Button-1> [namespace code [list _tkevent_override %W %x %y]] 70 bind domtext <Double-Button-1> [namespace code [list _tkevent_override %W %x %y]] 71 72 # All of these bindings for the Text widget class cause characters 73 # to be inserted or deleted. These must be caught and prevented if the 74 # characters are part of markup, otherwise the node value must be 75 # updated 76 # TODO: update with all bindings for Text widget 77 78 foreach spec { 79 <Meta-Key-d> <Meta-Key-Delete> <Meta-Key-BackSpace> 80 <Control-Key-h> <Control-Key-t> <Control-Key-k> <Control-Key-d> 81 <Control-Key-i> <Key> 82 <<Cut>> <<Paste>> <<PasteSelection>> <<Clear>> 83 <Key-BackSpace> <Key-Delete> <Key-Return> 84 } { 85 bind domtext $spec [list domtext::_tkevent_filter_$spec %W %A] 86 } 87 foreach spec { 88 <Key-Up> <Key-Down> <Key-Left> <Key-Right> 89 } { 90 bind domtext $spec [list domtext::_key_select %W $spec] 91 } 92 foreach spec { 93 <Meta-Key> <Control-Key> 94 } { 95 bind domtext $spec {# Do nothing - allow the normal Text class binding to take effect} 96 } 97 98 variable eventTypeMap 99 array set eventTypeMap { 100 ButtonPress mousedown 101 ButtonRelease mouseup 102 Enter mouseover 103 Leave mouseout 104 Motion mousemove 105 FocusIn DOMFocusIn 106 FocusOut DOMFocusOut 107 } 108} 109 110# domtext::create -- 111# 112# Widget class creation command 113# 114# Arguments: 115# path widget path 116# args configuration options 117# 118# Results: 119# Widget created, returns path 120 121proc domtext::create {path args} { 122 upvar #0 [namespace current]::$path data 123 array set maps [list Text {} :text {} .text {}] 124 125 eval frame $path $maps(:text) -bd 0 -relief flat -takefocus 0 \ 126 -class domtext -highlightthickness 0 127 128 Widget::initFromODB domtext $path $maps(Text) 129 130 # Setup event bindings for generating DOM events 131 bindtags $path [list $path Bwdomtext [winfo toplevel $path] all] 132 133 set text [eval text $path.text $maps(.text) \ 134 -state [Widget::getMegawidgetOption $path -state] -wrap none \ 135 -takefocus 1] 136 $text tag configure starttab -elide 1 137 $text tag configure endtab -elide 1 138 $text tag configure xmldecl -elide 1 139 $text tag configure doctypedecl -elide 1 140 141 bindtags $path [list $path domtext [winfo toplevel $path] all] 142 143 grid $text -sticky news 144 grid rowconfigure $path 0 -weight 1 145 grid columnconfigure $path 0 -weight 1 146 147 # Certain class bindings must be overridden 148 bindtags $text [list $path domtext [winfo class $text] [winfo toplevel $path] all] 149 150 rename $path ::$path:cmd 151 proc ::$path { cmd args } "return \[eval domtext::\$cmd $path \$args\]" 152 153 set root [Widget::getMegawidgetOption $path -rootnode] 154 if {[string length $root]} { 155 _refresh $path $root 156 } 157 158 set data(insert) end 159 set data(nextElemBgColor) 0 160 161 configure $path \ 162 -showtag [Widget::getMegawidgetOption $path -showtag] \ 163 -showxmldecl [Widget::getMegawidgetOption $path -showxmldecl] \ 164 -showdoctypedecl [Widget::getMegawidgetOption $path -showdoctypedecl] 165 166 return $path 167} 168 169# domtext::cget -- 170# 171# Implements the cget method 172# 173# Arguments: 174# path widget path 175# option configuration option 176# 177# Results: 178# Returns value of option 179 180proc domtext::cget {path option} { 181 return [Widget::getoption $path $option] 182} 183 184# domtext::configure -- 185# 186# Implements the configure method 187# 188# Arguments: 189# path widget path 190# args configuration options 191# 192# Results: 193# Sets values of options 194 195proc domtext::configure {path args} { 196 upvar #0 [namespace current]::$path data 197 198 set res [Widget::configure $path $args] 199 200 set rn [Widget::hasChanged $path -rootnode root] 201 if {$rn} { 202 203 $path.text delete 1.0 end 204 # Delete all marks and tags 205 # This doesn't delete the standard marks and tags 206 eval $path.text tag delete [$path.text tag names] 207 eval $path.text mark unset [$path.text mark names] 208 # Remove event listeners from previous DOM tree 209 210 set data(insert) 1.0 211 212 if {[string length $root]} { 213 set docel [dom::document cget $root -documentElement] 214 215 if {[string length $docel]} { 216 # Listen for UI events 217 dom::node addEventListener $root DOMActivate [namespace code [list _node_selected $path]] -usecapture 1 218 219 # Listen for mutation events 220 dom::node addEventListener $root DOMNodeInserted [namespace code [list _node_inserted $path]] -usecapture 1 221 dom::node addEventListener $root DOMNodeRemoved [namespace code [list _node_removed $path]] -usecapture 1 222 dom::node addEventListener $root DOMCharacterDataModified [namespace code [list _node_pcdata_modified $path]] -usecapture 1 223 dom::node addEventListener $root DOMAttrModified [namespace code [list _node_attr_modified $path]] -usecapture 1 224 dom::node addEventListener $root DOMAttrRemoved [namespace code [list _node_attr_removed $path]] -usecapture 1 225 226 _refresh $path $root 227 } 228 } 229 } 230 231 set tc [Widget::hasChanged $path -tagcolor tagcolor] 232 set hc [Widget::hasChanged $path -highlightcolor hlcolor] 233 set cc [Widget::hasChanged $path -commentcolor commcolor] 234 set ec [Widget::hasChanged $path -entityrefcolor ercolor] 235 set ebg [Widget::hasChanged $path -elementbgcolorlist ebgcolor] 236 if {($rn && [string length $root]) || $tc} { 237 $path.text tag configure tags -foreground $tagcolor 238 } 239 if {($rn && [string length $root]) || $cc} { 240 $path.text tag configure comment -foreground $commcolor 241 } 242 if {($rn && [string length $root]) || $ec} { 243 $path.text tag configure entityreference -foreground $ercolor 244 } 245 if {($rn && [string length $root]) || $hc} { 246 $path.text tag configure highlight -background $hlcolor 247 } 248 if {($rn && [string length $root]) || $ebg} { 249 set data(nextElemBgColor) 0 250 _elementbg_setall $path $root 251 } 252 253 if {[Widget::hasChanged $path -showtag showtag]} { 254 switch -- $showtag { 255 text { 256 $path.text tag configure starttab -elide 1 257 $path.text tag configure endtab -elide 1 258 $path.text tag configure tags -elide 0 259 } 260 tab { 261 $path.text tag configure tags -elide 1 262 $path.text tag configure starttab -elide 0 263 $path.text tag configure endtab -elide 0 264 } 265 {} { 266 $path.text tag configure tags -elide 1 267 $path.text tag configure starttab -elide 1 268 $path.text tag configure endtab -elide 1 269 } 270 default { 271 return -code error "invalid value \"$showtag\"" 272 } 273 } 274 } 275 276 if {[Widget::hasChanged $path -showxmldecl showxmldecl]} { 277 $path.text tag configure xmldecl -elide [expr !$showxmldecl] 278 } 279 if {[Widget::hasChanged $path -showdoctypedecl showdoctypedecl]} { 280 $path.text tag configure doctypedecl -elide [expr !$showdoctypedecl] 281 } 282 return $res 283} 284 285# domtext::xview -- 286# 287# Implements xview method 288# 289# Arguments: 290# path widget path 291# args additional arguments 292# 293# Results: 294# Depends on Text's xview method 295 296proc domtext::xview {path args} { 297 eval $path.text xview $args 298} 299 300# domtext::yview -- 301# 302# Implements yview method 303# 304# Arguments: 305# path widget path 306# args additional arguments 307# 308# Results: 309# Depends on Text's yview method 310 311proc domtext::yview {path args} { 312 eval $path.text yview $args 313} 314 315# domtext::_refresh -- 316# 317# Inserts serialized nodes into the Text widget, 318# while at the same time marking up the text to support 319# DOM-level editing functions. 320# 321# This function is similar to the DOM package's 322# serialization feature. The code started by being copied 323# from there. 324# 325# Assumes that the widget is in normal state 326# 327# Arguments: 328# path widget path 329# node DOM node 330# 331# Results: 332# Text widget populated with serialized text. 333 334proc domtext::_refresh {path node} { 335 upvar #0 [namespace current]::$path data 336 337 $path.text mark set $node $data(insert) 338 $path.text mark gravity $node left 339 340 set end $data(insert) 341 342 # For all nodes we bind Tk events to be able to generate DOM events 343 $path.text tag bind $node <1> [namespace code [list _tkevent_select $path $node %x %y]] 344 $path.text tag bind $node <Double-1> [namespace code [list _tkevent_open $path $node]] 345 346 $path.text tag configure $node -background [_elementbg_cycle $path] 347 348 switch [::dom::node cget $node -nodeType] { 349 document - 350 documentFragment { 351 352 # Display the XML declaration 353 if {0} { 354 # OUCH! Need an interface in the DOM package for this data 355 array set nodeInfo [set $node] 356 # XML Declaration attributes have a defined order, so can't use array directly 357 array set xmldecl $nodeInfo(document:xmldecl) 358 set xmldecllist [list version $xmldecl(version)] 359 catch {lappend xmldecllist standalone $xmldecl(standalone)} 360 catch {lappend xmldecllist encoding $xmldecl(encoding)} 361 $path.text insert $data(insert) "<?xml[dom::Serialize:attributeList $xmldecllist]?>\n" [list $node xmldecl] 362 set data(insert) [lindex [$path.text tag ranges $node] end] 363 } 364 foreach childToken [::dom::node children $node] { 365 set end [_refresh $path $childToken] 366 set data(insert) $end 367 } 368 369 $path.text tag add $node $node $end 370 $path.text tag configure xmldecl -elide [expr ![Widget::cget $path -showxmldecl]] 371 $path.text tag raise xmldecl 372 } 373 374 element { 375 376 # Serialize the start tag 377 $path.text insert $data(insert) <[::dom::node cget $node -nodeName] [list tags tag:start:$node] [_serialize:attributeList [array get [::dom::node cget $node -attributes]]] [list tags attrs:$node] > [list tags tag:start:$node] 378 379 # Add the start tab icon 380 $path.text image create $data(insert) -image ::domtext::starttab -align center -name tab:start:$node 381 foreach t [list starttab tags tag:start:$node] { 382 $path.text tag add $t tab:start:$node 383 } 384 385 set data(insert) [lindex [$path.text tag ranges tag:start:$node] end] 386 387 # Serialize the content 388 $path.text mark set content:$node $data(insert) 389 $path.text mark gravity content:$node left 390 foreach childToken [::dom::node children $node] { 391 set end [_refresh $path $childToken] 392 set data(insert) $end 393 } 394 $path.text tag add content:$node content:$node $end 395 396 # Serialize the end tag 397 $path.text insert $data(insert) </[::dom::node cget $node -nodeName]> [list tags tag:end:$node] 398 set end [lindex [$path.text tag ranges tag:end:$node] end] 399 # Add the end tab icon 400 $path.text image create $end -image ::domtext::endtab -align center -name tab:end:$node 401 foreach t [list endtab tags tag:end:$node] { 402 $path.text tag add $t tab:end:$node 403 } 404 set end [lindex [$path.text tag ranges tag:end:$node] end] 405 406 set data(insert) $end 407 $path.text tag add $node $node $end 408 409 $path.text tag raise starttab 410 $path.text tag raise endtab 411 $path.text tag configure starttab -elide [expr {[Widget::cget $path -showtag] != "tab"}] 412 $path.text tag configure endtab -elide [expr {[Widget::cget $path -showtag] != "tab"}] 413 414 } 415 416 textNode { 417 set text [_encode [dom::node cget $node -nodeValue]] 418 if {[string length $text]} { 419 $path.text insert $data(insert) $text $node 420 set end [lindex [$path.text tag ranges $node] 1] 421 set data(insert) $end 422 } else { 423 set end $data(insert) 424 } 425 } 426 427 docType { 428 array set nodeInfo [set $node] 429 $path.text insert $data(insert) "<!DOCTYPE $nodeInfo(doctype:name)" [list $node doctypedecl] 430 set data(insert) [lindex [$path.text tag ranges $node] end] 431 432 if {[string length $nodeInfo(doctype:internaldtd)]} { 433 $path.text insert $data(insert) " \[$nodeInfo(doctype:internaldtd)\]" [list $node doctypedecl] 434 set data(insert) [lindex [$path.text tag ranges $node] end] 435 } 436 437 $path.text insert $data(insert) >\n [list $node doctypedecl] 438 set end [lindex [$path.text tag ranges $node] end] 439 set data(insert) $end 440 $path.text tag configure doctypedecl -elide [expr ![Widget::cget $path -showdoctypedecl]] 441 $path.text tag raise doctypedecl 442 } 443 444 comment { 445 set text [::dom::node cget $node -nodeValue] 446 $path.text insert $data(insert) <!-- [list comment markup $node] $text [list comment $node] --> [list comment markup $node] 447 set end [lindex [$path.text tag ranges $node] 1] 448 set data(insert) $end 449 } 450 451 entityReference { 452 set text [::dom::node cget $node -nodeName] 453 $path.text insert $data(insert) & [list entityreference markup $node] $text [list entityreference $node] \; [list entityreference markup $node] 454 set end [lindex [$path.text tag ranges $node] 1] 455 set data(insert) $end 456 } 457 458 processingInstruction { 459 set text [::dom::node cget $node -nodeValue] 460 if {[string length $text]} { 461 set text " $text" 462 } 463 $path.text insert $data(insert) "<?[::dom::node cget $node -nodeName]$text?>" $node 464 set end [lindex [$path.text tag ranges $node] 1] 465 set data(insert) $end 466 } 467 468 default { 469 # Ignore it 470 } 471 472 } 473 474 return $end 475} 476 477# domtext::_serialize:attributeList -- 478# 479# Produce textual representation of an attribute list. 480# 481# NB. This is copied from TclDOM's domimpl.tcl, 482# but with the namespace handling removed. 483# 484# Arguments: 485# atlist name/value list of attributes 486# 487# Results: 488# Returns string 489 490proc domtext::_serialize:attributeList atlist { 491 492 set result {} 493 foreach {name value} $atlist { 494 495 append result { } $name = 496 497 # Handle special characters 498 regsub -all & $value {\&} value 499 regsub -all < $value {\<} value 500 501 if {![string match *\"* $value]} { 502 append result \"$value\" 503 } elseif {![string match *'* $value]} { 504 append result '$value' 505 } else { 506 regsub -all \" $value {\"} value 507 append result \"$value\" 508 } 509 510 } 511 512 return $result 513} 514 515# domtext::_encode -- 516# 517# Protect XML special characters 518# 519# NB. This is copied from TclDOM's domimpl.tcl. 520# 521# Arguments: 522# value text 523# 524# Results: 525# Returns string 526 527proc domtext::_encode value { 528 array set Entity { 529 $ $ 530 < < 531 > > 532 & & 533 \" " 534 ' ' 535 } 536 537 regsub -all {([$<>&"'])} $value {$Entity(\1)} value 538 539 return [subst -nocommand -nobackslash $value] 540} 541 542# domtext::_elementbg_setall -- 543# 544# Recurse node hierarchy setting element background color property 545# 546# Arguments: 547# path widget path 548# node DOM node 549# 550# Results: 551# Text widget tag configured 552 553proc domtext::_elementbg_setall {path node} { 554 555 $path.text tag configure $node -background [_elementbg_cycle $path] 556 557 switch [dom::node cget $node -nodeType] { 558 document - 559 documentFragment - 560 element { 561 foreach child [dom::node children $node] { 562 _elementbg_setall $path $child 563 } 564 } 565 default { 566 # No more to do here 567 } 568 } 569 570 return {} 571} 572proc domtext::_elementbg_cycle path { 573 upvar #0 [namespace current]::$path data 574 575 set list [Widget::cget $path -elementbgcolorlist] 576 set colour [lindex $list $data(nextElemBgColor)] 577 578 set data(nextElemBgColor) [expr [incr data(nextElemBgColor)] % [llength $$list]] 579 580 return $colour 581} 582 583# domtext::_node_inserted -- 584# 585# React to addition of a node 586# 587# Arguments: 588# path widget path 589# evid DOM event node 590# 591# Results: 592# Display updated to reflect change to DOM structure 593 594proc domtext::_node_inserted {path evid} { 595 upvar #0 [namespace current]::$path data 596 597 set node [dom::event cget $evid -target] 598 599 # Remove parent's content and then render new content 600 set parent [dom::node parent $node] 601 set tags [$path.text tag ranges $parent] 602 set start [lindex $tags 0] 603 set end [lindex $tags end] 604 if {[string length $start]} { 605 $path.text delete $start $end 606 } else { 607 set start end 608 } 609 610 set data(insert) $start 611 set end [_refresh $path $parent] 612 613 # Restore grandparent element tags 614 set parent [::dom::node parent $parent] 615 while {[string length $parent]} { 616 set ranges [$path.text tag ranges $parent] 617 catch {eval [list $path.text] tag remove [list $parent] $ranges} 618 catch {$path.text tag add $parent [lindex $ranges 0] [lindex $ranges end]} 619 # Also do content tag for elements 620 if {![string compare [::dom::node cget $parent -nodeType] "element"]} { 621 set ranges [$path.text tag ranges content:$parent] 622 catch {eval [list $path.text] tag remove [list $parent] $ranges} 623 catch {$path.text tag add content:$parent [lindex $ranges 0] [lindex $ranges end]} 624 } 625 626 set parent [::dom::node parent $parent] 627 } 628 629 return {} 630} 631 632# domtext::_node_removed -- 633# 634# React to removal of a node. 635# This is almost identical to node insertion, 636# except that we must get the parent from the event. 637# 638# Arguments: 639# path widget path 640# evid DOM event node 641# 642# Results: 643# Display updated to reflect change to DOM structure 644 645proc domtext::_node_removed {path evid} { 646 upvar #0 [namespace current]::selected$path selected 647 648 set node [dom::event cget $evid -target] 649 650 if {[info exists selected] && ![string compare $node $selected]} { 651 unset selected 652 } 653 654 # Remove parent's content and then render new content 655 set parent [dom::event cget $evid -relatedNode] 656 set tags [$path.text tag ranges $parent] 657 set start [lindex $tags 0] 658 set end [lindex $tags end] 659 if {[string length $start]} { 660 $path.text delete $start $end 661 } else { 662 set start end 663 } 664 665 set data(insert) $start 666 set end [_refresh $path $parent] 667 668 # Restore grandparent element tags 669 set parent [::dom::node parent $parent] 670 while {[string length $parent]} { 671 set ranges [$path.text tag ranges $parent] 672 catch {eval [list $path.text] tag remove [list $parent] $ranges} 673 catch {$path.text tag add $parent [lindex $ranges 0] [lindex $ranges end]} 674 # Also do content tag for elements 675 if {![string compare [::dom::node cget $parent -nodeType] "element"]} { 676 set ranges [$path.text tag ranges content:$parent] 677 catch {eval [list $path.text] tag remove [list $parent] $ranges} 678 catch {$path.text tag add content:$parent [lindex $ranges 0] [lindex $ranges end]} 679 } 680 681 set parent [::dom::node parent $parent] 682 } 683 684 return {} 685} 686 687# domtext::_node_attr_modified -- 688# 689# React to a change in the attribute list for a node 690# 691# Arguments: 692# path widget path 693# evid DOM event node 694# 695# Results: 696# Display updated to reflect change to DOM structure 697 698proc domtext::_node_attr_modified {path evid} { 699 700 set node [dom::event cget $evid -target] 701 702 set tags [$path.text tag ranges attrs:$node] 703 if {[llength $tags]} { 704 705 # Remove previously defined attributes 706 707 foreach {start end} $tags break 708 set existingTags [$path.text tag names $start] 709 $path.text delete $start $end 710 $path.text tag delete attrs:$node 711 712 } else { 713 set tagStartEnd [lindex [$path.text tag ranges tag:start:$node] end] 714 set start [$path.text index "$tagStartEnd - 1 char"] 715 set existingTags [$path.text tag names $start] 716 } 717 718 # Replace with current attributes 719 720 lappend existingTags attrs:$node 721 $path.text insert $start [::dom::Serialize:attributeList [array get [::dom::node cget $node -attributes]]] $existingTags 722 723 return {} 724} 725 726# domtext::_node_attr_removed -- 727# 728# React to a change in the attribute list for a node 729# 730# Arguments: 731# path widget path 732# evid DOM event node 733# 734# Results: 735# Display updated to reflect change to DOM structure 736 737proc domtext::_node_attr_removed {path evid} { 738 _node_attr_modified $path $evid 739} 740 741# domtext::_node_pcdata_modified -- 742# 743# React to a change in character data 744# 745# Arguments: 746# path widget path 747# evid DOM event node 748# 749# Results: 750# Display updated to reflect change to DOM structure 751 752proc domtext::_node_pcdata_modified {path evid} { 753 754 set node [dom::event cget $evid -target] 755 756 if {[string compare [dom::node cget $node -nodeType] "textNode"]} { 757 return -code error "node is not a text node" 758 } 759 760 # Remember where the insertion point is 761 set insert [$path.text index insert] 762 763 # Remove previous text 764 set ranges [$path.text tag ranges $node] 765 set tags [$path.text tag names [lindex $ranges 0]] 766 eval [list $path.text] delete $ranges 767 768 # Replace with new text 769 $path.text insert [lindex $ranges 0] [dom::event cget $evid -newValue] $tags 770 771 # Restore insertion point 772 $path.text mark set insert $insert 773 774 return {} 775} 776 777# domtext::_node_selected -- 778# 779# A node has been selected. 780# 781# Arguments: 782# path widget path 783# evid DOM event node 784# 785# Results: 786# Node's text is selected 787 788proc domtext::_node_selected {path evid} { 789 upvar #0 [namespace current]::selected$path selected 790 791 set node [dom::event cget $evid -target] 792 set selected $node 793 794 catch {eval [list $path.text] tag remove sel [$path.text tag ranges sel]} 795 796 set ranges [$path.text tag ranges $node] 797 if {[llength $ranges]} { 798 eval [list $path.text] tag add sel $ranges 799 } 800 801 $path.text mark set insert [lindex $ranges end] 802 803 return {} 804} 805 806# domtext::_tkevent_override -- 807# 808# Certain Text widget class bindings must be prevented from firing 809# 810# Arguments: 811# path widget path 812# x x coord 813# y y coord 814# 815# Results: 816# Return break error code 817 818proc domtext::_tkevent_override {w x y} { 819 return -code break 820} 821 822# domtext::_tkevent_select -- 823# 824# Single click. We only want the highest priority tag to fire. 825# 826# Arguments: 827# path widget path 828# node DOM node 829# x 830# y Coordinates 831# 832# Results: 833# DOM event posted 834 835proc domtext::_tkevent_select {path node x y} { 836 variable tkeventid 837 838 catch {after cancel $tkeventid} 839 set tkeventid [after idle " 840 dom::event postUIEvent [list $node] DOMActivate -detail 1 841 dom::event postMouseEvent [list $node] click -detail 1 842 [namespace current]::_tkevent_select_setinsert [list $path] [list $node] [::tk::TextClosestGap $path.text $x $y] 843"] 844 return {} 845} 846 847# Helper routine for above proc 848 849proc domtext::_tkevent_select_setinsert {path node idx} { 850 switch [::dom::node cget $node -nodeType] { 851 textNode { 852 # No need to change where the insertion point is going 853 } 854 element { 855 # Set the insertion point to the end of the first 856 # child textNode, or if none to immediately following 857 # the start tag. 858 set fc [::dom::node cget $node -firstChild] 859 if {[string length $fc] && [::dom::node cget $fc -nodeType] == "textNode"} { 860 set idx [lindex [$path.text tag ranges $fc] end] 861 } else { 862 set idx [lindex [$path.text tag ranges tag:start:$node] end] 863 } 864 } 865 default { 866 # Set the insertion point following the node 867 set idx [lindex [$path.text tag ranges $node] end] 868 } 869 } 870 871 $path.text mark set insert $idx 872 $path.text mark set anchor insert 873 focus $path.text 874 875 return {} 876} 877 878# domtext::_tkevent_open -- 879# 880# Double click 881# 882# Arguments: 883# path widget path 884# node DOM node 885# 886# Results: 887# DOM event posted 888 889proc domtext::_tkevent_open {path node} { 890 variable tkeventid 891 892 catch {after cancel $tkeventid} 893 set tkeventid [after idle " 894 dom::event postUIEvent [list $node] DOMActivate -detail 2 895 dom::event postMouseEvent [list $node] click -detail 2 896"] 897 return {} 898} 899 900# domtext::_key_select -- 901# 902# Select a node in which a key event has occurred. 903# 904# Arguments: 905# path widget path 906# spec the event specifier 907# 908# Results: 909# Appropriate node is selected. Returns node id. 910 911proc domtext::_key_select {path spec} { 912 # Once the Text widget gets the focus, it receives the event. 913 # We compensate for this here 914 if {[winfo class $path] == "Text"} { 915 set path [winfo parent $path] 916 } 917 upvar #0 [namespace current]::selected$path selected 918 919 set root [Widget::cget $path -rootnode] 920 921 # If selected node is a textNode move around the text itself 922 # Otherwise markup has been selected. 923 # Move around the nodes 924 925 switch -glob [dom::node cget $selected -nodeType],$spec { 926 textNode,<Key-Up> { 927 set ranges [$path.text tag ranges $selected] 928 foreach {line char} [split [lindex $ranges 0] .] break 929 set index [$path.text index insert] 930 foreach {iline ichar} [split [lindex $index 0] .] break 931 if {$line == $iline} { 932 set new [dom::node parent $selected] 933 } else { 934 ::tk::TextSetCursor $path.text [::tk::TextUpDownLine $path.text -1] 935 # The insertion point may now be in another node 936 set newnode [_insert_to_node $path] 937 if {[string compare $newnode $selected]} { 938 dom::event postUIEvent $newnode DOMActivate -detail 1 939 } 940 return -code break 941 } 942 } 943 textNode,<Key-Down> { 944 set ranges [$path.text tag ranges $selected] 945 foreach {line char} [split [lindex $ranges end] .] break 946 set index [$path.text index insert] 947 foreach {iline ichar} [split [lindex $index 0] .] break 948 if {$line == $iline} { 949 bell 950 return {} 951 } else { 952 ::tk::TextSetCursor $path.text [::tk::TextUpDownLine $path.text 1] 953 # The insertion point may now be in another node 954 set newnode [_insert_to_node $path] 955 if {[string compare $newnode $selected]} { 956 dom::event postUIEvent $newnode DOMActivate -detail 1 957 } 958 return -code break 959 } 960 } 961 textNode,<Key-Left> { 962 set ranges [$path.text tag ranges $selected] 963 set index [$path.text index insert] 964 if {[$path.text compare $index == [lindex $ranges 0]]} { 965 set new [dom::node cget $selected -previousSibling] 966 if {![string length $new]} { 967 set new [dom::node parent $selected] 968 } 969 } else { 970 ::tk::TextSetCursor $path.text insert-1c 971 return -code break 972 } 973 } 974 textNode,<Key-Right> { 975 set ranges [$path.text tag ranges $selected] 976 set index [$path.text index insert] 977 if {[$path.text compare $index == [lindex $ranges end]]} { 978 set new [dom::node cget $selected -nextSibling] 979 if {![string length $new]} { 980 set new [dom::node parent $selected] 981 } 982 } else { 983 ::tk::TextSetCursor $path.text insert+1c 984 return -code break 985 } 986 } 987 988 *,<Key-Up> { 989 set new [dom::node parent $selected] 990 } 991 *,<Key-Down> { 992 set new [dom::node cget $selected -firstChild] 993 if {![string length $new]} { 994 bell 995 return {} 996 } 997 } 998 *,<Key-Left> { 999 if {[dom::node parent $selected] == $root} { 1000 bell 1001 return {} 1002 } 1003 set new [dom::node cget $selected -previousSibling] 1004 if {![string length $new]} { 1005 set new [dom::node parent $selected] 1006 } 1007 } 1008 *,<Key-Right> { 1009 set new [dom::node cget $selected -nextSibling] 1010 if {![string length $new]} { 1011 set new [dom::node parent $selected] 1012 } 1013 } 1014 } 1015 if {![string length $new]} { 1016 bell 1017 } 1018 1019 dom::event postUIEvent $new DOMActivate -detail 1 1020 1021 return -code break 1022} 1023 1024# domtext::_tkevent_filter_* -- 1025# 1026# React to editing events to keep the DOM structure 1027# synchronised 1028# 1029# Arguments: 1030# path widget path 1031# detail key pressed 1032# 1033# Results: 1034# Either event is blocked or passed through to the Text class binding 1035# DOM events may be generated if text is inserted or deleted 1036 1037proc domtext::_tkevent_filter_<Key> {path detail} { 1038 # Once the Text widget gets the focus, it receives the event. 1039 # We compensate for this here 1040 set code ok 1041 if {[winfo class $path] == "Text"} { 1042 set path [winfo parent $path] 1043 set code break 1044 } 1045 upvar #0 [namespace current]::selected$path selected 1046 1047 set index [$path.text index insert] 1048 1049 $path.text tag remove sel 0.0 end 1050 1051 # Take action depending upon which node type the event has occurred. 1052 # Possibilities are: 1053 # text node insert the text, update node 1054 # element If a text node exists as first child, 1055 # redirect event to it and make it active. 1056 # Otherwise create a text node 1057 # Document Type Declaration ignore 1058 # XML Declaration ignore 1059 1060 switch [dom::node cget $selected -nodeType] { 1061 element { 1062 set child [dom::node cget $selected -firstChild] 1063 if {[string length $child]} { 1064 if {[dom::node cget $child -nodeType] == "textNode"} { 1065 dom::event postUIEvent $child DOMActivate -detail 1 1066 dom::node configure $child -nodeValue [dom::node cget $child -nodeValue]$detail 1067 ::tk::TextSetCursor $path.text insert+1c 1068 focus $path.text 1069 return -code $code {} 1070 } else { 1071 bell 1072 return -code $code {} 1073 } 1074 } else { 1075 set child [dom::document createTextNode $selected $detail] 1076 dom::event postUIEvent $child DOMActivate -detail 1 1077 # When we return the new text node will have been 1078 # inserted into the Text widget 1079 set end [lindex [$path.text tag ranges $child] 1] 1080 $path.text mark set insert $end 1081 $path.text tag remove sel 0.0 end 1082 focus $path.text 1083 return -code $code {} 1084 } 1085 } 1086 textNode { 1087 1088 # We need to know where in the character data to insert the 1089 # character. This is hard, so instead allow the Text widget 1090 # to do the insertion then take all of the text and 1091 # set that as the node's value 1092 1093 $path.text insert insert $detail $selected 1094 $path.text see insert 1095 focus $path.text 1096 set ranges [$path.text tag ranges $selected] 1097 set newvalue [$path.text get [lindex $ranges 0] [lindex $ranges end]] 1098 dom::node configure $selected -nodeValue $newvalue 1099 return -code $code {} 1100 1101 } 1102 default { 1103 bell 1104 return -code $code {} 1105 } 1106 } 1107 1108 return -code $code {} 1109} 1110 1111proc domtext::_tkevent_filter_<Key-Return> {path detail} { 1112 set code [catch {_tkevent_filter_<Key> $path \n} msg] 1113 return -code $code $msg 1114} 1115proc domtext::_tkevent_filter_<Control-Key-i> {path detail} { 1116 set code [catch {_tkevent_filter_<Key> $path \t} msg] 1117 return -code $code $msg 1118} 1119# Don't support transposition (yet) 1120proc domtext::_tkevent_filter_<Control-Key-t> {path detail} { 1121 return -code break 1122} 1123 1124proc domtext::_tkevent_filter_<Control-Key-h> {path detail} { 1125 set code [catch {_tkevent_filter_<Key-Backspace> $path $detail} msg] 1126 return -code $code $msg 1127} 1128proc domtext::_tkevent_filter_<Key-BackSpace> {path detail} { 1129 # Once the Text widget gets the focus, it receives the event. 1130 # We compensate for this here 1131 if {[winfo class $path] == "Text"} { 1132 set path [winfo parent $path] 1133 } 1134 upvar #0 [namespace current]::selected$path selected 1135 1136 switch [dom::node cget $selected -nodeType] { 1137 textNode { 1138 # If we're at the beginning of the text node stop here 1139 set ranges [$path.text tag ranges $selected] 1140 if {![llength $ranges] || [$path.text compare insert <= [lindex $ranges 0]]} { 1141 bell 1142 return -code break 1143 } 1144 } 1145 default { 1146 switch [tk_messageBox -parent [winfo toplevel $path] -title [mc {Confirm Delete Node}] -message [format [mc {Are you sure you want to delete a node of type %s?}] [dom::node cget $selected -nodeType]] -type okcancel] { 1147 ok { 1148 dom::node removeNode [dom::node parent $selected] $selected 1149 } 1150 cancel { 1151 return -code break 1152 } 1153 } 1154 } 1155 } 1156 1157 $path.text delete insert-1c 1158 $path.text see insert 1159 1160 _tkevent_filter_update $path 1161 1162 return -code break 1163} 1164proc domtext::_tkevent_filter_<Key-Delete> {path detail} { 1165 # Once the Text widget gets the focus, it receives the event. 1166 # We compensate for this here 1167 if {[winfo class $path] == "Text"} { 1168 set path [winfo parent $path] 1169 } 1170 upvar #0 [namespace current]::selected$path selected 1171 1172 switch [dom::node cget $selected -nodeType] { 1173 textNode { 1174 # If we're at the beginning of the text node stop here 1175 set ranges [$path.text tag ranges $selected] 1176 if {[$path.text compare insert >= [lindex $ranges end]]} { 1177 bell 1178 return -code break 1179 } 1180 } 1181 default { 1182 switch [tk_messageBox -parent [winfo toplevel $path] -title [mc {Confirm Delete Node}] -message [format [mc {Are you sure you want to delete a node of type %s?}] [dom::node cget $selected -nodeType]] -type okcancel] { 1183 ok { 1184 dom::node removeNode [dom::node parent $selected] $selected 1185 } 1186 cancel { 1187 return -code break 1188 } 1189 } 1190 } 1191 } 1192 1193 $path.text delete insert 1194 $path.text see insert 1195 1196 _tkevent_filter_update $path 1197 1198 return -code break 1199} 1200proc domtext::_tkevent_filter_update path { 1201 upvar #0 [namespace current]::selected$path selected 1202 1203 # Now update the DOM node's value 1204 1205 set ranges [$path.text tag ranges $selected] 1206 1207 # If all text has been deleted then remove the node 1208 if {[llength $ranges]} { 1209 set newtext [$path.text get [lindex $ranges 0] [lindex $ranges end]] 1210 dom::node configure $selected -nodeValue $newtext 1211 } else { 1212 set parent [dom::node parent $selected] 1213 dom::node removeNode [dom::node parent $selected] $selected 1214 # Move selection to parent element, rather than removing selection 1215 #unset selected 1216 dom::event postUIEvent $parent DOMActivate -detail 1 1217 } 1218 1219 return {} 1220} 1221 1222# This will delete from the insertion point to the end of the line 1223# or text node, whichever is shorter 1224# TODO: implement this 1225proc domtext::_tkevent_filter_<Control-Key-k> {path detail} { 1226 return -code break 1227} 1228# TODO: this will delete the word to the left of the insertion point 1229# (only within the text node) 1230proc domtext::_tkevent_filter_<Meta-Key-Delete> {path detail} { 1231 return -code break 1232} 1233proc domtext::_tkevent_filter_<Meta-Key-BackSpace> {path detail} { 1234 _tkevent_filter_<Meta-Key-Delete> $path $detail 1235} 1236 1237### Utilities 1238 1239# domtext::_insert_to_node -- 1240# 1241# Finds the DOM node for the insertion point 1242# 1243# Arguments: 1244# path widget path 1245# 1246# Results: 1247# Returns DOM token 1248 1249proc domtext::_insert_to_node path { 1250 set tags [$path.text tag names insert] 1251 set newnode [lindex $tags end] 1252 while {![dom::DOMImplementation isNode $newnode]} { 1253 set tags [lreplace $tags end end] 1254 set newnode [lindex $tags end] 1255 } 1256 return $newnode 1257} 1258 1259### Inlined images 1260 1261image create photo ::domtext::starttab -data { 1262R0lGODlhEAAYAPcAAP//////zP//mf//Zv//M///AP/M///MzP/Mmf/MZv/M 1263M//MAP+Z//+ZzP+Zmf+ZZv+ZM/+ZAP9m//9mzP9mmf9mZv9mM/9mAP8z//8z 1264zP8zmf8zZv8zM/8zAP8A//8AzP8Amf8AZv8AM/8AAMz//8z/zMz/mcz/Zsz/ 1265M8z/AMzM/8zMzMzMmczMZszMM8zMAMyZ/8yZzMyZmcyZZsyZM8yZAMxm/8xm 1266zMxmmcxmZsxmM8xmAMwz/8wzzMwzmcwzZswzM8wzAMwA/8wAzMwAmcwAZswA 1267M8wAAJn//5n/zJn/mZn/Zpn/M5n/AJnM/5nMzJnMmZnMZpnMM5nMAJmZ/5mZ 1268zJmZmZmZZpmZM5mZAJlm/5lmzJlmmZlmZplmM5lmAJkz/5kzzJkzmZkzZpkz 1269M5kzAJkA/5kAzJkAmZkAZpkAM5kAAGb//2b/zGb/mWb/Zmb/M2b/AGbM/2bM 1270zGbMmWbMZmbMM2bMAGaZ/2aZzGaZmWaZZmaZM2aZAGZm/2ZmzGZmmWZmZmZm 1271M2ZmAGYz/2YzzGYzmWYzZmYzM2YzAGYA/2YAzGYAmWYAZmYAM2YAADP//zP/ 1272zDP/mTP/ZjP/MzP/ADPM/zPMzDPMmTPMZjPMMzPMADOZ/zOZzDOZmTOZZjOZ 1273MzOZADNm/zNmzDNmmTNmZjNmMzNmADMz/zMzzDMzmTMzZjMzMzMzADMA/zMA 1274zDMAmTMAZjMAMzMAAAD//wD/zAD/mQD/ZgD/MwD/AADM/wDMzADMmQDMZgDM 1275MwDMAACZ/wCZzACZmQCZZgCZMwCZAABm/wBmzABmmQBmZgBmMwBmAAAz/wAz 1276zAAzmQAzZgAzMwAzAAAA/wAAzAAAmQAAZgAAM+4AAN0AALsAAKoAAIgAAHcA 1277AFUAAEQAACIAABEAAADuAADdAAC7AACqAACIAAB3AABVAABEAAAiAAARAAAA 12787gAA3QAAuwAAqgAAiAAAdwAAVQAARAAAIgAAEe7u7t3d3bu7u6qqqoiIiHd3 1279d1VVVURERCIiIhEREQAAACwAAAAAEAAYAAcIgwABCBxIsKBAfAjx2TNYMCHC 1280hQwPOrwHkaFDhRQjXtR3L6PBix3teSR4USRHexUlJuTY8WRFkBQ7dsQ3sOS9 1281kzNrOmR5M6dKhCFl3qP5EyPOoTpXymRJFABMkTKb2sSZL19ShDz1WSU5MeZW 1282rglNfgWL9d5YsvjMRgRQte3ZtXABAggIADs= 1283} 1284image create photo ::domtext::endtab -data { 1285R0lGODlhEAAYAPcAAP//////zP//mf//Zv//M///AP/M///MzP/Mmf/MZv/M 1286M//MAP+Z//+ZzP+Zmf+ZZv+ZM/+ZAP9m//9mzP9mmf9mZv9mM/9mAP8z//8z 1287zP8zmf8zZv8zM/8zAP8A//8AzP8Amf8AZv8AM/8AAMz//8z/zMz/mcz/Zsz/ 1288M8z/AMzM/8zMzMzMmczMZszMM8zMAMyZ/8yZzMyZmcyZZsyZM8yZAMxm/8xm 1289zMxmmcxmZsxmM8xmAMwz/8wzzMwzmcwzZswzM8wzAMwA/8wAzMwAmcwAZswA 1290M8wAAJn//5n/zJn/mZn/Zpn/M5n/AJnM/5nMzJnMmZnMZpnMM5nMAJmZ/5mZ 1291zJmZmZmZZpmZM5mZAJlm/5lmzJlmmZlmZplmM5lmAJkz/5kzzJkzmZkzZpkz 1292M5kzAJkA/5kAzJkAmZkAZpkAM5kAAGb//2b/zGb/mWb/Zmb/M2b/AGbM/2bM 1293zGbMmWbMZmbMM2bMAGaZ/2aZzGaZmWaZZmaZM2aZAGZm/2ZmzGZmmWZmZmZm 1294M2ZmAGYz/2YzzGYzmWYzZmYzM2YzAGYA/2YAzGYAmWYAZmYAM2YAADP//zP/ 1295zDP/mTP/ZjP/MzP/ADPM/zPMzDPMmTPMZjPMMzPMADOZ/zOZzDOZmTOZZjOZ 1296MzOZADNm/zNmzDNmmTNmZjNmMzNmADMz/zMzzDMzmTMzZjMzMzMzADMA/zMA 1297zDMAmTMAZjMAMzMAAAD//wD/zAD/mQD/ZgD/MwD/AADM/wDMzADMmQDMZgDM 1298MwDMAACZ/wCZzACZmQCZZgCZMwCZAABm/wBmzABmmQBmZgBmMwBmAAAz/wAz 1299zAAzmQAzZgAzMwAzAAAA/wAAzAAAmQAAZgAAM+4AAN0AALsAAKoAAIgAAHcA 1300AFUAAEQAACIAABEAAADuAADdAAC7AACqAACIAAB3AABVAABEAAAiAAARAAAA 13017gAA3QAAuwAAqgAAiAAAdwAAVQAARAAAIgAAEe7u7t3d3bu7u6qqqoiIiHd3 1302d1VVVURERCIiIhEREQAAACwAAAAAEAAYAAcIgwABCBxIsKDBgvbwKcR3cGDC 1303hQwb2rsHMaLBiQ8XHpx4T1/Fi/c4fiRob6K+kCMBlOx4r6VHiAPxtWwpEqZA 1304mSFZZlQY0+XMlxpvzsxJ0SYAnCZRGsV50mVKnDRbpsyXL+fJnRYF5mvaMeXA 1305qjWDFtyqVOzYrkYNVvWqlqrbhg0BAggIADs= 1306} 1307 1308