summaryrefslogtreecommitdiffstats
path: root/tclxml/tclxml-tcl/tclparser-8.1.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tclxml/tclxml-tcl/tclparser-8.1.tcl')
-rwxr-xr-xtclxml/tclxml-tcl/tclparser-8.1.tcl614
1 files changed, 614 insertions, 0 deletions
diff --git a/tclxml/tclxml-tcl/tclparser-8.1.tcl b/tclxml/tclxml-tcl/tclparser-8.1.tcl
new file mode 100755
index 0000000..40a0af9
--- /dev/null
+++ b/tclxml/tclxml-tcl/tclparser-8.1.tcl
@@ -0,0 +1,614 @@
+# tclparser-8.1.tcl --
+#
+# This file provides a Tcl implementation of a XML parser.
+# This file supports Tcl 8.1.
+#
+# See xml-8.[01].tcl for definitions of character sets and
+# regular expressions.
+#
+# Copyright (c) 2005-2008 by Explain.
+# http://www.explain.com.au/
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: tclparser-8.1.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
+
+package require Tcl 8.1
+
+package provide xml::tclparser 3.2
+
+package require xmldefs 3.2
+
+package require sgmlparser 1.0
+
+namespace eval xml::tclparser {
+
+ namespace export create createexternal externalentity parse configure get delete
+
+ # Tokenising expressions
+
+ variable tokExpr $::xml::tokExpr
+ variable substExpr $::xml::substExpr
+
+ # Register this parser class
+
+ ::xml::parserclass create tcl \
+ -createcommand [namespace code create] \
+ -createentityparsercommand [namespace code createentityparser] \
+ -parsecommand [namespace code parse] \
+ -configurecommand [namespace code configure] \
+ -deletecommand [namespace code delete] \
+ -resetcommand [namespace code reset]
+}
+
+# xml::tclparser::create --
+#
+# Creates XML parser object.
+#
+# Arguments:
+# name unique identifier for this instance
+#
+# Results:
+# The state variable is initialised.
+
+proc xml::tclparser::create name {
+
+ # Initialise state variable
+ upvar \#0 [namespace current]::$name parser
+ array set parser [list -name $name \
+ -cmd [uplevel 3 namespace current]::$name \
+ -final 1 \
+ -validate 0 \
+ -statevariable [namespace current]::$name \
+ -baseuri {} \
+ internaldtd {} \
+ entities [namespace current]::Entities$name \
+ extentities [namespace current]::ExtEntities$name \
+ parameterentities [namespace current]::PEntities$name \
+ externalparameterentities [namespace current]::ExtPEntities$name \
+ elementdecls [namespace current]::ElDecls$name \
+ attlistdecls [namespace current]::AttlistDecls$name \
+ notationdecls [namespace current]::NotDecls$name \
+ depth 0 \
+ leftover {} \
+ ]
+
+ # Initialise entities with predefined set
+ array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+ return $parser(-cmd)
+}
+
+# xml::tclparser::createentityparser --
+#
+# Creates XML parser object for an entity.
+#
+# Arguments:
+# name name for the new parser
+# parent name of parent parser
+#
+# Results:
+# The state variable is initialised.
+
+proc xml::tclparser::createentityparser {parent name} {
+ upvar #0 [namespace current]::$parent p
+
+ # Initialise state variable
+ upvar \#0 [namespace current]::$name external
+ array set external [array get p]
+
+ regsub $parent $p(-cmd) {} parentns
+
+ array set external [list -name $name \
+ -cmd $parentns$name \
+ -statevariable [namespace current]::$name \
+ internaldtd {} \
+ line 0 \
+ ]
+ incr external(depth)
+
+ return $external(-cmd)
+}
+
+# xml::tclparser::configure --
+#
+# Configures a XML parser object.
+#
+# Arguments:
+# name unique identifier for this instance
+# args option name/value pairs
+#
+# Results:
+# May change values of config options
+
+proc xml::tclparser::configure {name args} {
+ upvar \#0 [namespace current]::$name parser
+
+ # BUG: very crude, no checks for illegal args
+ # Mats: Should be synced with sgmlparser.tcl
+ set options {-elementstartcommand -elementendcommand \
+ -characterdatacommand -processinginstructioncommand \
+ -externalentitycommand -xmldeclcommand \
+ -doctypecommand -commentcommand \
+ -entitydeclcommand -unparsedentitydeclcommand \
+ -parameterentitydeclcommand -notationdeclcommand \
+ -elementdeclcommand -attlistdeclcommand \
+ -paramentityparsing -defaultexpandinternalentities \
+ -startdoctypedeclcommand -enddoctypedeclcommand \
+ -entityreferencecommand -warningcommand \
+ -defaultcommand -unknownencodingcommand -notstandalonecommand \
+ -startcdatasectioncommand -endcdatasectioncommand \
+ -errorcommand -final \
+ -validate -baseuri -baseurl \
+ -name -cmd -emptyelement \
+ -parseattributelistcommand -parseentitydeclcommand \
+ -normalize -internaldtd -dtdsubset \
+ -reportempty -ignorewhitespace \
+ -reportempty \
+ }
+ set usage [join $options ", "]
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ foreach {flag value} $args {
+ if {[regexp $pat $flag]} {
+ # Validate numbers
+ if {[info exists parser($flag)] && \
+ [string is integer -strict $parser($flag)] && \
+ ![string is integer -strict $value]} {
+ return -code error "Bad value for $flag ($value), must be integer"
+ }
+ set parser($flag) $value
+ } else {
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+
+ # Backward-compatibility: -baseuri is a synonym for -baseurl
+ catch {set parser(-baseuri) $parser(-baseurl)}
+
+ return {}
+}
+
+# xml::tclparser::parse --
+#
+# Parses document instance data
+#
+# Arguments:
+# name parser object
+# xml data
+# args configuration options
+#
+# Results:
+# Callbacks are invoked
+
+proc xml::tclparser::parse {name xml args} {
+
+ array set options $args
+ upvar \#0 [namespace current]::$name parser
+ variable tokExpr
+ variable substExpr
+
+ # Mats:
+ if {[llength $args]} {
+ eval {configure $name} $args
+ }
+
+ set parseOptions [list \
+ -emptyelement [namespace code ParseEmpty] \
+ -parseattributelistcommand [namespace code ParseAttrs] \
+ -parseentitydeclcommand [namespace code ParseEntity] \
+ -normalize 0]
+ eval lappend parseOptions \
+ [array get parser -*command] \
+ [array get parser -reportempty] \
+ [array get parser -ignorewhitespace] \
+ [array get parser -name] \
+ [array get parser -cmd] \
+ [array get parser -baseuri] \
+ [array get parser -validate] \
+ [array get parser -final] \
+ [array get parser -defaultexpandinternalentities] \
+ [array get parser entities] \
+ [array get parser extentities] \
+ [array get parser parameterentities] \
+ [array get parser externalparameterentities] \
+ [array get parser elementdecls] \
+ [array get parser attlistdecls] \
+ [array get parser notationdecls]
+
+ # Mats:
+ # If -final 0 we also need to maintain the state with a -statevariable !
+ if {!$parser(-final)} {
+ eval lappend parseOptions [array get parser -statevariable]
+ }
+
+ set dtdsubset no
+ catch {set dtdsubset $options(-dtdsubset)}
+ switch -- $dtdsubset {
+ internal {
+ # Bypass normal parsing
+ lappend parseOptions -statevariable $parser(-statevariable)
+ array set intOptions [array get ::sgml::StdOptions]
+ array set intOptions $parseOptions
+ ::sgml::ParseDTD:Internal [array get intOptions] $xml
+ return {}
+ }
+ external {
+ # Bypass normal parsing
+ lappend parseOptions -statevariable $parser(-statevariable)
+ array set intOptions [array get ::sgml::StdOptions]
+ array set intOptions $parseOptions
+ ::sgml::ParseDTD:External [array get intOptions] $xml
+ return {}
+ }
+ default {
+ # Pass through to normal processing
+ }
+ }
+
+ lappend tokenOptions \
+ -internaldtdvariable [namespace current]::${name}(internaldtd)
+
+ # Mats: If -final 0 we also need to maintain the state with a -statevariable !
+ if {!$parser(-final)} {
+ eval lappend tokenOptions [array get parser -statevariable] \
+ [array get parser -final]
+ }
+
+ # Mats:
+ # Why not the first four? Just padding? Lrange undos \n interp.
+ # It is necessary to have the first four as well if chopped off in
+ # middle of pcdata.
+ set tokenised [lrange \
+ [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions] \
+ 0 end]
+
+ lappend parseOptions -internaldtd [list $parser(internaldtd)]
+ eval ::sgml::parseEvent [list $tokenised] $parseOptions
+
+ return {}
+}
+
+# xml::tclparser::ParseEmpty -- Tcl 8.1+ version
+#
+# Used by parser to determine whether an element is empty.
+# This is usually dead easy in XML, but as always not quite.
+# Have to watch out for empty element syntax
+#
+# Arguments:
+# tag element name
+# attr attribute list (raw)
+# e End tag delimiter.
+#
+# Results:
+# Return value of e
+
+proc xml::tclparser::ParseEmpty {tag attr e} {
+ switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
+ 0,0 {
+ return {}
+ }
+ 0,* {
+ return /
+ }
+ default {
+ return $e
+ }
+ }
+}
+
+# xml::tclparser::ParseAttrs -- Tcl 8.1+ version
+#
+# Parse element attributes.
+#
+# There are two forms for name-value pairs:
+#
+# name="value"
+# name='value'
+#
+# Arguments:
+# opts parser options
+# attrs attribute string given in a tag
+#
+# Results:
+# Returns a Tcl list representing the name-value pairs in the
+# attribute string
+#
+# A ">" occurring in the attribute list causes problems when parsing
+# the XML. This manifests itself by an unterminated attribute value
+# and a ">" appearing the element text.
+# In this case return a three element list;
+# the message "unterminated attribute value", the attribute list it
+# did manage to parse and the remainder of the attribute list.
+
+proc xml::tclparser::ParseAttrs {opts attrs} {
+
+ set result {}
+
+ while {[string length [string trim $attrs]]} {
+ if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
+ lappend result $attrName [NormalizeAttValue $opts $value]
+ } elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
+ return -code error [list {unterminated attribute value} $result $attrs]
+ } else {
+ return -code error "invalid attribute list"
+ }
+ }
+
+ return $result
+}
+
+# xml::tclparser::NormalizeAttValue --
+#
+# Perform attribute value normalisation. This involves:
+# . character references are appended to the value
+# . entity references are recursively processed and replacement value appended
+# . whitespace characters cause a space to be appended
+# . other characters appended as-is
+#
+# Arguments:
+# opts parser options
+# value unparsed attribute value
+#
+# Results:
+# Normalised value returned.
+
+proc xml::tclparser::NormalizeAttValue {opts value} {
+
+ # sgmlparser already has backslashes protected
+ # Protect Tcl specials
+ regsub -all {([][$])} $value {\\\1} value
+
+ # Deal with white space
+ regsub -all "\[$::xml::Wsp\]" $value { } value
+
+ # Find entity refs
+ regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value
+
+ return [subst $value]
+}
+
+# xml::tclparser::NormalizeAttValue:DeRef --
+#
+# Handler to normalize attribute values
+#
+# Arguments:
+# opts parser options
+# ref entity reference
+#
+# Results:
+# Returns character
+
+proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} {
+ # SRB: Bug fix 2008-11-18 #812051: surround case labels in braces for compatibility with Freewrap
+ switch -glob -- $ref {
+ {#x*} {
+ scan [string range $ref 2 end] %x value
+ set char [format %c $value]
+ # Check that the char is legal for XML
+ if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+ return $char
+ } else {
+ return -code error "illegal character"
+ }
+ }
+ {#*} {
+ scan [string range $ref 1 end] %d value
+ set char [format %c $value]
+ # Check that the char is legal for XML
+ if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+ return $char
+ } else {
+ return -code error "illegal character"
+ }
+ }
+ lt -
+ gt -
+ amp -
+ quot -
+ apos {
+ array set map {lt < gt > amp & quot \" apos '}
+ return $map($ref)
+ }
+ default {
+ # A general entity. Must resolve to a text value - no element structure.
+
+ array set options $opts
+ upvar #0 $options(entities) map
+
+ if {[info exists map($ref)]} {
+
+ if {[regexp < $map($ref)]} {
+ return -code error "illegal character \"<\" in attribute value"
+ }
+
+ if {![regexp & $map($ref)]} {
+ # Simple text replacement
+ return $map($ref)
+ }
+
+ # There are entity references in the replacement text.
+ # Can't use child entity parser since must catch element structures
+
+ return [NormalizeAttValue $opts $map($ref)]
+
+ } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {
+
+ set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]
+
+ return $result
+
+ } else {
+ return -code error "unable to resolve entity reference \"$ref\""
+ }
+ }
+ }
+}
+
+# xml::tclparser::ParseEntity --
+#
+# Parse general entity declaration
+#
+# Arguments:
+# data text to parse
+#
+# Results:
+# Tcl list containing entity declaration
+
+proc xml::tclparser::ParseEntity data {
+ set data [string trim $data]
+ if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
+ switch $type {
+ PUBLIC {
+ return [list external $id2 $id1 $ndata]
+ }
+ SYSTEM {
+ return [list external $id1 {} $ndata]
+ }
+ }
+ } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
+ return [list internal $value]
+ } else {
+ return -code error "badly formed entity declaration"
+ }
+}
+
+# xml::tclparser::delete --
+#
+# Destroy parser data
+#
+# Arguments:
+# name parser object
+#
+# Results:
+# Parser data structure destroyed
+
+proc xml::tclparser::delete name {
+ upvar \#0 [namespace current]::$name parser
+ catch {::sgml::ParserDelete $parser(-statevariable)}
+ catch {unset parser}
+ return {}
+}
+
+# xml::tclparser::get --
+#
+# Retrieve additional information from the parser
+#
+# Arguments:
+# name parser object
+# method info to retrieve
+# args additional arguments for method
+#
+# Results:
+# Depends on method
+
+proc xml::tclparser::get {name method args} {
+ upvar #0 [namespace current]::$name parser
+
+ switch -- $method {
+
+ elementdecl {
+ switch [llength $args] {
+
+ 0 {
+ # Return all element declarations
+ upvar #0 $parser(elementdecls) elements
+ return [array get elements]
+ }
+
+ 1 {
+ # Return specific element declaration
+ upvar #0 $parser(elementdecls) elements
+ if {[info exists elements([lindex $args 0])]} {
+ return [array get elements [lindex $args 0]]
+ } else {
+ return -code error "element \"[lindex $args 0]\" not declared"
+ }
+ }
+
+ default {
+ return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
+ }
+ }
+ }
+
+ attlist {
+ if {[llength $args] != 1} {
+ return -code error "wrong number of arguments: should be \"get attlist element\""
+ }
+
+ upvar #0 $parser(attlistdecls)
+
+ return {}
+ }
+
+ entitydecl {
+ }
+
+ parameterentitydecl {
+ }
+
+ notationdecl {
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+ }
+
+ return {}
+}
+
+# xml::tclparser::ExternalEntity --
+#
+# Resolve and parse external entity
+#
+# Arguments:
+# name parser object
+# base base URL
+# sys system identifier
+# pub public identifier
+#
+# Results:
+# External entity is fetched and parsed
+
+proc xml::tclparser::ExternalEntity {name base sys pub} {
+}
+
+# xml::tclparser:: --
+#
+# Reset a parser instance, ready to parse another document
+#
+# Arguments:
+# name parser object
+#
+# Results:
+# Variables unset
+
+proc xml::tclparser::reset {name} {
+ upvar \#0 [namespace current]::$name parser
+
+ # Has this parser object been properly initialised?
+ if {![info exists parser] || \
+ ![info exists parser(-name)]} {
+ return [create $name]
+ }
+
+ array set parser {
+ -final 1
+ depth 0
+ leftover {}
+ }
+
+ foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
+ catch {unset [namespace current]::${var}$name}
+ }
+
+ # Initialise entities with predefined set
+ array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+ return {}
+}