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 \]\]&gt\;<!\[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	< &lt;
3066	> &gt;
3067	& &amp;
3068	\" &quot;
3069	' &apos;
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 {\&amp;} value
3106	regsub -all < $value {\&lt;} 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 {\&quot;} 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