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 {\&amp;} value
499	regsub -all < $value {\&lt;} 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 {\&quot;} 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	< &lt;
531	> &gt;
532	& &amp;
533	\" &quot;
534	' &apos;
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