1#---------------------------------------------------------------------------- 2# Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com) 3#---------------------------------------------------------------------------- 4# 5# $Id: tdom.tcl,v 1.20 2008/05/24 21:59:58 rolf Exp $ 6# 7# 8# The higher level functions of tDOM written in plain Tcl. 9# 10# 11# The contents of this file are subject to the Mozilla Public License 12# Version 1.1 (the "License"); you may not use this file except in 13# compliance with the License. You may obtain a copy of the License at 14# http://www.mozilla.org/MPL/ 15# 16# Software distributed under the License is distributed on an "AS IS" 17# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the 18# License for the specific language governing rights and limitations 19# under the License. 20# 21# The Original Code is tDOM. 22# 23# The Initial Developer of the Original Code is Jochen Loewer 24# Portions created by Jochen Loewer are Copyright (C) 1998, 1999 25# Jochen Loewer. All Rights Reserved. 26# 27# Contributor(s): 28# Rolf Ade (rolf@pointsman.de): 'fake' nodelists/live childNodes 29# 30# written by Jochen Loewer 31# April, 1999 32# 33#---------------------------------------------------------------------------- 34 35package require tdom 36 37#---------------------------------------------------------------------------- 38# setup namespaces for additional Tcl level methods, etc. 39# 40#---------------------------------------------------------------------------- 41namespace eval ::dom { 42 namespace eval domDoc { 43 } 44 namespace eval domNode { 45 } 46 namespace eval DOMImplementation { 47 } 48 namespace eval xpathFunc { 49 } 50 namespace eval xpathFuncHelper { 51 } 52} 53 54namespace eval ::tDOM { 55 variable extRefHandlerDebug 0 56 variable useForeignDTD "" 57 58 namespace export xmlOpenFile xmlReadFile extRefHandler baseURL 59} 60 61#---------------------------------------------------------------------------- 62# hasFeature (DOMImplementation method) 63# 64# 65# @in url the URL, where to get the XML document 66# 67# @return document object 68# @exception XML parse errors, ... 69# 70#---------------------------------------------------------------------------- 71proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } { 72 73 switch $feature { 74 xml - 75 XML { 76 if {($version == "") || ($version == "1.0")} { 77 return 1 78 } 79 } 80 } 81 return 0 82 83} 84 85#---------------------------------------------------------------------------- 86# load (DOMImplementation method) 87# 88# requests a XML document via http using the given URL and 89# builds up a DOM tree in memory returning the document object 90# 91# 92# @in url the URL, where to get the XML document 93# 94# @return document object 95# @exception XML parse errors, ... 96# 97#---------------------------------------------------------------------------- 98proc ::dom::DOMImplementation::load { dom url } { 99 100 error "Sorry, load method not implemented yet!" 101 102} 103 104#---------------------------------------------------------------------------- 105# isa (docDoc method, for [incr tcl] compatibility) 106# 107# 108# @in className 109# 110# @return 1 iff inherits from the given class 111# 112#---------------------------------------------------------------------------- 113proc ::dom::domDoc::isa { doc className } { 114 115 if {$className == "domDoc"} { 116 return 1 117 } 118 return 0 119} 120 121#---------------------------------------------------------------------------- 122# info (domDoc method, for [incr tcl] compatibility) 123# 124# 125# @in subcommand 126# @in args 127# 128#---------------------------------------------------------------------------- 129proc ::dom::domDoc::info { doc subcommand args } { 130 131 switch $subcommand { 132 class { 133 return "domDoc" 134 } 135 inherit { 136 return "" 137 } 138 heritage { 139 return "domDoc {}" 140 } 141 default { 142 error "domDoc::info subcommand $subcommand not yet implemented!" 143 } 144 } 145} 146 147#---------------------------------------------------------------------------- 148# importNode (domDoc method) 149# 150# Document Object Model (Core) Level 2 method 151# 152# 153# @in subcommand 154# @in args 155# 156#---------------------------------------------------------------------------- 157proc ::dom::domDoc::importNode { doc importedNode deep } { 158 159 if {$deep || ($deep == "-deep")} { 160 set node [$importedNode cloneNode -deep] 161 } else { 162 set node [$importedNode cloneNode] 163 } 164 return $node 165} 166 167#---------------------------------------------------------------------------- 168# isa (domNode method, for [incr tcl] compatibility) 169# 170# 171# @in className 172# 173# @return 1 iff inherits from the given class 174# 175#---------------------------------------------------------------------------- 176proc ::dom::domNode::isa { doc className } { 177 178 if {$className == "domNode"} { 179 return 1 180 } 181 return 0 182} 183 184#---------------------------------------------------------------------------- 185# info (domNode method, for [incr tcl] compatibility) 186# 187# 188# @in subcommand 189# @in args 190# 191#---------------------------------------------------------------------------- 192proc ::dom::domNode::info { doc subcommand args } { 193 194 switch $subcommand { 195 class { 196 return "domNode" 197 } 198 inherit { 199 return "" 200 } 201 heritage { 202 return "domNode {}" 203 } 204 default { 205 error "domNode::info subcommand $subcommand not yet implemented!" 206 } 207 } 208} 209 210#---------------------------------------------------------------------------- 211# isWithin (domNode method) 212# 213# tests, whether a node object is nested below another tag 214# 215# 216# @in tagName the nodeName of an elment node 217# 218# @return 1 iff node is nested below a element with nodeName tagName 219# 0 otherwise 220# 221#---------------------------------------------------------------------------- 222proc ::dom::domNode::isWithin { node tagName } { 223 224 while {[$node parentNode] != ""} { 225 set node [$node parentNode] 226 if {[$node nodeName] == $tagName} { 227 return 1 228 } 229 } 230 return 0 231} 232 233#---------------------------------------------------------------------------- 234# tagName (domNode method) 235# 236# same a nodeName for element interface 237# 238#---------------------------------------------------------------------------- 239proc ::dom::domNode::tagName { node } { 240 241 if {[$node nodeType] == "ELEMENT_NODE"} { 242 return [$node nodeName] 243 } 244 return -code error "NOT_SUPPORTED_ERR not an element!" 245} 246 247#---------------------------------------------------------------------------- 248# simpleTranslate (domNode method) 249# 250# applies simple translation rules similar to Cost's simple 251# translations to a node 252# 253# 254# @in output_var 255# @in trans_specs 256# 257#---------------------------------------------------------------------------- 258proc ::dom::domNode::simpleTranslate { node output_var trans_specs } { 259 260 upvar $output_var output 261 262 if {[$node nodeType] == "TEXT_NODE"} { 263 append output [cgiQuote [$node nodeValue]] 264 return 265 } 266 set found 0 267 268 foreach {match action} $trans_specs { 269 270 if {[catch { 271 if {!$found && ([$node selectNode self::$match] != "") } { 272 set found 1 273 } 274 } err]} { 275 if {![string match "NodeSet expected for parent axis!" $err]} { 276 error $err 277 } 278 } 279 if {$found && ($action != "-")} { 280 set stop 0 281 foreach {type value} $action { 282 switch $type { 283 prefix { append output [subst $value] } 284 tag { append output <$value> } 285 start { append output [eval $value] } 286 stop { set stop 1 } 287 } 288 } 289 if {!$stop} { 290 foreach child [$node childNodes] { 291 simpleTranslate $child output $trans_specs 292 } 293 } 294 foreach {type value} $action { 295 switch $type { 296 suffix { append output [subst $value] } 297 end { append output [eval $value] } 298 tag { append output </$value> } 299 } 300 } 301 return 302 } 303 } 304 foreach child [$node childNodes] { 305 simpleTranslate $child output $trans_specs 306 } 307} 308 309#---------------------------------------------------------------------------- 310# a DOM conformant 'live' childNodes 311# 312# @return a 'nodelist' object (it is just the normal node) 313# 314#---------------------------------------------------------------------------- 315proc ::dom::domNode::childNodesLive { node } { 316 317 return $node 318} 319 320#---------------------------------------------------------------------------- 321# item method on a 'nodelist' object 322# 323# @return a 'nodelist' object (it is just a normal 324# 325#---------------------------------------------------------------------------- 326proc ::dom::domNode::item { nodeListNode index } { 327 328 return [lindex [$nodeListNode childNodes] $index] 329} 330 331#---------------------------------------------------------------------------- 332# length method on a 'nodelist' object 333# 334# @return a 'nodelist' object (it is just a normal 335# 336#---------------------------------------------------------------------------- 337proc ::dom::domNode::length { nodeListNode } { 338 339 return [llength [$nodeListNode childNodes]] 340} 341 342#---------------------------------------------------------------------------- 343# appendData on a 'CharacterData' object 344# 345#---------------------------------------------------------------------------- 346proc ::dom::domNode::appendData { node arg } { 347 348 set type [$node nodeType] 349 if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 350 ($type != "COMMENT_NODE") 351 } { 352 return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 353 } 354 set oldValue [$node nodeValue] 355 $node nodeValue [append oldValue $arg] 356} 357 358#---------------------------------------------------------------------------- 359# deleteData on a 'CharacterData' object 360# 361#---------------------------------------------------------------------------- 362proc ::dom::domNode::deleteData { node offset count } { 363 364 set type [$node nodeType] 365 if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 366 ($type != "COMMENT_NODE") 367 } { 368 return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 369 } 370 incr offset -1 371 set before [string range [$node nodeValue] 0 $offset] 372 incr offset 373 incr offset $count 374 set after [string range [$node nodeValue] $offset end] 375 $node nodeValue [append before $after] 376} 377 378#---------------------------------------------------------------------------- 379# insertData on a 'CharacterData' object 380# 381#---------------------------------------------------------------------------- 382proc ::dom::domNode::insertData { node offset arg } { 383 384 set type [$node nodeType] 385 if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 386 ($type != "COMMENT_NODE") 387 } { 388 return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 389 } 390 incr offset -1 391 set before [string range [$node nodeValue] 0 $offset] 392 incr offset 393 set after [string range [$node nodeValue] $offset end] 394 $node nodeValue [append before $arg $after] 395} 396 397#---------------------------------------------------------------------------- 398# replaceData on a 'CharacterData' object 399# 400#---------------------------------------------------------------------------- 401proc ::dom::domNode::replaceData { node offset count arg } { 402 403 set type [$node nodeType] 404 if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 405 ($type != "COMMENT_NODE") 406 } { 407 return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 408 } 409 incr offset -1 410 set before [string range [$node nodeValue] 0 $offset] 411 incr offset 412 incr offset $count 413 set after [string range [$node nodeValue] $offset end] 414 $node nodeValue [append before $arg $after] 415} 416 417#---------------------------------------------------------------------------- 418# substringData on a 'CharacterData' object 419# 420# @return part of the node value (text) 421# 422#---------------------------------------------------------------------------- 423proc ::dom::domNode::substringData { node offset count } { 424 425 set type [$node nodeType] 426 if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 427 ($type != "COMMENT_NODE") 428 } { 429 return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 430 } 431 set endOffset [expr $offset + $count - 1] 432 return [string range [$node nodeValue] $offset $endOffset] 433} 434 435#---------------------------------------------------------------------------- 436# coerce2number 437# 438#---------------------------------------------------------------------------- 439proc ::dom::xpathFuncHelper::coerce2number { type value } { 440 switch $type { 441 empty { return 0 } 442 number - 443 string { return $value } 444 attrvalues { return [lindex $value 0] } 445 nodes { return [[lindex $value 0] selectNodes number()] } 446 attrnodes { return [lindex $value 1] } 447 } 448} 449 450#---------------------------------------------------------------------------- 451# coerce2string 452# 453#---------------------------------------------------------------------------- 454proc ::dom::xpathFuncHelper::coerce2string { type value } { 455 switch $type { 456 empty { return "" } 457 number - 458 string { return $value } 459 attrvalues { return [lindex $value 0] } 460 nodes { return [[lindex $value 0] selectNodes string()] } 461 attrnodes { return [lindex $value 1] } 462 } 463} 464 465#---------------------------------------------------------------------------- 466# function-available 467# 468#---------------------------------------------------------------------------- 469proc ::dom::xpathFunc::function-available { ctxNode pos 470 nodeListType nodeList args} { 471 472 if {[llength $args] != 2} { 473 error "function-available(): wrong # of args!" 474 } 475 foreach { arg1Typ arg1Value } $args break 476 set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 477 switch $str { 478 boolean - 479 ceiling - 480 concat - 481 contains - 482 count - 483 current - 484 document - 485 element-available - 486 false - 487 floor - 488 format-number - 489 generate-id - 490 id - 491 key - 492 last - 493 lang - 494 local-name - 495 name - 496 namespace-uri - 497 normalize-space - 498 not - 499 number - 500 position - 501 round - 502 starts-with - 503 string - 504 string-length - 505 substring - 506 substring-after - 507 substring-before - 508 sum - 509 translate - 510 true - 511 unparsed-entity-uri { 512 return [list bool true] 513 } 514 default { 515 set TclXpathFuncs [info procs ::dom::xpathFunc::*] 516 if {[lsearch -exact $TclXpathFuncs $str] != -1} { 517 return [list bool true] 518 } else { 519 return [list bool false] 520 } 521 } 522 } 523} 524 525#---------------------------------------------------------------------------- 526# element-available 527# 528# This is not strictly correct. The XSLT namespace may be bound 529# to another prefix (and the prefix 'xsl' may be bound to another 530# namespace). Since the expression context isn't available at the 531# moment at tcl coded XPath functions, this couldn't be done better 532# than this "works in the 'normal' cases" version. 533#---------------------------------------------------------------------------- 534proc ::dom::xpathFunc::element-available { ctxNode pos 535 nodeListType nodeList args} { 536 537 if {[llength $args] != 2} { 538 error "element-available(): wrong # of args!" 539 } 540 foreach { arg1Typ arg1Value } $args break 541 set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 542 # The XSLT recommendation says: "The element-available 543 # function returns true if and only if the expanded-name 544 # is the name of an instruction." The following xsl 545 # elements are not in the category instruction. 546 # xsl:attribute-set 547 # xsl:decimal-format 548 # xsl:include 549 # xsl:key 550 # xsl:namespace-alias 551 # xsl:output 552 # xsl:param 553 # xsl:strip-space 554 # xsl:preserve-space 555 # xsl:template 556 # xsl:import 557 # xsl:otherwise 558 # xsl:sort 559 # xsl:stylesheet 560 # xsl:transform 561 # xsl:with-param 562 # xsl:when 563 switch $str { 564 xsl:apply-templates - 565 xsl:apply-imports - 566 xsl:call-template - 567 xsl:element - 568 xsl:attribute - 569 xsl:text - 570 xsl:processing-instruction - 571 xsl:comment - 572 xsl:copy - 573 xsl:value-of - 574 xsl:number - 575 xsl:for-each - 576 xsl:if - 577 xsl:choose - 578 xsl:variable - 579 xsl:copy-of - 580 xsl:message - 581 xsl:fallback { 582 return [list bool true] 583 } 584 default { 585 return [list bool false] 586 } 587 } 588} 589 590#---------------------------------------------------------------------------- 591# system-property 592# 593# This is not strictly correct. The XSLT namespace may be bound 594# to another prefix (and the prefix 'xsl' may be bound to another 595# namespace). Since the expression context isn't available at the 596# moment at tcl coded XPath functions, this couldn't be done better 597# than this "works in the 'normal' cases" version. 598#---------------------------------------------------------------------------- 599proc ::dom::xpathFunc::system-property { ctxNode pos 600 nodeListType nodeList args } { 601 602 if {[llength $args] != 2} { 603 error "system-property(): wrong # of args!" 604 } 605 foreach { arg1Typ arg1Value } $args break 606 set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 607 switch $str { 608 xsl:version { 609 return [list number 1.0] 610 } 611 xsl:vendor { 612 return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."] 613 } 614 xsl:vendor-url { 615 return [list string "http://www.tdom.org"] 616 } 617 default { 618 return [list string ""] 619 } 620 } 621} 622 623#---------------------------------------------------------------------------- 624# IANAEncoding2TclEncoding 625# 626#---------------------------------------------------------------------------- 627 628# As of version 8.3.4 tcl supports 629# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949 630# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201 631# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp 632# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737 633# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr 634# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic 635# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6 636# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253 637# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852 638# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode 639# cp857 640# 641# Just add more mappings (and mail them to the tDOM mailing list, please). 642 643proc tDOM::IANAEncoding2TclEncoding {IANAName} { 644 645 # First the most widespread encodings with there 646 # preferred MIME name, to speed lookup in this 647 # usual cases. Later the official names and the 648 # aliases. 649 # 650 # For "official names for character sets that may be 651 # used in the Internet" see 652 # http://www.iana.org/assignments/character-sets 653 # (that's the source for the encoding names below) 654 # 655 # Matching is case-insensitive 656 657 switch [string tolower $IANAName] { 658 "us-ascii" {return ascii} 659 "utf-8" {return utf-8} 660 "utf-16" {return unicode; # not sure about this} 661 "iso-8859-1" {return iso8859-1} 662 "iso-8859-2" {return iso8859-2} 663 "iso-8859-3" {return iso8859-3} 664 "iso-8859-4" {return iso8859-4} 665 "iso-8859-5" {return iso8859-5} 666 "iso-8859-6" {return iso8859-6} 667 "iso-8859-7" {return iso8859-7} 668 "iso-8859-8" {return iso8859-8} 669 "iso-8859-9" {return iso8859-9} 670 "iso-8859-10" {return iso8859-10} 671 "iso-8859-13" {return iso8859-13} 672 "iso-8859-14" {return iso8859-14} 673 "iso-8859-15" {return iso8859-15} 674 "iso-8859-16" {return iso8859-16} 675 "iso-2022-kr" {return iso2022-kr} 676 "euc-kr" {return euc-kr} 677 "iso-2022-jp" {return iso2022-jp} 678 "koi8-r" {return koi8-r} 679 "shift_jis" {return shiftjis} 680 "euc-jp" {return euc-jp} 681 "gb2312" {return gb2312} 682 "big5" {return big5} 683 "cp866" {return cp866} 684 "cp1250" {return cp1250} 685 "cp1253" {return cp1253} 686 "cp1254" {return cp1254} 687 "cp1255" {return cp1255} 688 "cp1256" {return cp1256} 689 "cp1257" {return cp1257} 690 691 "windows-1251" - 692 "cp1251" {return cp1251} 693 694 "windows-1252" - 695 "cp1252" {return cp1252} 696 697 "iso_8859-1:1987" - 698 "iso-ir-100" - 699 "iso_8859-1" - 700 "latin1" - 701 "l1" - 702 "ibm819" - 703 "cp819" - 704 "csisolatin1" {return iso8859-1} 705 706 "iso_8859-2:1987" - 707 "iso-ir-101" - 708 "iso_8859-2" - 709 "iso-8859-2" - 710 "latin2" - 711 "l2" - 712 "csisolatin2" {return iso8859-2} 713 714 "iso_8859-5:1988" - 715 "iso-ir-144" - 716 "iso_8859-5" - 717 "iso-8859-5" - 718 "cyrillic" - 719 "csisolatincyrillic" {return iso8859-5} 720 721 "ms_kanji" - 722 "csshiftjis" {return shiftjis} 723 724 "csiso2022kr" {return iso2022-kr} 725 726 "ibm866" - 727 "csibm866" {return cp866} 728 729 default { 730 # There are much more encoding names out there 731 # It's only laziness, that let me stop here. 732 error "Unrecognized encoding name '$IANAName'" 733 } 734 } 735} 736 737#---------------------------------------------------------------------------- 738# xmlOpenFile 739# 740#---------------------------------------------------------------------------- 741proc tDOM::xmlOpenFile {filename {encodingString {}}} { 742 743 set fd [open $filename] 744 745 if {$encodingString != {}} { 746 upvar $encodingString encString 747 } 748 749 # The autodetection of the encoding follows 750 # XML Recomendation, Appendix F 751 752 fconfigure $fd -encoding binary 753 if {![binary scan [read $fd 4] "H8" firstBytes]} { 754 # very short (< 4 Bytes) file 755 seek $fd 0 start 756 set encString UTF-8 757 return $fd 758 } 759 760 # First check for BOM 761 switch [string range $firstBytes 0 3] { 762 "feff" - 763 "fffe" { 764 # feff: UTF-16, big-endian BOM 765 # ffef: UTF-16, little-endian BOM 766 seek $fd 0 start 767 set encString UTF-16 768 fconfigure $fd -encoding identity 769 return $fd 770 } 771 } 772 773 # If the entity has a XML Declaration, the first four characters 774 # must be "<?xm". 775 switch $firstBytes { 776 "3c3f786d" { 777 # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS, 778 # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 779 # ensures that the characters of ASCII have their normal positions, 780 # width and values; the actual encoding declaration must be read to 781 # detect which of these applies, but since all of these encodings 782 # use the same bit patterns for the ASCII characters, the encoding 783 # declaration itself be read reliably. 784 785 # First 300 bytes should be enough for a XML Declaration 786 # This is of course not 100 percent bullet-proof. 787 set head [read $fd 296] 788 789 # Try to find the end of the XML Declaration 790 set closeIndex [string first ">" $head] 791 if {$closeIndex == -1} { 792 error "Weird XML data or not XML data at all" 793 } 794 795 seek $fd 0 start 796 set xmlDeclaration [read $fd [expr {$closeIndex + 5}]] 797 # extract the encoding information 798 set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]} 799 # emacs: " 800 if {![regexp $pattern $head - encStr]} { 801 # Probably something like <?xml version="1.0"?>. 802 # Without encoding declaration this must be UTF-8 803 set encoding utf-8 804 set encString UTF-8 805 } else { 806 set encoding [IANAEncoding2TclEncoding $encStr] 807 set encString $encStr 808 } 809 } 810 "0000003c" - 811 "0000003c" - 812 "3c000000" - 813 "00003c00" { 814 # UCS-4 815 error "UCS-4 not supported" 816 } 817 "003c003f" - 818 "3c003f00" { 819 # UTF-16, big-endian, no BOM 820 # UTF-16, little-endian, no BOM 821 seek $fd 0 start 822 set encoding identity 823 set encString UTF-16 824 } 825 "4c6fa794" { 826 # EBCDIC in some flavor 827 error "EBCDIC not supported" 828 } 829 default { 830 # UTF-8 without an encoding declaration 831 seek $fd 0 start 832 set encoding identity 833 set encString "UTF-8" 834 } 835 } 836 fconfigure $fd -encoding $encoding 837 return $fd 838} 839 840#---------------------------------------------------------------------------- 841# xmlReadFile 842# 843#---------------------------------------------------------------------------- 844proc tDOM::xmlReadFile {filename {encodingString {}}} { 845 846 if {$encodingString != {}} { 847 upvar $encodingString encString 848 } 849 850 set fd [xmlOpenFile $filename encString] 851 set data [read $fd [file size $filename]] 852 close $fd 853 return $data 854} 855 856#---------------------------------------------------------------------------- 857# extRefHandler 858# 859# A very simple external entity resolver, included for convenience. 860# Depends on the tcllib package uri and resolves only file URLs. 861# 862#---------------------------------------------------------------------------- 863 864if {![catch {package require uri}]} { 865 proc tDOM::extRefHandler {base systemId publicId} { 866 variable extRefHandlerDebug 867 variable useForeignDTD 868 869 if {$extRefHandlerDebug} { 870 puts stderr "tDOM::extRefHandler called with:" 871 puts stderr "\tbase: '$base'" 872 puts stderr "\tsystemId: '$systemId'" 873 puts stderr "\tpublicId: '$publicId'" 874 } 875 if {$systemId == ""} { 876 if {$useForeignDTD != ""} { 877 set systemId $useForeignDTD 878 } else { 879 error "::tDOM::useForeignDTD does\ 880 not point to the foreign DTD" 881 } 882 } 883 set absolutURI [uri::resolve $base $systemId] 884 array set uriData [uri::split $absolutURI] 885 switch $uriData(scheme) { 886 file { 887 return [list string $absolutURI [xmlReadFile $uriData(path)]] 888 } 889 default { 890 error "can only handle file URI's" 891 } 892 } 893 } 894} 895 896#---------------------------------------------------------------------------- 897# baseURL 898# 899# A simple convenience proc which returns an absolute URL for a given 900# filename. 901# 902#---------------------------------------------------------------------------- 903 904proc tDOM::baseURL {path} { 905 switch [file pathtype $path] { 906 "relative" { 907 return "file://[pwd]/$path" 908 } 909 default { 910 return "file://$path" 911 } 912 } 913} 914 915# EOF 916