912 lines
27 KiB
Tcl
912 lines
27 KiB
Tcl
#----------------------------------------------------------------------------
|
|
# Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
|
|
#----------------------------------------------------------------------------
|
|
#
|
|
# $Id: tdom.tcl,v 1.19 2005/01/11 15:57:19 rolf Exp $
|
|
#
|
|
#
|
|
# The higher level functions of tDOM written in plain Tcl.
|
|
#
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public License
|
|
# Version 1.1 (the "License"); you may not use this file except in
|
|
# compliance with the License. You may obtain a copy of the License at
|
|
# http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS"
|
|
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
|
|
# License for the specific language governing rights and limitations
|
|
# under the License.
|
|
#
|
|
# The Original Code is tDOM.
|
|
#
|
|
# The Initial Developer of the Original Code is Jochen Loewer
|
|
# Portions created by Jochen Loewer are Copyright (C) 1998, 1999
|
|
# Jochen Loewer. All Rights Reserved.
|
|
#
|
|
# Contributor(s):
|
|
# Rolf Ade (rolf@pointsman.de): 'fake' nodelists/live childNodes
|
|
#
|
|
# written by Jochen Loewer
|
|
# April, 1999
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
|
|
package require tdom
|
|
|
|
#----------------------------------------------------------------------------
|
|
# setup namespaces for additional Tcl level methods, etc.
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
namespace eval ::dom {
|
|
namespace eval domDoc {
|
|
}
|
|
namespace eval domNode {
|
|
}
|
|
namespace eval DOMImplementation {
|
|
}
|
|
namespace eval xpathFunc {
|
|
}
|
|
namespace eval xpathFuncHelper {
|
|
}
|
|
}
|
|
|
|
namespace eval ::tDOM {
|
|
variable extRefHandlerDebug 0
|
|
variable useForeignDTD ""
|
|
|
|
namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# hasFeature (DOMImplementation method)
|
|
#
|
|
#
|
|
# @in url the URL, where to get the XML document
|
|
#
|
|
# @return document object
|
|
# @exception XML parse errors, ...
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {
|
|
|
|
switch $feature {
|
|
xml -
|
|
XML {
|
|
if {($version == "") || ($version == "1.0")} {
|
|
return 1
|
|
}
|
|
}
|
|
}
|
|
return 0
|
|
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# load (DOMImplementation method)
|
|
#
|
|
# requests a XML document via http using the given URL and
|
|
# builds up a DOM tree in memory returning the document object
|
|
#
|
|
#
|
|
# @in url the URL, where to get the XML document
|
|
#
|
|
# @return document object
|
|
# @exception XML parse errors, ...
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::DOMImplementation::load { dom url } {
|
|
|
|
error "Sorry, load method not implemented yet!"
|
|
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# isa (docDoc method, for [incr tcl] compatibility)
|
|
#
|
|
#
|
|
# @in className
|
|
#
|
|
# @return 1 iff inherits from the given class
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domDoc::isa { doc className } {
|
|
|
|
if {$className == "domDoc"} {
|
|
return 1
|
|
}
|
|
return 0
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# info (domDoc method, for [incr tcl] compatibility)
|
|
#
|
|
#
|
|
# @in subcommand
|
|
# @in args
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domDoc::info { doc subcommand args } {
|
|
|
|
switch $subcommand {
|
|
class {
|
|
return "domDoc"
|
|
}
|
|
inherit {
|
|
return ""
|
|
}
|
|
heritage {
|
|
return "domDoc {}"
|
|
}
|
|
default {
|
|
error "domDoc::info subcommand $subcommand not yet implemented!"
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# importNode (domDoc method)
|
|
#
|
|
# Document Object Model (Core) Level 2 method
|
|
#
|
|
#
|
|
# @in subcommand
|
|
# @in args
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domDoc::importNode { doc importedNode deep } {
|
|
|
|
if {$deep || ($deep == "-deep")} {
|
|
set node [$importedNode cloneNode -deep]
|
|
} else {
|
|
set node [$importedNode cloneNode]
|
|
}
|
|
return $node
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# isa (domNode method, for [incr tcl] compatibility)
|
|
#
|
|
#
|
|
# @in className
|
|
#
|
|
# @return 1 iff inherits from the given class
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::isa { doc className } {
|
|
|
|
if {$className == "domNode"} {
|
|
return 1
|
|
}
|
|
return 0
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# info (domNode method, for [incr tcl] compatibility)
|
|
#
|
|
#
|
|
# @in subcommand
|
|
# @in args
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::info { doc subcommand args } {
|
|
|
|
switch $subcommand {
|
|
class {
|
|
return "domNode"
|
|
}
|
|
inherit {
|
|
return ""
|
|
}
|
|
heritage {
|
|
return "domNode {}"
|
|
}
|
|
default {
|
|
error "domNode::info subcommand $subcommand not yet implemented!"
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# isWithin (domNode method)
|
|
#
|
|
# tests, whether a node object is nested below another tag
|
|
#
|
|
#
|
|
# @in tagName the nodeName of an elment node
|
|
#
|
|
# @return 1 iff node is nested below a element with nodeName tagName
|
|
# 0 otherwise
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::isWithin { node tagName } {
|
|
|
|
while {[$node parentNode] != ""} {
|
|
set node [$node parentNode]
|
|
if {[$node nodeName] == $tagName} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# tagName (domNode method)
|
|
#
|
|
# same a nodeName for element interface
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::tagName { node } {
|
|
|
|
if {[$node nodeType] == "ELEMENT_NODE"} {
|
|
return [$node nodeName]
|
|
}
|
|
return -code error "NOT_SUPPORTED_ERR not an element!"
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# simpleTranslate (domNode method)
|
|
#
|
|
# applies simple translation rules similar to Cost's simple
|
|
# translations to a node
|
|
#
|
|
#
|
|
# @in output_var
|
|
# @in trans_specs
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {
|
|
|
|
upvar $output_var output
|
|
|
|
if {[$node nodeType] == "TEXT_NODE"} {
|
|
append output [cgiQuote [$node nodeValue]]
|
|
return
|
|
}
|
|
set found 0
|
|
|
|
foreach {match action} $trans_specs {
|
|
|
|
if {[catch {
|
|
if {!$found && ([$node selectNode self::$match] != "") } {
|
|
set found 1
|
|
}
|
|
} err]} {
|
|
if {![string match "NodeSet expected for parent axis!" $err]} {
|
|
error $err
|
|
}
|
|
}
|
|
if {$found && ($action != "-")} {
|
|
set stop 0
|
|
foreach {type value} $action {
|
|
switch $type {
|
|
prefix { append output [subst $value] }
|
|
tag { append output <$value> }
|
|
start { append output [eval $value] }
|
|
stop { set stop 1 }
|
|
}
|
|
}
|
|
if {!$stop} {
|
|
foreach child [$node childNodes] {
|
|
simpleTranslate $child output $trans_specs
|
|
}
|
|
}
|
|
foreach {type value} $action {
|
|
switch $type {
|
|
suffix { append output [subst $value] }
|
|
end { append output [eval $value] }
|
|
tag { append output </$value> }
|
|
}
|
|
}
|
|
return
|
|
}
|
|
}
|
|
foreach child [$node childNodes] {
|
|
simpleTranslate $child output $trans_specs
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# a DOM conformant 'live' childNodes
|
|
#
|
|
# @return a 'nodelist' object (it is just the normal node)
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::childNodesLive { node } {
|
|
|
|
return $node
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# item method on a 'nodelist' object
|
|
#
|
|
# @return a 'nodelist' object (it is just a normal
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::item { nodeListNode index } {
|
|
|
|
return [lindex [$nodeListNode childNodes] $index]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# length method on a 'nodelist' object
|
|
#
|
|
# @return a 'nodelist' object (it is just a normal
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::length { nodeListNode } {
|
|
|
|
return [llength [$nodeListNode childNodes]]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# appendData on a 'CharacterData' object
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::appendData { node arg } {
|
|
|
|
set type [$node nodeType]
|
|
if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
|
|
($type != "COMMENT_NODE")
|
|
} {
|
|
return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
|
|
}
|
|
set oldValue [$node nodeValue]
|
|
$node nodeValue [append oldValue $arg]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# deleteData on a 'CharacterData' object
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::deleteData { node offset count } {
|
|
|
|
set type [$node nodeType]
|
|
if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
|
|
($type != "COMMENT_NODE")
|
|
} {
|
|
return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
|
|
}
|
|
incr offset -1
|
|
set before [string range [$node nodeValue] 0 $offset]
|
|
incr offset
|
|
incr offset $count
|
|
set after [string range [$node nodeValue] $offset end]
|
|
$node nodeValue [append before $after]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# insertData on a 'CharacterData' object
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::insertData { node offset arg } {
|
|
|
|
set type [$node nodeType]
|
|
if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
|
|
($type != "COMMENT_NODE")
|
|
} {
|
|
return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
|
|
}
|
|
incr offset -1
|
|
set before [string range [$node nodeValue] 0 $offset]
|
|
incr offset
|
|
set after [string range [$node nodeValue] $offset end]
|
|
$node nodeValue [append before $arg $after]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# replaceData on a 'CharacterData' object
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::replaceData { node offset count arg } {
|
|
|
|
set type [$node nodeType]
|
|
if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
|
|
($type != "COMMENT_NODE")
|
|
} {
|
|
return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
|
|
}
|
|
incr offset -1
|
|
set before [string range [$node nodeValue] 0 $offset]
|
|
incr offset
|
|
incr offset $count
|
|
set after [string range [$node nodeValue] $offset end]
|
|
$node nodeValue [append before $arg $after]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# substringData on a 'CharacterData' object
|
|
#
|
|
# @return part of the node value (text)
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::domNode::substringData { node offset count } {
|
|
|
|
set type [$node nodeType]
|
|
if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
|
|
($type != "COMMENT_NODE")
|
|
} {
|
|
return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
|
|
}
|
|
set endOffset [expr $offset + $count - 1]
|
|
return [string range [$node nodeValue] $offset $endOffset]
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# coerce2number
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::xpathFuncHelper::coerce2number { type value } {
|
|
switch $type {
|
|
empty { return 0 }
|
|
number -
|
|
string { return $value }
|
|
attrvalues { return [lindex $value 0] }
|
|
nodes { return [[lindex $value 0] selectNodes number()] }
|
|
attrnodes { return [lindex $value 1] }
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# coerce2string
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::xpathFuncHelper::coerce2string { type value } {
|
|
switch $type {
|
|
empty { return "" }
|
|
number -
|
|
string { return $value }
|
|
attrvalues { return [lindex $value 0] }
|
|
nodes { return [[lindex $value 0] selectNodes string()] }
|
|
attrnodes { return [lindex $value 1] }
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# function-available
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::xpathFunc::function-available { ctxNode pos
|
|
nodeListType nodeList args} {
|
|
|
|
if {[llength $args] != 2} {
|
|
error "function-available(): wrong # of args!"
|
|
}
|
|
foreach { arg1Typ arg1Value } $args break
|
|
set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
|
|
switch $str {
|
|
boolean -
|
|
ceiling -
|
|
concat -
|
|
contains -
|
|
count -
|
|
current -
|
|
document -
|
|
element-available -
|
|
false -
|
|
floor -
|
|
format-number -
|
|
generate-id -
|
|
id -
|
|
key -
|
|
last -
|
|
lang -
|
|
local-name -
|
|
name -
|
|
namespace-uri -
|
|
normalize-space -
|
|
not -
|
|
number -
|
|
position -
|
|
round -
|
|
starts-with -
|
|
string -
|
|
string-length -
|
|
substring -
|
|
substring-after -
|
|
substring-before -
|
|
sum -
|
|
translate -
|
|
true -
|
|
unparsed-entity-uri {
|
|
return [list bool true]
|
|
}
|
|
default {
|
|
set TclXpathFuncs [info procs ::dom::xpathFunc::*]
|
|
if {[lsearch -exact $TclXpathFuncs $str] != -1} {
|
|
return [list bool true]
|
|
} else {
|
|
return [list bool false]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# element-available
|
|
#
|
|
# This is not strictly correct. The XSLT namespace may be bound
|
|
# to another prefix (and the prefix 'xsl' may be bound to another
|
|
# namespace). Since the expression context isn't available at the
|
|
# moment at tcl coded XPath functions, this couldn't be done better
|
|
# than this "works in the 'normal' cases" version.
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::xpathFunc::element-available { ctxNode pos
|
|
nodeListType nodeList args} {
|
|
|
|
if {[llength $args] != 2} {
|
|
error "element-available(): wrong # of args!"
|
|
}
|
|
foreach { arg1Typ arg1Value } $args break
|
|
set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
|
|
switch $str {
|
|
xsl:stylesheet -
|
|
xsl:transform -
|
|
xsl:include -
|
|
xsl:import -
|
|
xsl:strip-space -
|
|
xsl:preserve-space -
|
|
xsl:template -
|
|
xsl:apply-templates -
|
|
xsl:apply-imports -
|
|
xsl:call-template -
|
|
xsl:element -
|
|
xsl:attribute -
|
|
xsl:attribute-set -
|
|
xsl:text -
|
|
xsl:processing-instruction -
|
|
xsl:comment -
|
|
xsl:copy -
|
|
xsl:value-of -
|
|
xsl:number -
|
|
xsl:for-each -
|
|
xsl:if -
|
|
xsl:choose -
|
|
xsl:when -
|
|
xsl:otherwise -
|
|
xsl:sort -
|
|
xsl:variable -
|
|
xsl:param -
|
|
xsl:copy-of -
|
|
xsl:with-param -
|
|
xsl:key -
|
|
xsl:message -
|
|
xsl:decimal-format -
|
|
xsl:namespace-alias -
|
|
xsl:output -
|
|
xsl:fallback {
|
|
return [list bool true]
|
|
}
|
|
default {
|
|
return [list bool false]
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# system-property
|
|
#
|
|
# This is not strictly correct. The XSLT namespace may be bound
|
|
# to another prefix (and the prefix 'xsl' may be bound to another
|
|
# namespace). Since the expression context isn't available at the
|
|
# moment at tcl coded XPath functions, this couldn't be done better
|
|
# than this "works in the 'normal' cases" version.
|
|
#----------------------------------------------------------------------------
|
|
proc ::dom::xpathFunc::system-property { ctxNode pos
|
|
nodeListType nodeList args } {
|
|
|
|
if {[llength $args] != 2} {
|
|
error "system-property(): wrong # of args!"
|
|
}
|
|
foreach { arg1Typ arg1Value } $args break
|
|
set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
|
|
switch $str {
|
|
xsl:version {
|
|
return [list number 1.0]
|
|
}
|
|
xsl:vendor {
|
|
return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
|
|
}
|
|
xsl:vendor-url {
|
|
return [list string "http://www.tdom.org"]
|
|
}
|
|
default {
|
|
return [list string ""]
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# IANAEncoding2TclEncoding
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
|
|
# As of version 8.3.4 tcl supports
|
|
# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
|
|
# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
|
|
# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
|
|
# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
|
|
# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
|
|
# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
|
|
# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
|
|
# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
|
|
# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
|
|
# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
|
|
# cp857
|
|
#
|
|
# Just add more mappings (and mail them to the tDOM mailing list, please).
|
|
|
|
proc tDOM::IANAEncoding2TclEncoding {IANAName} {
|
|
|
|
# First the most widespread encodings with there
|
|
# preferred MIME name, to speed lookup in this
|
|
# usual cases. Later the official names and the
|
|
# aliases.
|
|
#
|
|
# For "official names for character sets that may be
|
|
# used in the Internet" see
|
|
# http://www.iana.org/assignments/character-sets
|
|
# (that's the source for the encoding names below)
|
|
#
|
|
# Matching is case-insensitive
|
|
|
|
switch [string tolower $IANAName] {
|
|
"us-ascii" {return ascii}
|
|
"utf-8" {return utf-8}
|
|
"utf-16" {return unicode; # not sure about this}
|
|
"iso-8859-1" {return iso8859-1}
|
|
"iso-8859-2" {return iso8859-2}
|
|
"iso-8859-3" {return iso8859-3}
|
|
"iso-8859-4" {return iso8859-4}
|
|
"iso-8859-5" {return iso8859-5}
|
|
"iso-8859-6" {return iso8859-6}
|
|
"iso-8859-7" {return iso8859-7}
|
|
"iso-8859-8" {return iso8859-8}
|
|
"iso-8859-9" {return iso8859-9}
|
|
"iso-8859-10" {return iso8859-10}
|
|
"iso-8859-13" {return iso8859-13}
|
|
"iso-8859-14" {return iso8859-14}
|
|
"iso-8859-15" {return iso8859-15}
|
|
"iso-8859-16" {return iso8859-16}
|
|
"iso-2022-kr" {return iso2022-kr}
|
|
"euc-kr" {return euc-kr}
|
|
"iso-2022-jp" {return iso2022-jp}
|
|
"koi8-r" {return koi8-r}
|
|
"shift_jis" {return shiftjis}
|
|
"euc-jp" {return euc-jp}
|
|
"gb2312" {return gb2312}
|
|
"big5" {return big5}
|
|
"cp866" {return cp866}
|
|
"cp1250" {return cp1250}
|
|
"cp1253" {return cp1253}
|
|
"cp1254" {return cp1254}
|
|
"cp1255" {return cp1255}
|
|
"cp1256" {return cp1256}
|
|
"cp1257" {return cp1257}
|
|
|
|
"windows-1251" -
|
|
"cp1251" {return cp1251}
|
|
|
|
"windows-1252" -
|
|
"cp1252" {return cp1252}
|
|
|
|
"iso_8859-1:1987" -
|
|
"iso-ir-100" -
|
|
"iso_8859-1" -
|
|
"latin1" -
|
|
"l1" -
|
|
"ibm819" -
|
|
"cp819" -
|
|
"csisolatin1" {return iso8859-1}
|
|
|
|
"iso_8859-2:1987" -
|
|
"iso-ir-101" -
|
|
"iso_8859-2" -
|
|
"iso-8859-2" -
|
|
"latin2" -
|
|
"l2" -
|
|
"csisolatin2" {return iso8859-2}
|
|
|
|
"iso_8859-5:1988" -
|
|
"iso-ir-144" -
|
|
"iso_8859-5" -
|
|
"iso-8859-5" -
|
|
"cyrillic" -
|
|
"csisolatincyrillic" {return iso8859-5}
|
|
|
|
"ms_kanji" -
|
|
"csshiftjis" {return shiftjis}
|
|
|
|
"csiso2022kr" {return iso2022-kr}
|
|
|
|
"ibm866" -
|
|
"csibm866" {return cp866}
|
|
|
|
default {
|
|
# There are much more encoding names out there
|
|
# It's only laziness, that let me stop here.
|
|
error "Unrecognized encoding name '$IANAName'"
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# xmlOpenFile
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc tDOM::xmlOpenFile {filename {encodingString {}}} {
|
|
|
|
set fd [open $filename]
|
|
|
|
if {$encodingString != {}} {
|
|
upvar $encodingString encString
|
|
}
|
|
|
|
# The autodetection of the encoding follows
|
|
# XML Recomendation, Appendix F
|
|
|
|
fconfigure $fd -encoding binary
|
|
if {![binary scan [read $fd 4] "H8" firstBytes]} {
|
|
# very short (< 4 Bytes) file
|
|
seek $fd 0 start
|
|
set encString UTF-8
|
|
return $fd
|
|
}
|
|
|
|
# First check for BOM
|
|
switch [string range $firstBytes 0 3] {
|
|
"feff" -
|
|
"fffe" {
|
|
# feff: UTF-16, big-endian BOM
|
|
# ffef: UTF-16, little-endian BOM
|
|
seek $fd 0 start
|
|
set encString UTF-16
|
|
fconfigure $fd -encoding identity
|
|
return $fd
|
|
}
|
|
}
|
|
|
|
# If the entity has a XML Declaration, the first four characters
|
|
# must be "<?xm".
|
|
switch $firstBytes {
|
|
"3c3f786d" {
|
|
# UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
|
|
# EUC, or any other 7-bit, 8-bit, or mixed-width encoding which
|
|
# ensures that the characters of ASCII have their normal positions,
|
|
# width and values; the actual encoding declaration must be read to
|
|
# detect which of these applies, but since all of these encodings
|
|
# use the same bit patterns for the ASCII characters, the encoding
|
|
# declaration itself be read reliably.
|
|
|
|
# First 300 bytes should be enough for a XML Declaration
|
|
# This is of course not 100 percent bullet-proof.
|
|
set head [read $fd 296]
|
|
|
|
# Try to find the end of the XML Declaration
|
|
set closeIndex [string first ">" $head]
|
|
if {$closeIndex == -1} {
|
|
error "Weird XML data or not XML data at all"
|
|
}
|
|
|
|
seek $fd 0 start
|
|
set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
|
|
# extract the encoding information
|
|
set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
|
|
# emacs: "
|
|
if {![regexp $pattern $head - encStr]} {
|
|
# Probably something like <?xml version="1.0"?>.
|
|
# Without encoding declaration this must be UTF-8
|
|
set encoding utf-8
|
|
set encString UTF-8
|
|
} else {
|
|
set encoding [IANAEncoding2TclEncoding $encStr]
|
|
set encString $encStr
|
|
}
|
|
}
|
|
"0000003c" -
|
|
"0000003c" -
|
|
"3c000000" -
|
|
"00003c00" {
|
|
# UCS-4
|
|
error "UCS-4 not supported"
|
|
}
|
|
"003c003f" -
|
|
"3c003f00" {
|
|
# UTF-16, big-endian, no BOM
|
|
# UTF-16, little-endian, no BOM
|
|
seek $fd 0 start
|
|
set encoding identity
|
|
set encString UTF-16
|
|
}
|
|
"4c6fa794" {
|
|
# EBCDIC in some flavor
|
|
error "EBCDIC not supported"
|
|
}
|
|
default {
|
|
# UTF-8 without an encoding declaration
|
|
seek $fd 0 start
|
|
set encoding identity
|
|
set encString "UTF-8"
|
|
}
|
|
}
|
|
fconfigure $fd -encoding $encoding
|
|
return $fd
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# xmlReadFile
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
proc tDOM::xmlReadFile {filename {encodingString {}}} {
|
|
|
|
if {$encodingString != {}} {
|
|
upvar $encodingString encString
|
|
}
|
|
|
|
set fd [xmlOpenFile $filename encString]
|
|
set data [read $fd [file size $filename]]
|
|
close $fd
|
|
return $data
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# extRefHandler
|
|
#
|
|
# A very simple external entity resolver, included for convenience.
|
|
# Depends on the tcllib package uri and resolves only file URLs.
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
|
|
if {![catch {package require uri}]} {
|
|
proc tDOM::extRefHandler {base systemId publicId} {
|
|
variable extRefHandlerDebug
|
|
variable useForeignDTD
|
|
|
|
if {$extRefHandlerDebug} {
|
|
puts stderr "tDOM::extRefHandler called with:"
|
|
puts stderr "\tbase: '$base'"
|
|
puts stderr "\tsystemId: '$systemId'"
|
|
puts stderr "\tpublicId: '$publicId'"
|
|
}
|
|
if {$systemId == ""} {
|
|
if {$useForeignDTD != ""} {
|
|
set systemId $useForeignDTD
|
|
} else {
|
|
error "::tDOM::useForeignDTD does\
|
|
not point to the foreign DTD"
|
|
}
|
|
}
|
|
set absolutURI [uri::resolve $base $systemId]
|
|
array set uriData [uri::split $absolutURI]
|
|
switch $uriData(scheme) {
|
|
file {
|
|
return [list string $absolutURI [xmlReadFile $uriData(path)]]
|
|
}
|
|
default {
|
|
error "can only handle file URI's"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# baseURL
|
|
#
|
|
# A simple convenience proc which returns an absolute URL for a given
|
|
# filename.
|
|
#
|
|
#----------------------------------------------------------------------------
|
|
|
|
proc tDOM::baseURL {path} {
|
|
switch [file pathtype $path] {
|
|
"relative" {
|
|
return "file://[pwd]/$path"
|
|
}
|
|
default {
|
|
return "file://$path"
|
|
}
|
|
}
|
|
}
|
|
|
|
# EOF
|