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