1# Features covered: dom command
2#
3# This file contains a collection of tests for the dom command of
4# tDOM.
5#
6#    dom-1.*:  createDocument, createDocumentNS
7#    dom-2.*:  parse
8#    dom-3.*:  isName, isNCName, isCharData, isPIName, isComment, isCDATA
9#    dom-4.*:  parse -useForeignDTD
10#    dom-5.*:  external entities
11#    dom-6.*:  use in slave interpreter
12#    dom-7.*:  setNameCheck, setTextCheck
13#    dom-8.*:  createDocumentNode, documentNodes
14#    dom-9.*:  setObjectCommands
15#    dom-10.*: createNodeCmd
16#    dom-11.*: featureinfo
17#    dom-12.*: -feedbackAfter
18#
19# Copyright (c) 2002, 2003, 2004 Rolf Ade.
20
21source [file join [file dir [info script]] loadtdom.tcl]
22
23test dom-1.1 {createDocument with root node name not a XML Name} {
24    list [catch {dom createDocument "root node"} msg] $msg
25} "1 {Invalid root element name 'root node'}"
26
27test dom-1.2 {createDocument with root node name not a XML Name} {
28    list [catch {dom createDocument "1root"} msg] $msg
29} "1 {Invalid root element name '1root'}"
30
31test dom-1.3 {createDocument - root name us-ascii} {
32    dom createDocument "root" doc
33    set root [$doc documentElement]
34    set result [$root nodeName]
35    $doc delete
36    set result
37} "root"
38
39test dom-1.4 {createDocument - root name with UTF-8 chars} {
40    dom createDocument "\u00c4\u00d4\u00dc" doc
41    set root [$doc documentElement]
42    set result [$root nodeName]
43    $doc delete
44    set result
45} "\u00c4\u00d4\u00dc"
46
47test dom-1.5 {createDocument with FQ root name} {
48    dom createDocument "foo:bar" doc
49    set root [$doc documentElement]
50    set result [$root nodeName]
51    $doc delete
52    set result
53} "foo:bar"
54
55test dom-1.6 {createDocument with wrong # of args} {
56    list [catch {dom createDocument "root" "http:/foo:bar" doc} msg] $msg
57} "1 {wrong \# args: should be \"createDocument docElemName ?newObjVar?\"}"
58
59test dom-1.7 {createDocumentNS - check root name} {
60    set doc [dom createDocumentNS "http://foo.bar" "root"]
61    set root [$doc documentElement]
62    set result [$root nodeName]
63    $doc delete
64    set result
65} "root"
66
67test dom-1.8 {createDocumentNS - check the NS of the created root} {
68    dom createDocumentNS "http://foo.bar" "root" doc
69    set root [$doc documentElement]
70    set result [$root namespaceURI]
71    $doc delete
72    set result
73} "http://foo.bar"
74
75test dom-1.9 {createDocumentNS with root name not a NCName} {
76    list [catch {dom createDocumentNS "http://foo.bar" "foo bar" doc} msg] $msg
77} "1 {Invalid root element name 'foo bar'}"
78
79test dom-1.10 {createDocumentNS with root name not a NCName} {
80    list [catch {dom createDocumentNS "http://foo.bar" "a:b:c" doc} msg] $msg
81} "1 {Invalid root element name 'a:b:c'}"
82
83test dom-1.11 {createDocumentNS with root name not a NCName} {
84    list [catch {dom createDocumentNS "http://foo.bar" "a b:b" doc} msg] $msg
85} "1 {Invalid root element name 'a b:b'}"
86
87test dom-1.12 {createDocumentNS with root name not a NCName} {
88    list [catch {dom createDocumentNS "http://foo.bar" "a:a b" doc} msg] $msg
89} "1 {Invalid root element name 'a:a b'}"
90
91test dom-1.13 {createDocumentNS - check root name} {
92    set doc [dom createDocumentNS "http://foo.bar" foo:root]
93    set root [$doc documentElement]
94    set result [$root nodeName]
95    $doc delete
96    set result
97} "foo:root"
98
99test dom-1.14 {createDocument - rename the doc cmd} {
100    set doc [dom createDocument root]
101    if {[info commands fooCmd] == "fooCmd"} {
102        rename fooCmd {}
103    }
104    rename $doc fooCmd
105    set result [[fooCmd documentElement] nodeName]
106    fooCmd delete
107    set result
108} {root}
109
110test dom-1.15 {createDocument - rename the doc cmd} {
111    if {[info commands fooCmd] == "fooCmd"} {
112        rename fooCmd {}
113    }
114    set nrOfCommands [llength [info commands]]
115    set doc [dom createDocument root]
116    rename $doc fooCmd
117    fooCmd delete
118    expr {[llength [info commands]] == $nrOfCommands}
119} {1}
120
121test dom-1.16 {createDocumentNS - empty namespace, no prefix} {
122    dom createDocumentNS "" doc doc
123    set result [$doc asXML -indent none]
124    $doc delete
125    set result
126} {<doc/>}
127
128test dom-1.17 {createDocumentNS -  namespace, no prefix} {
129    dom createDocumentNS "uri" doc doc
130    set result [$doc asXML -indent none]
131    $doc delete
132    set result
133} {<doc xmlns="uri"/>}
134
135test dom-1.18 {createDocumentNS -  namespace, no prefix} {
136    dom createDocumentNS "uri" doc doc
137    set result [$doc selectNodes -namespaces {ns uri} count(/ns:doc)]
138    $doc delete
139    set result
140} 1
141
142test dom-1.19 {createDocumentNS - namespace, prefix} {
143    dom createDocumentNS "uri" n1:doc doc
144    set result [$doc selectNodes -namespaces {ns uri} count(/ns:doc)]
145    $doc delete
146    set result
147} 1
148
149test dom-1.20 {createDocumentNS - empty namespace, prefix} {
150    catch {dom createDocumentNS "" n1:doc doc} errMsg
151    set errMsg
152} {Missing URI in Namespace declaration}
153
154test dom-1.21 {Explicit delete of scoped doc with domDoc cmd} {} {
155    dom createDocument test doc
156    domDoc $doc delete
157    unset doc
158} {}
159
160proc dom-1.22 {doc} {
161    $doc delete
162}
163test dom-1.22 {Explicit delete of scoped doc in proc call from scope} {} {
164    dom createDocument test doc
165    dom-1.22 $doc
166    unset doc
167} {}
168
169test dom-1.23 {Explicit delete of scoped doc} {
170    dom createDocument test doc
171    $doc delete
172    unset doc
173} {}
174
175test dom-1.24 {Explicit delete of scoped doc} {
176    dom createDocument test doc
177    set result [catch {set doc foo} errMsg]
178    lappend result $errMsg
179    $doc delete
180    unset doc
181    set result
182} {1 {can't set "doc": var is read-only}}
183
184test dom-2.1 {Don't quash white space at start or end of non white space content} {
185    set doc [dom parse {<root>
186    some content
187    </root>}]
188    set root [$doc documentElement]
189    $root text
190} {
191    some content
192    }
193
194test dom-2.2 {parse doc with various re-declaration of a prefix} {
195    set doc [dom parse {<p:a xmlns:p="uri1">
196    <p:b xmlns:p="uri2">
197        <p:c xmlns:p="uri1"/>
198    </p:b>
199</p:a>}]
200    set root [$doc documentElement]
201    set result [$root asXML]
202    $doc delete
203    set result
204} {<p:a xmlns:p="uri1">
205    <p:b xmlns:p="uri2">
206        <p:c xmlns:p="uri1"/>
207    </p:b>
208</p:a>
209}
210
211test dom-2.3 {parse doc with default NS declaration} {
212    set doc [dom parse {<a xmlns:p="uri">
213    <p:b/>
214    <p:b/>
215</a>}]
216    set root [$doc documentElement]
217    set result [$root asXML]
218    $doc delete
219    set result
220} {<a xmlns:p="uri">
221    <p:b/>
222    <p:b/>
223</a>
224}
225
226test dom-2.4 {parse method: syntax check} {
227    set doc [dom parse -keepEmpties {<root>
228  text
229    </root>}]
230    set result [$doc asXML -indent none]
231    $doc delete
232    set result
233} {<root>
234  text
235    </root>}
236
237test dom-2.5 {parse method: syntax check} {
238    set doc [dom parse -useForeignDTD 0 -keepEmpties {<root>
239  text
240    </root>}]
241    set result [$doc asXML -indent none]
242    $doc delete
243    set result
244} {<root>
245  text
246    </root>}
247
248test dom-2.6 {parse method: syntax check} -setup {
249    set xmlFile [makeFile {<root>    </root>} dom.xml]
250} -body {
251    set fd [open $xmlFile]
252    set doc [dom parse -channel $fd -keepEmpties]
253    close $fd
254    set root [$doc documentElement]
255    set result [$root asXML -indent none]
256    $doc delete
257    set result
258} -cleanup {
259    removeFile dom.xml
260} -result {<root>    </root>}
261
262test dom-2.7 {parse method: syntax check} -setup {
263    set xmlFile [makeFile {<root>    </root>} dom.xml]
264} -body {
265    catch {unset -keepEmpties}
266    set fd [open $xmlFile]
267    set doc [dom parse -channel $fd -keepEmpties]
268    close $fd
269    $doc delete
270    info exists -keepEmpties
271} -cleanup {
272    removeFile dom.xml
273} -result 0
274
275test dom-2.8 {parse method: bogus option} -body {
276    set result [catch {set doc [dom parse -bogusOption foo <root/>]} errMsg]
277    lappend result $errMsg
278} -match regexp -result {1 {bad option "-bogusOption": must be .*}}
279
280test dom-2.9 {parse method: bogus option} -setup {
281    set xmlFile [makeFile {<root>    </root>} dom.xml]
282} -body {
283    catch {unset -keepEmpties}
284    set fd [open $xmlFile]
285    set result [catch {set doc [dom parse -channel $fd -bogusOption]} errMsg]
286    close $fd
287    lappend result $errMsg
288} -cleanup {
289    removeFile dom.xml
290} -match regexp -result {1 {bad option "-bogusOption": must be .*}}
291
292set dom_dtd "
293    <!ELEMENT root EMPTY>
294    <!ATTLIST root lang CDATA #FIXED \"en\">"
295
296proc extRefResolver {base systemId publicId} {
297    global dom_dtd
298
299    if {$publicId == "DOMCMDTEST"} {
300        return [list string $base $dom_dtd]
301    } else {
302        return [::tdom::extRefHandler $base $systemId $publicId]
303    }
304}
305
306test dom-2.10 {parse method: -paramentityparsing default is 'always'} {
307    set doc [dom parse -externalentitycommand extRefResolver {
308        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
309        <root/>
310    }]
311    set root [$doc documentElement]
312    set result [$root @lang]
313    $doc delete
314    set result
315} {en}
316
317test dom-2.11 {parse method: explicit -paramentityparsing always} {
318    set doc [dom parse -externalentitycommand extRefResolver \
319                       -paramentityparsing always {
320        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
321        <root/>
322    }]
323    set root [$doc documentElement]
324    set result [$root @lang]
325    $doc delete
326    set result
327} {en}
328
329test dom-2.12 {parse method: -paramentityparsing never} {
330    set doc [dom parse -externalentitycommand extRefResolver \
331                       -paramentityparsing never {
332        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
333        <root/>
334    }]
335    set root [$doc documentElement]
336    set result [catch {set result [$root @lang]} errMsg]
337    $doc delete
338    lappend result $errMsg
339    set result
340} {1 {Attribute "lang" not found!}}
341
342test dom-2.13 {parse method: -paramentityparsing notstandalone} {
343    set doc [dom parse -externalentitycommand extRefResolver \
344                       -paramentityparsing notstandalone {
345        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
346        <root/>
347    }]
348    set root [$doc documentElement]
349    set result [$root @lang]
350    $doc delete
351    set result
352} {en}
353
354test dom-2.14 {parse method: -paramentityparsing notstandalone} {
355    set doc [dom parse -externalentitycommand extRefResolver \
356                       -paramentityparsing notstandalone \
357                       {<?xml version="1.0" standalone="yes"?>
358        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
359        <root/>
360    }]
361    set root [$doc documentElement]
362    set result [catch {set result [$root @lang]} errMsg]
363    $doc delete
364    lappend result $errMsg
365    set result
366} {1 {Attribute "lang" not found!}}
367
368test dom-2.15 {parse method: -paramentityparsing notstandalone} {
369    set doc [dom parse -externalentitycommand extRefResolver \
370                       -paramentityparsing notstandalone \
371                       {<?xml version="1.0" standalone="no"?>
372        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
373        <root/>
374    }]
375    set root [$doc documentElement]
376    set result [$root @lang]
377    $doc delete
378    set result
379} {en}
380
381test dom-2.16 {parse method: wrong value arg for -paramentityparsing} {
382    set result [catch {set doc [dom parse -paramentityparsing wrong {
383        <root/>}]} errMsg]
384    lappend result $errMsg
385} {1 {bad value "wrong": must be always, never, or notstandalone}}
386
387# The following is syntactically wrong. It's used, to test the
388# error reporting in external DTDs
389set dom_dtd "<!ATTLIST root lang #FIXED \"en\">"
390
391test dom-2.17 {parse method: test reporting of error in external subset} {
392    set result [catch {set doc [dom parse \
393            -externalentitycommand extRefResolver {
394        <!DOCTYPE root PUBLIC "DOMCMDTEST" "dummysystemID">
395        <root/>
396    }]} errMsg]
397    lappend result $errMsg
398} {1 {error "syntax error" in entity "dummysystemID" at line 1 character 20
399"<!ATTLIST root lang # <--Error-- FIXED "en">", referenced at line 2 character 58}}
400
401test dom-2.18 {parse document with nodes before and after the documentElement} {
402    set doc [dom parse {<!-- First comment -->
403<doc>
404  <!-- Front comment -->
405  <inner/>
406  <!-- Back comment -->
407</doc>
408<!-- Last comment -->}]
409    set result [$doc asXML -indent none]
410    $doc delete
411    set result
412} {<!-- First comment --><doc><!-- Front comment --><inner/><!-- Back comment --></doc><!-- Last comment -->}
413
414test dom-2.19 {parse document - rename docCmd} {
415    set doc [dom parse {<root>foo<child/></root>}]
416    if {[info commands fooCmd] == "fooCmd"} {
417        rename fooCmd {}
418    }
419    rename $doc fooCmd
420    set result [fooCmd asXML -indent none]
421    fooCmd delete
422    set result
423} {<root>foo<child/></root>}
424
425test dom-2.20 {parse - doc with internal subset parsed with -keepEmpties} {
426    set doc [dom parse -keepEmpties {
427        <!DOCTYPE root [
428           <!ELEMENT root EMPTY>
429           <!-- Comment inside the DTD -->
430           <?aPI Inside the DTD?>
431           <!ATTLIST root lang CDATA #FIXED "en">
432          ]>
433        <root/>}]
434    $doc documentElement root
435    set result ""
436    foreach node [$root selectNodes /node()] {
437        switch [$node nodeType] {
438            TEXT_NODE {
439                lappend result TEXT_NODE
440                lappend result [string length [$node value]]
441            }
442            COMMENT_NODE {
443                lappend result COMMENT_NODE
444                lappend result [string length [$node value]]
445            }
446            PROCESSING_INSTRUCTION_NODE {
447                lappend result PROCESSING_INSTRUCTION_NODE
448                lappend result [$node target]
449                lappend result [$node data]
450            }
451            ELEMENT_NODE {
452                lappend result ELEMENT_NODE
453                lappend result [$node nodeName]
454            }
455            default {
456                lappend result [$node nodeType]
457            }
458        }
459    }
460    $doc delete
461    set result
462} {ELEMENT_NODE root}
463
464test dom-2.21 {parse - empty CDATA section} {
465    set doc [dom parse {<doc><![CDATA[]]></doc>}]
466    set root [$doc documentElement]
467    set result [$root hasChildNodes]
468    $doc delete
469    set result
470} {0}
471
472test dom-2.22 {parse - empty comment section} {
473    set doc [dom parse {<doc><!----></doc>}]
474    set root [$doc documentElement]
475    set result [$root hasChildNodes]
476    lappend result [[$root firstChild] nodeValue]
477    $doc delete
478    set result
479} {1 {}}
480
481test dom-2.23 {parse - pi without pivalue} {
482    set doc [dom parse {<doc><?p?></doc>}]
483    set pi [[$doc documentElement] firstChild]
484    set result [list [$pi nodeName] [$pi nodeValue] [$pi target] [$pi data]]
485    $doc delete
486    set result
487} {p {} p {}}
488
489proc 2.24 {args} {
490    error "2.24 external entitiy resolver script error"
491}
492
493test dom-2.24 {parse - script error in -externalentitycommand} {
494    set result [catch {
495        dom parse -externalentitycommand 2.24 {
496            <!DOCTYPE root SYSTEM "data/domCmd2.dtd">
497            <root/>}} errMsg]
498    lappend result $errMsg
499} {1 {2.24 external entitiy resolver script error}}
500
501test dom-2.25 {White space outside the document element is markup and ignored, even with -keepEmpties} {
502    set doc [dom parse -keepEmpties {
503<!-- First comment -->
504<doc>
505  <!-- Front comment -->
506  <inner/>
507  <!-- Back comment -->
508</doc>
509<!-- Last comment -->}]
510    set result [$doc asXML -indent none]
511    $doc delete
512    set result
513} {<!-- First comment --><doc>
514  <!-- Front comment -->
515  <inner/>
516  <!-- Back comment -->
517</doc><!-- Last comment -->}
518
519test dom-2.26 {Not well-formed input} {
520    catch {dom parse {<xsl:transform
521        xmlns:xsl="http://www.w3.org/1999/XSL/Transform
522                   <http://www.w3.org/1999/XSL/Transform> "/>}}
523} 1
524
525test dom-2.27 {parse -ignorexmlns} {
526    set result [list]
527    set doc [dom parse {<doc xmlns="foo.bar"><child/></doc>}]
528    set root [$doc documentElement]
529    lappend result [$root localName]
530    lappend result [$root namespaceURI]
531    set child [$root firstChild]
532    lappend result [$child localName]
533    lappend result [$child namespaceURI]
534    lappend result [$doc selectNodes count(/doc/child)]
535    $doc delete
536    set doc [dom parse -ignorexmlns {<doc xmlns="foo.bar"><child/></doc>}]
537    set root [$doc documentElement]
538    lappend result [$root nodeName]
539    lappend result [$root namespaceURI]
540    set child [$root firstChild]
541    lappend result [$child nodeName]
542    lappend result [$child namespaceURI]
543    lappend result [$doc selectNodes count(/doc/child)]
544    $doc delete
545    set result
546} {doc foo.bar child foo.bar 0 doc {} child {} 1}
547
548test dom-2.28 {parse document with undeclared xml prefix} {
549    catch {dom parse {<doc><foo:e/></doc>}} errMsg
550    string range $errMsg 0 30
551} {Namespace prefix is not defined}
552
553test dom-2.29 {parse not well-formed document with undeclared xml prefix} {knownBug} {
554    catch {dom parse {<foo:e/>}} errMsg
555    string range $errMsg 0 30
556} {Namespace prefix is not defined}
557
558test dom-2.30 {parse document with undeclared xml prefix} {
559    catch {dom parse {<foo:e><a/></foo:e>}} errMsg
560    string range $errMsg 0 30
561} {Namespace prefix is not defined}
562
563proc dom-2.31 {base systemId publicId} {
564    switch $publicId {
565        "e1" {
566            # Not well-formed
567            set data "<foo:e/>"
568        }
569        default {
570            error "unknown public ID"
571        }
572    }
573    return [list "string" $base $data]
574}
575test dom-2.31 {parse document with undeclared xml prefix} {
576    catch {dom parse -externalentitycommand dom-2.31 \
577                {<!DOCTYPE doc [<!ENTITY e1 PUBLIC "e1" "e1.xml">]>
578                    <doc>&e1;</doc>}
579    } errMsg
580    string range $errMsg 0 30
581} {Namespace prefix is not defined}
582
583test dom-2.32 {parse document with undeclared xml prefix and -ignorexmlns} {
584    set doc [dom parse -ignorexmlns {<foo:e><a/></foo:e>}]
585    set result [[$doc documentElement] nodeName]
586    $doc delete
587    set result
588} {foo:e}
589
590test dom-2.33 {end of options option} {
591    set doc [dom parse -json -- -0.123]
592    set result [$doc asXML -indent none]
593    $doc delete
594    set result
595} -0.123
596
597test dom-2.34 {XML prefix declaration with empty namespace} {
598    catch {dom parse {<foo:doc xmlns:foo=""><e1/></foo:doc>}} errMsg
599    set errMsg
600} {Missing URI in Namespace declaration, referenced at line 1 character 22}
601
602test dom-2.35 {-keepCDATA} {
603    set doc [dom parse -keepCDATA {<doc>foo <![CDATA[test of & <bad> format]]> bar </doc>}]
604    set result [$doc asXML -indent none]
605    $doc delete
606    set result
607} {<doc>foo <![CDATA[test of & <bad> format]]> bar </doc>}
608
609test dom-2.36 {-keepCDATA} {
610    set doc [dom parse -keepCDATA {<doc>foo <![CDATA[test of & <bad> format]]> bar </doc>}]
611    set root [$doc documentElement]
612    set result [list]
613    foreach child [$root childNodes] {
614        lappend result [$child nodeType]
615    }
616    $doc delete
617    set result
618} {TEXT_NODE CDATA_SECTION_NODE TEXT_NODE}
619
620test dom-2.37 {-keepCDATA} {
621    set doc [dom parse -keepCDATA {<doc><e><![CDATA[one]]></e></doc>}]
622    set result [list]
623    foreach child [$doc selectNodes doc/e/node()] {
624        lappend result [$child nodeType]
625    }
626    $doc delete
627    set result
628} {CDATA_SECTION_NODE}
629
630test dom-2.38 {-keepCDATA} {
631    set doc [dom parse -keepCDATA {<doc><e><![CDATA[one]]><![CDATA[two]]></e></doc>}]
632    set result [list]
633    foreach child [$doc selectNodes doc/e/node()] {
634        lappend result [$child nodeType]
635    }
636    $doc delete
637    set result
638} {CDATA_SECTION_NODE CDATA_SECTION_NODE}
639
640test dom-2.39 {-keepCDATA} {
641    set doc [dom parse -keepCDATA {<doc><e><![CDATA[]]></e></doc>}]
642    set result [$doc selectNodes count(doc/e/node())]
643    $doc delete
644    set result
645} 0
646
647test dom-2.40 {-keepCDATA white space only CDATA section} {
648    set doc [dom parse -keepCDATA {<doc><e><![CDATA[
649    ]]></e></doc>}]
650    set result [$doc selectNodes count(doc/e/node())]
651    $doc delete
652    set result
653} 0
654
655test dom-2.41 {-keepCDATA and -keepEmpties} {
656    set doc [dom parse -keepCDATA -keepEmpties {<doc><e><![CDATA[]]></e></doc>}]
657    set result [$doc selectNodes count(doc/e/node())]
658    $doc delete
659    set result
660} 1
661
662test dom-2.42 {namespaces} {
663    set doc [dom parse {
664        <help><br xmlns:xsi="a"/><em xmlns:xsi="a">notes</em></help>
665    }]
666    $doc delete
667} {}
668
669test dom-3.1 {isName} {
670    dom isName ":foo"
671} {1}
672
673test dom-3.2 {isName} {
674    dom isName "_foo"
675} {1}
676
677test dom-3.3 {isName} {
678    dom isName "foo:bar:baz"
679} {1}
680
681test dom-3.4 {isName} {
682    dom isName "-foo"
683} {0}
684
685test dom-3.5 {isName} {
686    dom isName ".foo"
687} {0}
688
689test dom-3.6 {isName} {
690    catch {dom isName}
691} {1}
692
693test dom-3.7 {isName} {
694    catch {dom isName foo bar}
695} {1}
696
697# The following character classes are out of XML 1.0 Second Edition rec,
698# Appendix B (which is following the Unicode standard).
699
700set BaseChar {
701    {0x0041 0x005A} {0x0061 0x007A} {0x00C0 0x00D6}
702    {0x00D8 0x00F6} {0x00F8 0x00FF} {0x0100 0x0131} {0x0134 0x013E}
703    {0x0141 0x0148} {0x014A 0x017E} {0x0180 0x01C3}
704    {0x01CD 0x01F0} {0x01F4 0x01F5} {0x01FA 0x0217} {0x0250 0x02A8}
705    {0x02BB 0x02C1} 0x0386 {0x0388 0x038A} 0x038C
706    {0x038E 0x03A1} {0x03A3 0x03CE} {0x03D0 0x03D6} 0x03DA 0x03DC
707    0x03DE 0x03E0 {0x03E2 0x03F3} {0x0401 0x040C}
708    {0x040E 0x044F} {0x0451 0x045C} {0x045E 0x0481} {0x0490 0x04C4}
709    {0x04C7 0x04C8} {0x04CB 0x04CC} {0x04D0 0x04EB}
710    {0x04EE 0x04F5} {0x04F8 0x04F9} {0x0531 0x0556} 0x0559
711    {0x0561 0x0586} {0x05D0 0x05EA} {0x05F0 0x05F2} {0x0621 0x063A}
712    {0x0641 0x064A} {0x0671 0x06B7} {0x06BA 0x06BE}
713    {0x06C0 0x06CE} {0x06D0 0x06D3} 0x06D5 {0x06E5 0x06E6}
714    {0x0905 0x0939} 0x093D {0x0958 0x0961} {0x0985 0x098C}
715    {0x098F 0x0990} {0x0993 0x09A8} {0x09AA 0x09B0} 0x09B2
716    {0x09B6 0x09B9} {0x09DC 0x09DD} {0x09DF 0x09E1} {0x09F0 0x09F1}
717    {0x0A05 0x0A0A} {0x0A0F 0x0A10} {0x0A13 0x0A28}
718    {0x0A2A 0x0A30} {0x0A32 0x0A33} {0x0A35 0x0A36} {0x0A38 0x0A39}
719    {0x0A59 0x0A5C} 0x0A5E {0x0A72 0x0A74} {0x0A85 0x0A8B}
720    0x0A8D {0x0A8F 0x0A91} {0x0A93 0x0AA8} {0x0AAA 0x0AB0}
721    {0x0AB2 0x0AB3} {0x0AB5 0x0AB9} 0x0ABD 0x0AE0 {0x0B05 0x0B0C}
722    {0x0B0F 0x0B10} {0x0B13 0x0B28} {0x0B2A 0x0B30}
723    {0x0B32 0x0B33} {0x0B36 0x0B39} 0x0B3D {0x0B5C 0x0B5D}
724    {0x0B5F 0x0B61} {0x0B85 0x0B8A} {0x0B8E 0x0B90} {0x0B92 0x0B95}
725    {0x0B99 0x0B9A} 0x0B9C {0x0B9E 0x0B9F} {0x0BA3 0x0BA4}
726    {0x0BA8 0x0BAA} {0x0BAE 0x0BB5} {0x0BB7 0x0BB9} {0x0C05 0x0C0C}
727    {0x0C0E 0x0C10} {0x0C12 0x0C28} {0x0C2A 0x0C33}
728    {0x0C35 0x0C39} {0x0C60 0x0C61} {0x0C85 0x0C8C} {0x0C8E 0x0C90}
729    {0x0C92 0x0CA8} {0x0CAA 0x0CB3} {0x0CB5 0x0CB9} 0x0CDE
730    {0x0CE0 0x0CE1} {0x0D05 0x0D0C} {0x0D0E 0x0D10} {0x0D12 0x0D28}
731    {0x0D2A 0x0D39} {0x0D60 0x0D61} {0x0E01 0x0E2E} 0x0E30
732    {0x0E32 0x0E33} {0x0E40 0x0E45} {0x0E81 0x0E82} 0x0E84
733    {0x0E87 0x0E88} 0x0E8A 0x0E8D {0x0E94 0x0E97} {0x0E99 0x0E9F}
734    {0x0EA1 0x0EA3} 0x0EA5 0x0EA7 {0x0EAA 0x0EAB}
735    {0x0EAD 0x0EAE} 0x0EB0 {0x0EB2 0x0EB3} 0x0EBD {0x0EC0 0x0EC4}
736    {0x0F40 0x0F47} {0x0F49 0x0F69} {0x10A0 0x10C5}
737    {0x10D0 0x10F6} 0x1100 {0x1102 0x1103} {0x1105 0x1107} 0x1109
738    {0x110B 0x110C} {0x110E 0x1112} 0x113C 0x113E 0x1140
739    0x114C 0x114E 0x1150 {0x1154 0x1155} 0x1159 {0x115F 0x1161}
740    0x1163 0x1165 0x1167 0x1169 {0x116D 0x116E}
741    {0x1172 0x1173} 0x1175 0x119E 0x11A8 0x11AB {0x11AE 0x11AF}
742    {0x11B7 0x11B8} 0x11BA {0x11BC 0x11C2} 0x11EB 0x11F0
743    0x11F9 {0x1E00 0x1E9B} {0x1EA0 0x1EF9} {0x1F00 0x1F15}
744    {0x1F18 0x1F1D} {0x1F20 0x1F45} {0x1F48 0x1F4D} {0x1F50 0x1F57}
745    0x1F59 0x1F5B 0x1F5D {0x1F5F 0x1F7D} {0x1F80 0x1FB4}
746    {0x1FB6 0x1FBC} 0x1FBE {0x1FC2 0x1FC4} {0x1FC6 0x1FCC}
747    {0x1FD0 0x1FD3} {0x1FD6 0x1FDB} {0x1FE0 0x1FEC} {0x1FF2 0x1FF4}
748    {0x1FF6 0x1FFC} 0x2126 {0x212A 0x212B} 0x212E
749    {0x2180 0x2182} {0x3041 0x3094} {0x30A1 0x30FA} {0x3105 0x312C}
750    {0xAC00 0xD7A3}
751}
752
753set Ideographic {
754    {0x4E00 0x9FA5} 0x3007 {0x3021 0x3029}
755}
756
757set CombiningChar {
758    {0x0300 0x0345} {0x0360 0x0361} {0x0483 0x0486} {0x0591 0x05A1}
759    {0x05A3 0x05B9} {0x05BB 0x05BD} 0x05BF {0x05C1 0x05C2}
760    0x05C4 {0x064B 0x0652} 0x0670 {0x06D6 0x06DC} {0x06DD 0x06DF}
761    {0x06E0 0x06E4} {0x06E7 0x06E8} {0x06EA 0x06ED}
762    {0x0901 0x0903} 0x093C {0x093E 0x094C} 0x094D {0x0951 0x0954}
763    {0x0962 0x0963} {0x0981 0x0983} 0x09BC 0x09BE 0x09BF
764    {0x09C0 0x09C4} {0x09C7 0x09C8} {0x09CB 0x09CD} 0x09D7
765    {0x09E2 0x09E3} 0x0A02 0x0A3C 0x0A3E 0x0A3F {0x0A40 0x0A42}
766    {0x0A47 0x0A48} {0x0A4B 0x0A4D} {0x0A70 0x0A71}
767    {0x0A81 0x0A83} 0x0ABC {0x0ABE 0x0AC5} {0x0AC7 0x0AC9}
768    {0x0ACB 0x0ACD} {0x0B01 0x0B03} 0x0B3C {0x0B3E 0x0B43}
769    {0x0B47 0x0B48} {0x0B4B 0x0B4D} {0x0B56 0x0B57} {0x0B82 0x0B83}
770    {0x0BBE 0x0BC2} {0x0BC6 0x0BC8} {0x0BCA 0x0BCD} 0x0BD7
771    {0x0C01 0x0C03} {0x0C3E 0x0C44} {0x0C46 0x0C48} {0x0C4A 0x0C4D}
772    {0x0C55 0x0C56} {0x0C82 0x0C83} {0x0CBE 0x0CC4}
773    {0x0CC6 0x0CC8} {0x0CCA 0x0CCD} {0x0CD5 0x0CD6} {0x0D02 0x0D03}
774    {0x0D3E 0x0D43} {0x0D46 0x0D48} {0x0D4A 0x0D4D} 0x0D57
775    0x0E31 {0x0E34 0x0E3A} {0x0E47 0x0E4E} 0x0EB1 {0x0EB4 0x0EB9}
776    {0x0EBB 0x0EBC} {0x0EC8 0x0ECD} {0x0F18 0x0F19} 0x0F35
777    0x0F37 0x0F39 0x0F3E 0x0F3F {0x0F71 0x0F84} {0x0F86 0x0F8B}
778    {0x0F90 0x0F95} 0x0F97 {0x0F99 0x0FAD} {0x0FB1 0x0FB7}
779    0x0FB9 {0x20D0 0x20DC} 0x20E1 {0x302A 0x302F} 0x3099 0x309A
780}
781
782set Digit {
783    {0x0030 0x0039} {0x0660 0x0669} {0x06F0 0x06F9} {0x0966 0x096F}
784    {0x09E6 0x09EF} {0x0A66 0x0A6F} {0x0AE6 0x0AEF}
785    {0x0B66 0x0B6F} {0x0BE7 0x0BEF} {0x0C66 0x0C6F} {0x0CE6 0x0CEF}
786    {0x0D66 0x0D6F} {0x0E50 0x0E59} {0x0ED0 0x0ED9}
787    {0x0F20 0x0F29}
788}
789
790set Extender {
791    0x00B7 0x02D0 0x02D1 0x0387 0x0640 0x0E46 0x0EC6 0x3005
792    {0x3031 0x3035} {0x309D 0x309E} {0x30FC 0x30FE}
793}
794
795proc sortCmd {a b} {
796    if {[lindex $a 0] > [lindex $b 0]} {
797        return 1
798    } else {
799        return -1
800    }
801}
802
803#  if {$tcl_version < 8.4} {
804#      set nameStartChars [lsort -command sortCmd \
805#              [concat $BaseChar $Ideographic 0x005F 0x003A]]
806#  } else {
807#      set nameStartChars [lsort -integer -index 0 \
808#              [concat $BaseChar $Ideographic 0x005F 0x003A]]
809#  }
810
811set nameStartChars [lsort -command sortCmd \
812        [concat $BaseChar $Ideographic 0x005F 0x003A]]
813
814# Append stop char needed by the test code to work properly.
815lappend nameStartChars 0x10000
816
817test dom-3.8 {isName} {longRunning && need_i18n} {
818    set ind 0
819    set nr 0
820    while {$nr < 65536} {
821        set range [lindex $nameStartChars $ind]
822        incr ind
823        if {[llength $range] == 2} {
824            foreach {min max} $range break
825        } else {
826            set min $range
827            set max $range
828        }
829        while {$nr < $min} {
830            if {[dom isName [subst \\u[format "%04x" $nr]]] != 0} {
831                error "wrong 'isName' result for name start char #x[format "%04x" $nr] - should be illegal"
832            }
833            incr nr
834        }
835        if {$nr == 0x10000} {break}
836        while {$nr <= $max} {
837            if {[dom isName [subst \\u[format "%04x" $nr]]] != 1} {
838                error "wrong 'isName' result for name start char #x[format "%04x" $nr] - should be legal"
839            }
840            incr nr
841        }
842    }
843    set nr
844} {65536}
845
846set nameChars [lsort -command sortCmd \
847        [concat $BaseChar $Ideographic $Digit 0x002E 0x002D 0x005F 0x003A \
848                $CombiningChar $Extender]]
849
850# Append stop char needed by the test code to work properly.
851lappend nameChars 0x10000
852
853test dom-3.9 {isName} {longRunning && need_i18n} {
854    set ind 0
855    set nr 0
856    while {$nr < 65536} {
857        set range [lindex $nameChars $ind]
858        incr ind
859        if {[llength $range] == 2} {
860            foreach {min max} $range break
861        } else {
862            set min $range
863            set max $range
864        }
865        while {$nr < $min} {
866            if {[dom isName a[subst \\u[format "%04x" $nr]]] != 0} {
867                error "wrong 'isName' result for name char #x[format "%04x" $nr] - should be illegal"
868            }
869            incr nr
870        }
871        if {$nr == 0x10000} {break}
872        while {$nr <= $max} {
873            if {[dom isName a[subst \\u[format "%04x" $nr]]] != 1} {
874                error "wrong 'isName' result for name char #x[format "%04x" $nr] - should be legal"
875            }
876            incr nr
877        }
878    }
879    set nr
880} {65536}
881
882
883test dom-3.10 {isNCName} {
884    dom isNCName ":foo"
885} {0}
886
887test dom-3.11 {isNCName} {
888    dom isNCName "_foo"
889} {1}
890
891test dom-3.12 {isNCName} {
892    dom isNCName "foo:bar:baz"
893} {0}
894
895test dom-3.13 {isNCName} {
896    dom isNCName "-foo"
897} {0}
898
899test dom-3.14 {isNCName} {
900    dom isNCName ".foo"
901} {0}
902
903test dom-3.15 {isNCName} {
904    catch {dom isNCName}
905} {1}
906
907test dom-3.16 {isNCName} {
908    catch {dom isNCName foo bar}
909} {1}
910
911
912test dom-3.17 {isQName} {
913    dom isQName ":foo"
914} {0}
915
916test dom-3.18 {isQName} {
917    dom isQName "_foo"
918} {1}
919
920test dom-3.19 {isQName} {
921    dom isQName "foo:bar:baz"
922} {0}
923
924test dom-3.20 {isQName} {
925    dom isQName "-foo"
926} {0}
927
928test dom-3.21 {isQName} {
929    dom isQName ".foo"
930} {0}
931
932test dom-3.22 {isQName} {
933    dom isQName "foo:bar"
934} {1}
935
936test dom-3.23 {isQName} {
937    catch {dom isQName}
938} {1}
939
940test dom-3.24 {isQName} {
941    catch {dom isQName foo bar}
942} {1}
943
944test dom-3.25 {isQName} {
945    dom isQName "foo bar"
946} {0}
947
948test dom-3.26 {isQName} {
949    dom isQName "woozbiz:"
950} {0}
951
952test dom-3.26.1 {isQName} {
953     dom isQName foo:1
954} {0}
955
956test dom-3.26.2 {isQName} {
957     dom isQName 1:foo
958} {0}
959
960set XMLChars {
961    0x9 0xA 0xD {0x20 0xD7FF} {0xE000 0xFFFD} {0x10000 0x10FFFF}
962}
963
964test dom-3.27 {isCharData} {longRunning && need_i18n} {
965    set ind 0
966    set nr 1
967    while {$nr < 65536} {
968        set range [lindex $XMLChars $ind]
969        incr ind
970        if {[llength $range] == 2} {
971            foreach {min max} $range break
972        } else {
973            set min $range
974            set max $range
975        }
976        while {$nr < $min} {
977            if {[dom isCharData "a[subst \\u[format "%04x" $nr]]b"] != 0} {
978                error "wrong 'isCharData' result for char #x[format "%04x" $nr] - should be illegal"
979            }
980            incr nr
981        }
982        if {$nr == 0x10000} {break}
983        while {$nr <= $max} {
984            if {[dom isCharData "a[subst \\u[format "%04x" $nr]]b"] != 1} {
985                error "wrong 'isCharData' result for char #x[format "%04x" $nr] - should be legal"
986            }
987            incr nr
988        }
989    }
990    set nr
991} {65536}
992
993
994test dom-3.28 {isPIName} {
995    dom isPIName "target"
996} {1}
997
998test dom-3.29 {isPIName} {
999    dom isPIName "foo:target"
1000} {1}
1001
1002test dom-3.30 {isPIName} {
1003    dom isPIName "Xml"
1004} {0}
1005
1006test dom-3.31 {isComment} {
1007    dom isComment "some comment"
1008} {1}
1009
1010test dom-3.32 {isComment} {
1011    dom isComment "some invalid -- comment"
1012} {0}
1013
1014test dom-3.33 {isComment} {
1015    dom isComment "some invalid comment-"
1016} {0}
1017
1018test dom-3.34 {isCDATA} {
1019    dom isCDATA "<valid>some ]] CDATA </valid>"
1020} {1}
1021
1022test dom-3.35 {isCDATA} {
1023    dom isCDATA "<invalid>some ]]> CDATA </invalid>"
1024} {0}
1025
1026test dom-3.36 {isCDATA} {
1027    dom isCDATA "invalid: ]]>"
1028} {0}
1029
1030test dom-3.37 {isCDATA} {
1031    dom isCDATA "valid: ]]> "
1032} {0}
1033
1034test dom-3.38 {isCDATA} {need_i18n} {
1035    dom isCDATA "\ud7fa\ud7fb\ud7fc\ud7fd\ud7fe\ud7ff]]>"
1036} {0}
1037
1038test dom-3.39 {isPIValue} {
1039    dom isPIValue "some processing instruction data"
1040} {1}
1041
1042test dom-3.40 {isPIValue} {
1043    dom isPIValue "some invalid ?> processing instruction data"
1044} {0}
1045
1046test dom-3.41 {isPIValue} {
1047    dom isPIValue "some invalid processing instruction data?>"
1048} {0}
1049
1050
1051test dom-4.1 {-useForeignDTD 0} {
1052    set doc [dom parse -useForeignDTD 0 {<root/>}]
1053    $doc delete
1054} {}
1055
1056test dom-4.2 {-useForeignDTD 1 with document with internal subset} {need_uri} {
1057    set baseURI [tdom::baseURL [file join [pwd] [file dir [info script]] dom.test]]
1058    set ::tdom::useForeignDTD "data/domCmd1.dtd"
1059    set doc [dom parse \
1060            -useForeignDTD 1 \
1061            -baseurl $baseURI \
1062            -externalentitycommand ::tdom::extRefHandler {
1063<!DOCTYPE root [
1064    <!ATTLIST root fixed CDATA #FIXED "toThat">
1065]>
1066<root/>}]
1067    set root [$doc documentElement]
1068    set result [$root @fixed]
1069    $doc delete
1070    set result
1071} {toThat}
1072
1073test dom-4.3 {-useForeignDTD 1 with document with internal subset} {need_uri} {
1074    set baseURI [tdom::baseURL [file join [pwd] [file dir [info script]] dom.test]]
1075    set ::tdom::useForeignDTD "data/domCmd1.dtd"
1076    set doc [dom parse \
1077            -useForeignDTD 1 \
1078            -baseurl $baseURI \
1079            -externalentitycommand ::tdom::extRefHandler {
1080<!DOCTYPE root [
1081    <!ATTLIST root fixed2 CDATA #FIXED "toThat">
1082]>
1083<root/>}]
1084    set root [$doc documentElement]
1085    set result [$root @fixed]
1086    lappend result [$root @fixed2]
1087    $doc delete
1088    set result
1089} {toThis toThat}
1090
1091test dom-4.4 {-useForeignDTD 1 with document without document declaration} {need_uri} {
1092    set baseURI [tdom::baseURL [file join [pwd] [file dir [info script]] dom.test]]
1093    set ::tdom::useForeignDTD "data/domCmd1.dtd"
1094    set doc [dom parse \
1095            -useForeignDTD 1 \
1096            -baseurl $baseURI \
1097            -externalentitycommand ::tdom::extRefHandler <root/>]
1098    set root [$doc documentElement]
1099    set result [$root @fixed]
1100    $doc delete
1101    set result
1102} {toThis}
1103
1104test dom-4.5 {-useForeignDTD 1 does not overwrite a given external subset} {need_uri} {
1105    set baseURI [tdom::baseURL [file join [pwd] [file dir [info script]] dom.test]]
1106    set ::tdom::useForeignDTD "data/domCmd1.dtd"
1107    set doc [dom parse \
1108            -useForeignDTD 1 \
1109            -baseurl $baseURI \
1110            -externalentitycommand ::tdom::extRefHandler {
1111<!DOCTYPE root SYSTEM "data/domCmd2.dtd">
1112<root/>}]
1113    set root [$doc documentElement]
1114    set result [$root @fixed]
1115    $doc delete
1116    set result
1117} {toThat}
1118
1119test dom-4.6 {-useForeignDTD with nonboolean arg} {need_uri} {
1120    set result [catch {set doc [dom parse -useForeignDTD foo <root/>]} errMsg]
1121    lappend result $errMsg
1122} {1 {expected boolean value but got "foo"}}
1123
1124test dom-5.1 {document with external subset} {need_uri} {
1125    set baseURI [tdom::baseURL [file join [pwd] [file dir [info script]] dom.test]]
1126    set doc [dom parse \
1127            -baseurl $baseURI \
1128            -externalentitycommand ::tdom::extRefHandler {
1129<!DOCTYPE root SYSTEM "data/domCmd2.dtd">
1130<root/>}]
1131    set root [$doc documentElement]
1132    set result [$root @fixed]
1133    $doc delete
1134    set result
1135} {toThat}
1136
1137proc dom-5.2 {myparm base systemId publicId} {
1138    set ::dom-5_2 $myparm
1139    return [list string dummy ""]
1140}
1141
1142test dom-5.2 {-externalentitycommand} {
1143    set ::dom-5_2 ""
1144    set doc [dom parse \
1145                 -baseurl "dummy" \
1146                 -externalentitycommand [list dom-5.2 thisDoc] {
1147                     <!DOCTYPE root SYSTEM "">
1148                     <root/>}]
1149    $doc delete
1150    set ::dom-5_2
1151} {thisDoc}
1152
1153proc dom-5.3 {base systemId publicId} {
1154    switch $publicId {
1155        "e1" {
1156            # Not well-formed
1157            set data "<e,1/>"
1158        }
1159        default {
1160            error "unknown public ID"
1161        }
1162    }
1163    return [list "string" $base $data]
1164}
1165test dom-5.3 {-externalentitycommand - nested external entities} -body {
1166    set result [catch {
1167        dom parse -externalentitycommand dom-5.3 \
1168            {<!DOCTYPE doc [
1169                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1170                            ]>
1171                <doc>&e1;</doc>}
1172    } msg]
1173    list $result $msg
1174} -result [list 1 {error "not well-formed (invalid token)" in entity "e1.xml" at line 1 character 2
1175"<e, <--Error-- 1/>", referenced at line 4 character 21}]
1176
1177proc dom-5.4 {base systemId publicId} {
1178    switch $publicId {
1179        "e1" {
1180            set data "<e1>&e2;</e1>"
1181        }
1182        "e2" {
1183            set data "<e,2/>"
1184        }
1185        default {
1186            error "unknown public ID"
1187        }
1188    }
1189    return [list "string" $base $data]
1190}
1191test dom-5.4 {-externalentitycommand - nested external entities} -body {
1192    set result [catch {
1193        dom parse -externalentitycommand dom-5.4 \
1194            {<!DOCTYPE doc [
1195                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1196                            <!ENTITY e2 PUBLIC "e2" "e2.xml">
1197                            ]>
1198                <doc>&e1;</doc>}
1199    } msg]
1200    list $result $msg
1201} -result [list 1 {error "not well-formed (invalid token)" in entity "e2.xml" at line 1 character 2
1202"<e, <--Error-- 2/>", referenced in entity "e1.xml" at line 1 character 4, referenced at line 5 character 21}]
1203
1204proc dom-5.5 {base systemId publicId} {
1205    switch $publicId {
1206        "e1" {
1207            set data "<e1>&e2;</e1>"
1208        }
1209        "e2" {
1210            set data "<e2>&e3;</e2>"
1211        }
1212        "e3" {
1213            # Not well-formed
1214            set data "<e,3/>"
1215        }
1216        default {
1217            error "unknown public ID"
1218        }
1219    }
1220    return [list "string" $base $data]
1221}
1222test dom-5.5 {-externalentitycommand - nested external entities} -body {
1223    set result [catch {
1224        dom parse -externalentitycommand dom-5.5 \
1225            {<!DOCTYPE doc [
1226                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1227                            <!ENTITY e2 PUBLIC "e2" "e2.xml">
1228                            <!ENTITY e3 PUBLIC "e3" "e3.xml">
1229                            ]>
1230                <doc>&e1;</doc>}
1231    } msg]
1232    list $result $msg
1233} -result [list 1 {error "not well-formed (invalid token)" in entity "e3.xml" at line 1 character 2
1234"<e, <--Error-- 3/>", referenced in entity "e2.xml" at line 1 character 4, referenced in entity "e1.xml" at line 1 character 4, referenced at line 6 character 21}]
1235
1236proc dom-5.6 {base systemId publicId} {
1237    switch $publicId {
1238        "e1" {
1239            set data [open $::e1]
1240        }
1241        default {
1242            error "unknown public ID"
1243        }
1244    }
1245    lappend ::openChannels $data
1246    return [list "channel" $base $data]
1247}
1248test dom-5.6 {-externalentitycommand - nested external entities} -setup {
1249    set e1 [makeFile "<e,1/>" e1.xml]
1250    set openChannels [list]
1251} -body {
1252    set result [catch {
1253        dom parse -externalentitycommand dom-5.6 \
1254            {<!DOCTYPE doc [
1255                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1256                            ]>
1257                <doc>&e1;</doc>}
1258    } msg]
1259    list $result $msg
1260} -cleanup {
1261    foreach channel $openChannels {close $channel}
1262    removeFile e1.xml
1263} -result [list 1 {error "not well-formed (invalid token)" in entity "e1.xml" at line 1 character 2, referenced at line 4 character 21}]
1264
1265proc dom-5.7 {base systemId publicId} {
1266    switch $publicId {
1267        "e1" {
1268            set data [open $::e1]
1269        }
1270        "e2" {
1271            set data [open $::e2]
1272        }
1273        default {
1274            error "unknown public ID"
1275        }
1276    }
1277    lappend ::openChannels $data
1278    return [list "channel" $base $data]
1279}
1280test dom-5.7 {-externalentitycommand - nested external entities} -setup {
1281    set e1 [makeFile "<e1>&e2;</e1>" e1.xml]
1282    set e2 [makeFile "<e,2/>" e2.xml]
1283    set openChannels [list]
1284} -body {
1285    set result [catch {
1286        dom parse -externalentitycommand dom-5.7 \
1287            {<!DOCTYPE doc [
1288                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1289                            <!ENTITY e2 PUBLIC "e2" "e2.xml">
1290                            ]>
1291                <doc>&e1;</doc>}
1292    } msg]
1293    list $result $msg
1294} -cleanup {
1295    foreach channel $openChannels {close $channel}
1296    removeFile e1.xml
1297    removeFile e2.xml
1298} -result [list 1 {error "not well-formed (invalid token)" in entity "e2.xml" at line 1 character 2, referenced in entity "e1.xml" at line 1 character 4, referenced at line 5 character 21}]
1299
1300proc dom-5.8 {base systemId publicId} {
1301    switch $publicId {
1302        "e1" {
1303            set data [open $::e1]
1304        }
1305        "e2" {
1306            set data [open $::e2]
1307        }
1308        "e3" {
1309            set data [open $::e3]
1310        }
1311        default {
1312            error "unknown public ID"
1313        }
1314    }
1315    lappend ::openChannels $data
1316    return [list "channel" $base $data]
1317}
1318test dom-5.8 {-externalentitycommand - nested external entities} -setup {
1319    set e1 [makeFile "<e1>&e2;</e1>" e1.xml]
1320    set e2 [makeFile "<e2>&e3;</e2>" e2.xml]
1321    set e3 [makeFile "<e,3/>" e3.xml]
1322    set openChannels [list]
1323} -body {
1324    set result [catch {
1325        dom parse -externalentitycommand dom-5.8 \
1326            {<!DOCTYPE doc [
1327                            <!ENTITY e1 PUBLIC "e1" "e1.xml">
1328                            <!ENTITY e2 PUBLIC "e2" "e2.xml">
1329                            <!ENTITY e3 PUBLIC "e3" "e3.xml">
1330                            ]>
1331                <doc>&e1;</doc>}
1332    } msg]
1333    list $result $msg
1334} -cleanup {
1335    foreach channel $openChannels {close $channel}
1336    removeFile e1.xml
1337    removeFile e2.xml
1338    removeFile e3.xml
1339} -result [list 1 {error "not well-formed (invalid token)" in entity "e3.xml" at line 1 character 2, referenced in entity "e2.xml" at line 1 character 4, referenced in entity "e1.xml" at line 1 character 4, referenced at line 6 character 21}]
1340
1341test dom-5.9 {Wrong option after -externalentitycommand} -body {
1342    set result [catch {dom parse -externalentitycommand ::tdom::extRefHandler \
1343                           -useForeignDTD foo}]
1344} -result 1
1345
1346test dom-6.1 {use in slave interpreter} {
1347    set slave [interp create]
1348    load {} tdom $slave
1349    interp eval $slave {
1350        dom parse <root>foo</root> doc
1351        $doc documentElement root
1352    }
1353    interp delete $slave
1354} {}
1355
1356test dom-6.2 {use in slave interpreter} {
1357    set slave [interp create]
1358    load {} tdom $slave
1359    interp eval $slave {
1360        set doc [dom parse <root>foo</root>]
1361        set root [$doc documentElement]
1362    }
1363    interp delete $slave
1364} {}
1365
1366test dom-7.1 {setNameCheck} {
1367    set result [dom setNameCheck]
1368    lappend result [dom setNameCheck 0]
1369    lappend result [dom setNameCheck]
1370    # set back to default
1371    lappend result [dom setNameCheck 1]
1372    set result
1373} {1 0 0 1}
1374
1375set doc [dom createDocument root]
1376# ensure, we've the default
1377dom setNameCheck 1
1378
1379test dom-7.2 {setNameCheck} {
1380    set result [catch {$doc createElement "invalid name"} errMsg]
1381    lappend result $errMsg
1382} {1 {Invalid tag name 'invalid name'}}
1383
1384test dom-7.3 {setNameCheck} {
1385    catch {$doc createElement "valid:name"}
1386} {0}
1387
1388test dom-7.4 {setNameCheck} {
1389    catch {$doc createElement "valid::name"}
1390} {0}
1391
1392test dom-7.5 {setNameCheck} {
1393    dom setNameCheck 0
1394    set result [catch {$doc createElement "invalid name"} errMsg]
1395    # set back to default
1396    dom setNameCheck 1
1397    set result
1398} {0}
1399
1400test dom-7.6 {setNameCheck} {
1401    set result [catch {$doc createElementNS "dummyns" "invalid name"} errMsg]
1402    lappend result $errMsg
1403} {1 {Invalid full qualified tag name 'invalid name'}}
1404
1405test dom-7.7 {setNameCheck} {
1406    catch {$doc createElementNS "dummyns" "valid:name"}
1407} {0}
1408
1409test dom-7.8 {setNameCheck} {
1410    set result [catch {$doc createElementNS "dummyns" "invalid::name"} errMsg]
1411    lappend result $errMsg
1412} {1 {Invalid full qualified tag name 'invalid::name'}}
1413
1414test dom-7.9 {setNameCheck} {
1415    dom setNameCheck 0
1416    set result [catch {$doc createElementNS "dummyns" "invalid name"} errMsg]
1417    # set back to default
1418    dom setNameCheck 1
1419    set result
1420} {0}
1421
1422test dom-7.10 {setTextCheck} {
1423    set result [catch {$doc createComment "valid comment"}]
1424    lappend result [catch {$doc createComment "invalid -- comment"}]
1425    dom setTextCheck 0
1426    lappend result [catch {$doc createComment "invalid -- comment"}]
1427    dom setTextCheck 1
1428    set result
1429} {0 1 0}
1430
1431test dom-7.11 {setTextCheck} {
1432    set result [catch {$doc createCDATASection "<valid/>"}]
1433    lappend result [catch {$doc createCDATASection "<invalid>]]></invalid"}]
1434    dom setTextCheck 0
1435    lappend result [catch {$doc createCDATASection "<invalid>]]></invalid"}]
1436    dom setTextCheck 1
1437    set result
1438} {0 1 0}
1439
1440test dom-7.12 {setTextCheck} {
1441    set result [catch {$doc createTextNode "data"}]
1442    lappend result [catch {$doc createTextNode "not XML \u0002 Char data"}]
1443    dom setTextCheck 0
1444    lappend result [catch {$doc createTextNode "not XML \u0002 Char data"}]
1445    dom setTextCheck 1
1446    set result
1447} {0 1 0}
1448
1449test dom-7.13 {setNameCheck} {
1450    set result [catch {$doc createProcessingInstruction "target" "data"}]
1451    lappend result [catch {$doc createProcessingInstruction "tar get" "data"}]
1452    lappend result [catch {$doc createProcessingInstruction "xMl" "data"}]
1453    dom setNameCheck 0
1454    lappend result [catch {$doc createProcessingInstruction "tar get" "data"}]
1455    lappend result [catch {$doc createProcessingInstruction "xMl" "data"}]
1456    dom setNameCheck 1
1457    set result
1458} {0 1 1 0 0}
1459
1460set root [$doc documentElement]
1461
1462test dom-7.14 {setNameCheck} {
1463    set result [catch {$root appendFromList {"a b" {} {}}} errMsg]
1464    lappend result $errMsg
1465    dom setNameCheck 0
1466    lappend result [catch {$root appendFromList {"a b" {} {}}}]
1467    dom setNameCheck 1
1468    set result
1469} {1 {Invalid tag name 'a b'} 0}
1470
1471test dom-7.15 {setNameCheck} {
1472    set result [catch {$root appendFromList {a {att1 "att1 value" "att 2" "att2 value"} {}}} errMsg]
1473    lappend result $errMsg
1474    dom setNameCheck 0
1475    lappend result [catch {$root appendFromList {a {att1 "att1 value" "att 2" "att2 value"} {}}}]
1476    dom setNameCheck 1
1477    set result
1478} {1 {Invalid attribute name 'att 2'} 0}
1479
1480test dom-7.16 {setTextCheck} {
1481    set result [catch {$root appendFromList {a {att1 "att1 value" "att2" "att2 value \u0002"} {}}} errMsg]
1482    lappend result $errMsg
1483    dom setTextCheck 0
1484    lappend result [catch {$root appendFromList {a {att1 "att1 value" "att2" "att2 value \u0002"} {}}}]
1485    dom setTextCheck 1
1486    set result
1487} [list 1 "Invalid attribute value 'att2 value \u0002'" 0]
1488
1489test dom-7.17 {setTextCheck} {
1490    set result [catch {$root appendFromList {\#text "foo \u0002"}} errMsg]
1491    lappend result $errMsg
1492    dom setTextCheck 0
1493    lappend result [catch {$root appendFromList {\#text "foo \u0002"}}]
1494    dom setTextCheck 1
1495    set result
1496} [list 1 "Invalid text value 'foo \u0002'" 0]
1497
1498$doc delete
1499
1500test dom-7.18 {setTextCheck and appendFromScript} {
1501    set doc [dom createDocumentNode]
1502    dom setTextCheck 0
1503    namespace eval nodeCmds {
1504        dom createNodeCmd elementNode doc
1505        dom createNodeCmd textNode t
1506    }
1507    $doc appendFromScript {
1508        nodeCmds::doc {
1509            nodeCmds::t "foo\u0003bar"
1510        }
1511    }
1512    dom setTextCheck 1
1513    set result [$doc asXML -indent none]
1514    $doc delete
1515    set result
1516} "<doc>foo\u0003bar</doc>"
1517
1518test dom-7.19 {setTextCheck and appendFromScript - setTextCheck state at create time is crucial} {
1519    set doc [dom createDocumentNode]
1520    namespace eval nodeCmds {
1521        dom createNodeCmd elementNode doc
1522        dom createNodeCmd textNode t
1523    }
1524    dom setTextCheck 0
1525    set result [catch {$doc appendFromScript {
1526        nodeCmds::doc {
1527            nodeCmds::t "foo\u0003bar"
1528        }
1529    }} errMsg]
1530    dom setTextCheck 1
1531    $doc delete
1532    lappend result $errMsg
1533} [list 1 "Invalid text value 'foo\u0003bar'"]
1534
1535test dom-7.19 {setNameCheck / createDocument} {
1536    dom setNameCheck 0
1537    dom createDocument "foo bar" doc
1538    set result [$doc asXML -indent none]
1539    $doc delete
1540    dom setNameCheck 1
1541    set result
1542} {<foo bar/>}
1543
1544
1545test dom-8.1 {createDocumentNode} {
1546    set result [catch {dom createDocumentNode foo bar}]
1547} {1}
1548
1549test dom-8.2 {createDocumentNode} {
1550    set docNode [dom createDocumentNode]
1551    set result [$docNode asXML -indent none]
1552    $docNode delete
1553    set result
1554} {}
1555
1556test dom-8.3 {createDocumentNode} {
1557    dom createDocumentNode docNode
1558    set result [$docNode asXML -indent none]
1559    $docNode delete
1560    set result
1561} {}
1562
1563test dom-8.4 {createDocumentNode} {
1564    set docNode [dom createDocumentNode]
1565    set result [$docNode nodeType]
1566    lappend result [$docNode documentElement]
1567    $docNode delete
1568    set result
1569} {DOCUMENT_NODE {}}
1570
1571test dom-8.5 {createDocumentNode} {
1572    set docNode [dom createDocumentNode]
1573    set newNode [$docNode createComment "Comment before the document node"]
1574    $docNode appendChild $newNode
1575    set result [[$docNode documentElement] nodeType]
1576    set newNode [$docNode createElement firstChild]
1577    $docNode appendChild $newNode
1578    lappend result [[$docNode documentElement] nodeName]
1579    set newNode [$docNode createElement secondChild]
1580    $docNode appendChild $newNode
1581    lappend result [[$docNode documentElement] nodeName]
1582    $docNode delete
1583    set result
1584} {COMMENT_NODE firstChild firstChild}
1585
1586test dom-8.6 {createDocumentNode} {
1587    set docNode [dom createDocumentNode]
1588    set doc [dom parse {<root><child1/><child2/>some text<child3/></root>}]
1589    set root [$doc documentElement]
1590    set listRep [$root asList]
1591    $doc delete
1592    $docNode appendFromList $listRep
1593    set result [$docNode asXML -indent none]
1594    $docNode delete
1595    set result
1596} {<root><child1/><child2/>some text<child3/></root>}
1597
1598test dom-8.7 {createDocumentNode} {
1599    dom createDocumentNode docNode
1600    dom createDocumentNode docNode
1601    $docNode delete
1602    set result ""
1603} ""
1604
1605test dom-8.8 {createDocumentNode} {
1606    dom createDocumentNode -jsonType ARRAY docNode
1607    set result [$docNode jsonType]
1608    $docNode delete
1609    set result
1610} ARRAY
1611
1612test dom-8.9 {createDocumentNode} {
1613    set docNode [dom createDocumentNode -jsonType NUMBER]
1614    set result [$docNode jsonType]
1615    $docNode delete
1616    set result
1617} NUMBER
1618
1619test dom-8.10 {createDocumentNode} {
1620    catch {dom createDocumentNode -foo NULL docNode} errMsg
1621    set errMsg
1622} {bad option "-foo": must be -jsonType}
1623
1624test dom-8.10 {createDocumentNode} {
1625    catch {dom createDocumentNode -foo NULL docNode} errMsg
1626    set errMsg
1627} {bad option "-foo": must be -jsonType}
1628
1629test dom-8.11 {createDocumentNode} {
1630    catch {dom createDocumentNode -jsonType FOO docNode} errMsg
1631    set errMsg
1632} {bad jsonType "FOO": must be NONE, ARRAY, OBJECT, NULL, TRUE, FALSE, STRING, or NUMBER}
1633
1634test dom-9.1 {setObjectCommands} {
1635    dom setObjectCommands
1636} {automatic}
1637
1638test dom-9.2 {setObjectCommands} {
1639    dom setObjectCommands automatic
1640} {automatic}
1641
1642test dom-9.3 {setObjectCommands} {
1643    set result [catch {dom setObjectCommands foobar} errMsg]
1644    lappend result $errMsg
1645} {1 {bad mode value "foobar": must be automatic, command, or token}}
1646
1647test dom-9.4 {setObjectCommands} {
1648    set nrOfCmds [llength [info commands]]
1649    dom setObjectCommands automatic
1650    set docNode [dom createDocumentNode]
1651    set result [expr {$nrOfCmds + 1 == [llength [info commands]]}]
1652    $docNode delete
1653    lappend result [expr {$nrOfCmds == [llength [info commands]]}]
1654    dom setObjectCommands token
1655    set docNode [dom createDocumentNode]
1656    lappend result [expr {$nrOfCmds == [llength [info commands]]}]
1657    lappend result [domDoc $docNode hasChildNodes]
1658    domDoc $docNode delete
1659    lappend result [expr {$nrOfCmds == [llength [info commands]]}]
1660    # switch back to default
1661    dom setObjectCommands automatic
1662    set result
1663} {1 1 1 0 1}
1664
1665test dom-9.5 {setObjectCommands} {
1666    dom setObjectCommands token
1667    set nrOfCmds [llength [info commands]]
1668    set doc [dom parse <root><child1/><child2/></root>]
1669    set root [domDoc $doc documentElement]
1670    set result [expr {$nrOfCmds == [llength [info commands]]}]
1671    dom setObjectCommands command
1672    set docCmd [domNode $root ownerDocument]
1673    lappend result [expr {$nrOfCmds + 1 == [llength [info commands]]}]
1674    $docCmd delete
1675    dom setObjectCommands automatic
1676    set result
1677} {1 1}
1678
1679test dom-9.6 {node token with result var argument} {
1680    dom setObjectCommands token
1681    set doc [dom parse <root><child1/><child2/></root>]
1682    domDoc $doc documentElement var
1683    domNode $var firstChild var
1684    domNode $var nextSibling var
1685    domDoc $doc delete
1686    dom setObjectCommands automatic
1687} {automatic}
1688
1689
1690test dom-9.7 {Attempt to use the token to an already freed node} {
1691    dom setObjectCommands token
1692    set doc [dom createDocument one]
1693    set top [domDoc $doc documentElement]
1694    set elem [domDoc $doc createElement one]
1695    domNode $elem delete
1696    set result [catch {domNode $elem asList} errMsg]
1697    lappend result $errMsg
1698    domDoc $doc delete
1699    dom setObjectCommands automatic
1700    set result
1701} {1 {Parameter "" is not a domNode.}}
1702
1703catch {namespace delete nodeCmds}
1704
1705namespace eval nodeCmds {
1706    dom createNodeCmd elementNode e1
1707    dom createNodeCmd elementNode e2
1708    dom createNodeCmd commentNode c
1709    dom createNodeCmd textNode    t
1710    dom createNodeCmd cdataNode   cdata
1711    dom createNodeCmd piNode      pi
1712    dom createNodeCmd parserNode  parser
1713    dom createNodeCmd -tagName foo elementNode bar
1714}
1715
1716test dom-10.1 {createNodeCmd} {
1717    llength [info commands nodeCmds::*]
1718} {8}
1719
1720namespace eval nodeCmds {
1721    rename e1 {}
1722    rename e2 {}
1723    rename c {}
1724    rename t {}
1725    rename cdata {}
1726    rename pi {}
1727    rename parser {}
1728    rename bar {}
1729}
1730
1731test dom-10.2 {createNodeCmd} {
1732    llength [info commands nodeCmds::*]
1733} {0}
1734
1735namespace eval nodeCmds {
1736    dom createNodeCmd elementNode e1
1737    dom createNodeCmd textNode    t
1738}
1739
1740test dom-10.3 {node creating command called outside domNode context} {
1741    set result [catch {nodeCmds::t "some text"} errMsg]
1742    lappend result $errMsg
1743} {1 {called outside domNode context}}
1744
1745test dom-10.4 {node creating command called outside domNode context} {
1746    dom createDocument docRoot doc
1747    $doc documentElement root
1748    $root appendFromScript {
1749        nodeCmds::t "Some text"
1750    }
1751    set result [list [$doc asXML -indent none]]
1752    $doc delete
1753    lappend result [catch {nodeCmds::t "Some text"} errMsg]
1754    lappend result $errMsg
1755} {{<docRoot>Some text</docRoot>} 1 {called outside domNode context}}
1756
1757test dom-10.5 {node creating command called outside domNode context} {
1758    dom createDocument docRoot doc
1759    $doc documentElement root
1760    $root appendFromScript {
1761        nodeCmds::e1 {
1762            nodeCmds::t "Some text"
1763        }
1764    }
1765    set result [list [$doc asXML -indent none]]
1766    $doc delete
1767    lappend result [catch {
1768        nodeCmds::e1 {
1769            nodeCmds::t "Some text"
1770        }} errMsg]
1771    lappend result $errMsg
1772} {{<docRoot><e1>Some text</e1></docRoot>} 1 {called outside domNode context}}
1773
1774namespace eval nodeCmds {
1775    dom createNodeCmd -tagName foo elementNode bar
1776}
1777test dom-10.6 {createNodeCmd - option -tagName} {
1778    set doc [dom createDocumentNode]
1779    $doc appendFromScript {
1780        nodeCmds::bar {}
1781    }
1782    set result [$doc asXML -indent none]
1783    $doc delete
1784    set result
1785} {<foo/>}
1786
1787namespace delete nodeCmds
1788
1789test dom-11.1 {featureinfo - expatversion} -body {
1790    dom featureinfo expatversion
1791} -match regexp -result {expat_.*}
1792
1793test dom-11.2 {featureinfo - invalid arg} -body {
1794    catch {dom featureinfo foo} errMsg
1795} -result 1
1796
1797test dom-11.3 {featureinfo - expatmajorversion} -body {
1798    dom featureinfo expatmajorversion
1799} -match regexp -result {(1|2)}
1800
1801test dom-11.4 {featureinfo - dtd} -body {
1802    dom featureinfo dtd
1803} -match regexp -result {(0|1)}
1804
1805test dom-11.5 {featureinfo - jsonmaxnesting} {
1806    dom featureinfo jsonmaxnesting
1807} 2000
1808
1809test dom-11.6 {featureinfo - versionhash} {
1810    regexp {^[0-9a-fA-F]+$} [dom featureinfo versionhash]
1811} 1
1812
1813proc ::dom::domParseFeedback {} {
1814    return -code break
1815}
1816test dom-12.1 {-feedbackAfter -- cmd returns TCL_BREAK} -body {
1817    dom parse -feedbackAfter 1 {<doc><e1/><e1/><e1/></doc>}
1818} -result ""
1819
1820proc ::dom::domParseFeedback {} {
1821    error "Error in feedback cmd."
1822}
1823test dom-12.2 {-feedbackAfter -- cmd returns TCL_ERROR} -body {
1824    set result [catch {
1825        dom parse -feedbackAfter 1 {<doc><e1/><e1/><e1/></doc>}
1826    } msg]
1827    list $result $msg
1828} -result [list 1 "Error in feedback cmd."]
1829
1830proc ::dom::domParseFeedback {} {
1831    # Update progess dialog, check for cancel etc.
1832    return
1833}
1834test dom-12.3 {-feedbackAfter} -body {
1835    set doc [dom parse -feedbackAfter 1 {<doc><e1/><e1/><e1/></doc>}]
1836    $doc selectNodes count(//*)
1837} -result 4
1838test dom-12.4 {-feedbackAfter and -channel} -setup {
1839    set xmlFile [makeFile {<doc><e1/><e1/><e1/></doc>} dom.xml]
1840} -body {
1841    set fd [open $xmlFile]
1842    set doc [dom parse -channel $fd -feedbackAfter 1]
1843    close $fd
1844    $doc selectNodes count(//*)
1845} -cleanup {
1846    removeFile dom.xml
1847} -result 4
1848proc extRefResolver-12.5 {base systemId publicId} {
1849    switch $publicId {
1850        "a" {
1851            set data "<e1/>"
1852        }
1853        "b" {
1854            set data "<e1/><e1/>"
1855        }
1856        default {
1857            error "unknown public ID"
1858        }
1859    }
1860    return [list "string" $base $data]
1861}
1862test dom-12.5 {-feedbackAfter and external entities} -body {
1863    set doc [dom parse -externalentitycommand extRefResolver-12.5 \
1864                 -feedbackAfter 1 {
1865                     <!DOCTYPE doc [
1866                                    <!ENTITY a PUBLIC "a" "a.xml">
1867                                    <!ENTITY b PUBLIC "b" "b.xml">
1868                                    ]>
1869                     <doc>&a;&b;</doc>}]
1870    $doc selectNodes count(//*)
1871} -result 4
1872
1873set cancel 0
1874proc extRefResolver-12.6 {base systemId publicId} {
1875    global cancel
1876    switch $publicId {
1877        "a" {
1878            set cancel 1
1879            set data "<e1/><e1/>"
1880        }
1881        "b" {
1882            set data "<e1/>"
1883        }
1884        default {
1885            error "unknown public ID"
1886        }
1887    }
1888    return [list "string" $base $data]
1889}
1890proc ::dom::domParseFeedback {} {
1891    global cancel
1892    if {$cancel} {
1893        return -code break
1894    }
1895}
1896test dom-12.6 {-feedbackAfter and external entities, with cancel} -body {
1897    dom parse -externalentitycommand extRefResolver-12.6 \
1898        -feedbackAfter 1 {
1899            <!DOCTYPE doc [
1900                           <!ENTITY a PUBLIC "a" "a.xml">
1901                           <!ENTITY b PUBLIC "b" "b.xml">
1902                          ]>
1903            <doc>&a;&b;</doc>}
1904} -result ""
1905proc ::dom::domParseFeedback {} {
1906    global cancel
1907    if {$cancel} {
1908        error "Error in feedback cmd."
1909    }
1910}
1911test dom-12.7 {-feedbackAfter and external entities, with error} -body {
1912    set result [catch {dom parse -externalentitycommand extRefResolver-12.6 \
1913                           -feedbackAfter 1 {
1914                               <!DOCTYPE doc [
1915                                              <!ENTITY a PUBLIC "a" "a.xml">
1916                                              <!ENTITY b PUBLIC "b" "b.xml">
1917                                             ]>
1918                               <doc>&a;&b;</doc>}} msg]
1919    list $result $msg
1920} -result [list 1 "Error in feedback cmd."]
1921
1922test dom-12.8 {-feedbackAfter without -feedbackcmd} -setup {
1923    catch {rename ::dom::domParseFeedback ""}
1924} -body {
1925    set result [catch {dom parse -feedbackAfter 100 <doc/>} msg]
1926    list $result $msg
1927} -result {1 {If -feedbackAfter is used, -feedbackcmd must also be used.}}
1928
1929proc feedbackcmd-12.9 {} {
1930    return -code break
1931}
1932test dom-12.9 {-feedbackAfter with -feedbackcmd -- cmd returns TCL_BREAK} -body {
1933    dom parse -feedbackAfter 1 -feedbackcmd feedbackcmd-12.9 \
1934        {<doc><e1/><e1/><e1/></doc>}
1935} -result ""
1936
1937proc feedbackcmd-12.10 {} {
1938    error "Error in feedback cmd."
1939}
1940test dom-12.10 {-feedbackAfter with -feedbackcmd -- cmd returns TCL_ERROR} -body {
1941    set result [catch {
1942        dom parse -feedbackAfter 1 -feedbackcmd feedbackcmd-12.10 \
1943            {<doc><e1/><e1/><e1/></doc>}
1944    } msg]
1945    list $result $msg
1946} -result [list 1 "Error in feedback cmd."]
1947
1948proc feedbackcmd-12.11 {} {
1949    # Update progess dialog, check for cancel etc.
1950    return
1951}
1952test dom-12.11 {-feedbackAfter with -feedbackcmd} -body {
1953    set doc [dom parse -feedbackAfter 1 -feedbackcmd feedbackcmd-12.11 \
1954                 {<doc><e1/><e1/><e1/></doc>}]
1955    $doc selectNodes count(//*)
1956} -result 4
1957test dom-12.12 {-feedbackAfter with -feedbackcmd and -channel} -setup {
1958    set xmlFile [makeFile {<doc><e1/><e1/><e1/></doc>} dom.xml]
1959} -body {
1960    set fd [open $xmlFile]
1961    set doc [dom parse -channel $fd -feedbackAfter 1 \
1962                 -feedbackcmd feedbackcmd-12.11]
1963    close $fd
1964    $doc selectNodes count(//*)
1965} -cleanup {
1966    removeFile dom.xml
1967} -result 4
1968test dom-12.13 {-feedbackAfter with -feedbackcmd and external entities} -body {
1969    set doc [dom parse -externalentitycommand extRefResolver-12.5 \
1970                 -feedbackcmd feedbackcmd-12.11 \
1971                 -feedbackAfter 1 {
1972                     <!DOCTYPE doc [
1973                                    <!ENTITY a PUBLIC "a" "a.xml">
1974                                    <!ENTITY b PUBLIC "b" "b.xml">
1975                                    ]>
1976                     <doc>&a;&b;</doc>}]
1977    $doc selectNodes count(//*)
1978} -result 4
1979
1980set cancel 0
1981proc feedbackcmd-12.14 {} {
1982    global cancel
1983    if {$cancel} {
1984        return -code break
1985    }
1986}
1987test dom-12.14 {-feedbackAfter with -feedbackcmd and external entities, with cancel} -body {
1988    dom parse -externalentitycommand extRefResolver-12.6 \
1989        -feedbackcmd feedbackcmd-12.14 \
1990        -feedbackAfter 1 {
1991            <!DOCTYPE doc [
1992                           <!ENTITY a PUBLIC "a" "a.xml">
1993                           <!ENTITY b PUBLIC "b" "b.xml">
1994                          ]>
1995            <doc>&a;&b;</doc>}
1996} -result ""
1997set cancel 0
1998proc feedbackcmd-12.15 {} {
1999    global cancel
2000    if {$cancel} {
2001        error "Error in feedback cmd."
2002    }
2003}
2004test dom-12.15 {-feedbackAfter with -feedbackcmd and external entities, with error} -body {
2005    set result [catch {dom parse -externalentitycommand extRefResolver-12.6 \
2006                           -feedbackcmd feedbackcmd-12.15 \
2007                           -feedbackAfter 1 {
2008                               <!DOCTYPE doc [
2009                                              <!ENTITY a PUBLIC "a" "a.xml">
2010                                              <!ENTITY b PUBLIC "b" "b.xml">
2011                                             ]>
2012                               <doc>&a;&b;</doc>}} msg]
2013    list $result $msg
2014} -result [list 1 "Error in feedback cmd."]
2015proc feedbackcmd-12.16 {} {
2016    incr ::feedbackcmd-12.16
2017}
2018test dom-12.16 {-feedbackcmd setting interp result w/ invalid XML} -body {
2019    set ::feedbackcmd-12.16 0
2020    set result [catch {dom parse -feedbackcmd feedbackcmd-12.16 \
2021                           -feedbackAfter 1 {<doc><e1/><e1/><e1></doc}} msg]
2022    list $result $msg
2023} -result [list 1 {error "unclosed token" at line 1 character 19
2024"<doc><e1/><e1/><e1>< <--Error-- /doc"}]
2025
2026# cleanup
2027::tcltest::cleanupTests
2028return
2029