Merge commit 'c0573da8973e0ae8650d787d639a9acf9ab4a1ac' as 'tclxml'

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 {}
+}