summaryrefslogtreecommitdiffstats
path: root/tclxml/tclxml-tcl/sgmlparser.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tclxml/tclxml-tcl/sgmlparser.tcl')
-rwxr-xr-xtclxml/tclxml-tcl/sgmlparser.tcl2814
1 files changed, 0 insertions, 2814 deletions
diff --git a/tclxml/tclxml-tcl/sgmlparser.tcl b/tclxml/tclxml-tcl/sgmlparser.tcl
deleted file mode 100755
index 2677a44..0000000
--- a/tclxml/tclxml-tcl/sgmlparser.tcl
+++ /dev/null
@@ -1,2814 +0,0 @@
-# sgmlparser.tcl --
-#
-# This file provides the generic part of a parser for SGML-based
-# languages, namely HTML and XML.
-#
-# NB. It is a misnomer. There is no support for parsing
-# arbitrary SGML as such.
-#
-# See sgml.tcl for variable definitions.
-#
-# Copyright (c) 2008 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: sgmlparser.tcl,v 1.1.1.1 2009/01/16 22:11:49 joye Exp $
-
-package require sgml 1.9
-
-package require uri 1.1
-
-package provide sgmlparser 1.1
-
-namespace eval sgml {
- namespace export tokenise parseEvent
-
- namespace export parseDTD
-
- # NB. Most namespace variables are defined in sgml-8.[01].tcl
- # to account for differences between versions of Tcl.
- # This especially includes the regular expressions used.
-
- variable ParseEventNum
- if {![info exists ParseEventNum]} {
- set ParseEventNum 0
- }
- variable ParseDTDnum
- if {![info exists ParseDTDNum]} {
- set ParseDTDNum 0
- }
-
- variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
- variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)
-
- #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
- #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
- variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
- variable MarkupDeclSub "\} {\\1} {\\2} \{"
-
- variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$
-
- variable StdOptions
- array set StdOptions [list \
- -elementstartcommand [namespace current]::noop \
- -elementendcommand [namespace current]::noop \
- -characterdatacommand [namespace current]::noop \
- -processinginstructioncommand [namespace current]::noop \
- -externalentitycommand {} \
- -xmldeclcommand [namespace current]::noop \
- -doctypecommand [namespace current]::noop \
- -commentcommand [namespace current]::noop \
- -entitydeclcommand [namespace current]::noop \
- -unparsedentitydeclcommand [namespace current]::noop \
- -parameterentitydeclcommand [namespace current]::noop \
- -notationdeclcommand [namespace current]::noop \
- -elementdeclcommand [namespace current]::noop \
- -attlistdeclcommand [namespace current]::noop \
- -paramentityparsing 1 \
- -defaultexpandinternalentities 1 \
- -startdoctypedeclcommand [namespace current]::noop \
- -enddoctypedeclcommand [namespace current]::noop \
- -entityreferencecommand {} \
- -warningcommand [namespace current]::noop \
- -errorcommand [namespace current]::Error \
- -final 1 \
- -validate 0 \
- -baseuri {} \
- -name {} \
- -cmd {} \
- -emptyelement [namespace current]::EmptyElement \
- -parseattributelistcommand [namespace current]::noop \
- -parseentitydeclcommand [namespace current]::noop \
- -normalize 1 \
- -internaldtd {} \
- -reportempty 0 \
- -ignorewhitespace 0 \
- ]
-}
-
-# sgml::tokenise --
-#
-# Transform the given HTML/XML text into a Tcl list.
-#
-# Arguments:
-# sgml text to tokenize
-# elemExpr RE to recognise tags
-# elemSub transform for matched tags
-# args options
-#
-# Valid Options:
-# -internaldtdvariable
-# -final boolean True if no more data is to be supplied
-# -statevariable varName Name of a variable used to store info
-#
-# Results:
-# Returns a Tcl list representing the document.
-
-proc sgml::tokenise {sgml elemExpr elemSub args} {
- array set options {-final 1}
- array set options $args
- set options(-final) [Boolean $options(-final)]
-
- # If the data is not final then there must be a variable to store
- # unused data.
- if {!$options(-final) && ![info exists options(-statevariable)]} {
- return -code error {option "-statevariable" required if not final}
- }
-
- # Pre-process stage
- #
- # Extract the internal DTD subset, if any
-
- catch {upvar #0 $options(-internaldtdvariable) dtd}
- if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
- regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
- }
-
- # Protect Tcl special characters
- regsub -all {([{}\\])} $sgml {\\\1} sgml
-
- # Do the translation
-
- if {[info exists options(-statevariable)]} {
- # Mats: Several rewrites here to handle -final 0 option.
- # If any cached unparsed xml (state(leftover)), prepend it.
- upvar #0 $options(-statevariable) state
- if {[string length $state(leftover)]} {
- regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
- set state(leftover) {}
- } else {
- regsub -all $elemExpr $sgml $elemSub sgml
- }
- set sgml "{} {} {} \{$sgml\}"
-
- # Performance note (Tcl 8.0):
- # Use of lindex, lreplace will cause parsing to list object
-
- # This RE only fixes chopped inside tags, not chopped text.
- if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
- set sgml [lreplace $sgml end end $text]
- # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
- set state(leftover) $rest
- }
-
- # Patch from bug report #596959, Marshall Rose
- if {[string compare [lindex $sgml 4] ""]} {
- set sgml [linsert $sgml 0 {} {} {} {} {}]
- }
-
- } else {
-
- # Performance note (Tcl 8.0):
- # In this case, no conversion to list object is performed
-
- # Mats: This fails if not -final and $sgml is chopped off right in a tag.
- regsub -all $elemExpr $sgml $elemSub sgml
- set sgml "{} {} {} \{$sgml\}"
- }
-
- return $sgml
-
-}
-
-# sgml::parseEvent --
-#
-# Produces an event stream for a XML/HTML document,
-# given the Tcl list format returned by tokenise.
-#
-# This procedure checks that the document is well-formed,
-# and throws an error if the document is found to be not
-# well formed. Warnings are passed via the -warningcommand script.
-#
-# The procedure only check for well-formedness,
-# no DTD is required. However, facilities are provided for entity expansion.
-#
-# Arguments:
-# sgml Instance data, as a Tcl list.
-# args option/value pairs
-#
-# Valid Options:
-# -final Indicates end of document data
-# -validate Boolean to enable validation
-# -baseuri URL for resolving relative URLs
-# -elementstartcommand Called when an element starts
-# -elementendcommand Called when an element ends
-# -characterdatacommand Called when character data occurs
-# -entityreferencecommand Called when an entity reference occurs
-# -processinginstructioncommand Called when a PI occurs
-# -externalentitycommand Called for an external entity reference
-#
-# -xmldeclcommand Called when the XML declaration occurs
-# -doctypecommand Called when the document type declaration occurs
-# -commentcommand Called when a comment occurs
-# -entitydeclcommand Called when a parsed entity is declared
-# -unparsedentitydeclcommand Called when an unparsed external entity is declared
-# -parameterentitydeclcommand Called when a parameter entity is declared
-# -notationdeclcommand Called when a notation is declared
-# -elementdeclcommand Called when an element is declared
-# -attlistdeclcommand Called when an attribute list is declared
-# -paramentityparsing Boolean to enable/disable parameter entity substitution
-# -defaultexpandinternalentities Boolean to enable/disable expansion of entities declared in internal DTD subset
-#
-# -startdoctypedeclcommand Called when the Doc Type declaration starts (see also -doctypecommand)
-# -enddoctypedeclcommand Called when the Doc Type declaration ends (see also -doctypecommand)
-#
-# -errorcommand Script to evaluate for a fatal error
-# -warningcommand Script to evaluate for a reportable warning
-# -statevariable global state variable
-# -normalize whether to normalize names
-# -reportempty whether to include an indication of empty elements
-# -ignorewhitespace whether to automatically strip whitespace
-#
-# Results:
-# The various callback scripts are invoked.
-# Returns empty string.
-#
-# BUGS:
-# If command options are set to empty string then they should not be invoked.
-
-proc sgml::parseEvent {sgml args} {
- variable Wsp
- variable noWsp
- variable Nmtoken
- variable Name
- variable ParseEventNum
- variable StdOptions
-
- array set options [array get StdOptions]
- catch {array set options $args}
-
- # Mats:
- # If the data is not final then there must be a variable to persistently store the parse state.
- if {!$options(-final) && ![info exists options(-statevariable)]} {
- return -code error {option "-statevariable" required if not final}
- }
-
- foreach {opt value} [array get options *command] {
- if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
- set options($opt) [namespace current]::noop
- }
- }
-
- if {![info exists options(-statevariable)]} {
- set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
- }
- if {![info exists options(entities)]} {
- set options(entities) [namespace current]::Entities$ParseEventNum
- array set $options(entities) [array get [namespace current]::EntityPredef]
- }
- if {![info exists options(extentities)]} {
- set options(extentities) [namespace current]::ExtEntities$ParseEventNum
- }
- if {![info exists options(parameterentities)]} {
- set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
- }
- if {![info exists options(externalparameterentities)]} {
- set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
- }
- if {![info exists options(elementdecls)]} {
- set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
- }
- if {![info exists options(attlistdecls)]} {
- set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
- }
- if {![info exists options(notationdecls)]} {
- set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
- }
- if {![info exists options(namespaces)]} {
- set options(namespaces) [namespace current]::Namespaces$ParseEventNum
- }
-
- # For backward-compatibility
- catch {set options(-baseuri) $options(-baseurl)}
-
- # Choose an external entity resolver
-
- if {![string length $options(-externalentitycommand)]} {
- if {$options(-validate)} {
- set options(-externalentitycommand) [namespace code ResolveEntity]
- } else {
- set options(-externalentitycommand) [namespace code noop]
- }
- }
-
- upvar #0 $options(-statevariable) state
- upvar #0 $options(entities) entities
-
- # Mats:
- # The problem is that the state is not maintained when -final 0 !
- # I've switched back to an older version here.
-
- if {![info exists state(line)]} {
- # Initialise the state variable
- array set state {
- mode normal
- haveXMLDecl 0
- haveDocElement 0
- inDTD 0
- context {}
- stack {}
- line 0
- defaultNS {}
- defaultNSURI {}
- }
- }
-
- foreach {tag close param text} $sgml {
-
- # Keep track of lines in the input
- incr state(line) [regsub -all \n $param {} discard]
- incr state(line) [regsub -all \n $text {} discard]
-
- # If the current mode is cdata or comment then we must undo what the
- # regsub has done to reconstitute the data
-
- set empty {}
- switch $state(mode) {
- comment {
- # This had "[string length $param] && " as a guard -
- # can't remember why :-(
- if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
- # end of comment (in tag)
- set tag {}
- set close {}
- set state(mode) normal
- DeProtect1 $options(-commentcommand) $state(commentdata)<$comm1
- unset state(commentdata)
- } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
- # end of comment (in attributes)
- DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag>$comm1
- unset state(commentdata)
- set tag {}
- set param {}
- set close {}
- set state(mode) normal
- } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
- # end of comment (in text)
- DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag$param>$comm1
- unset state(commentdata)
- set tag {}
- set param {}
- set close {}
- set state(mode) normal
- } else {
- # comment continues
- append state(commentdata) <$close$tag$param>$text
- continue
- }
- }
- cdata {
- if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
- # end of CDATA (in tag)
- PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
- set text [subst -novariable -nocommand $text]
- set tag {}
- unset state(cdata)
- set state(mode) normal
- } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
- # end of CDATA (in attributes)
- PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
- set text [subst -novariable -nocommand $text]
- set tag {}
- set param {}
- unset state(cdata)
- set state(mode) normal
- } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
- # end of CDATA (in text)
- PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
- set text [subst -novariable -nocommand $text]
- set tag {}
- set param {}
- set close {}
- unset state(cdata)
- set state(mode) normal
- } else {
- # CDATA continues
- append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
- continue
- }
- }
- continue {
- # We're skipping elements looking for the close tag
- switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
- 0,* {
- continue
- }
- *,0, {
- if {![string compare $tag $state(continue:tag)]} {
- set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
- if {![string length $empty]} {
- incr state(continue:level)
- }
- }
- continue
- }
- *,0,/ {
- if {![string compare $tag $state(continue:tag)]} {
- incr state(continue:level) -1
- }
- if {!$state(continue:level)} {
- unset state(continue:tag)
- unset state(continue:level)
- set state(mode) {}
- }
- }
- default {
- continue
- }
- }
- }
- default {
- # The trailing slash on empty elements can't be automatically separated out
- # in the RE, so we must do it here.
- regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
- }
- }
-
- # default: normal mode
-
- # Bug: if the attribute list has a right angle bracket then the empty
- # element marker will not be seen
-
- set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
-
- switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {
-
- 0,0,, {
- # Ignore empty tag - dealt with non-normal mode above
- }
- *,0,, {
-
- # Start tag for an element.
-
- # Check if the internal DTD entity is in an attribute value
- regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param
-
- set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
- set state(haveDocElement) 1
- switch $code {
- 0 {# OK}
- 3 {
- # break
- return {}
- }
- 4 {
- # continue
- # Remember this tag and look for its close
- set state(continue:tag) $tag
- set state(continue:level) 1
- set state(mode) continue
- continue
- }
- default {
- return -code $code -errorinfo $::errorInfo $msg
- }
- }
-
- }
-
- *,0,/, {
-
- # End tag for an element.
-
- set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
- switch $code {
- 0 {# OK}
- 3 {
- # break
- return {}
- }
- 4 {
- # continue
- # skip sibling nodes
- set state(continue:tag) [lindex $state(stack) end]
- set state(continue:level) 1
- set state(mode) continue
- continue
- }
- default {
- return -code $code -errorinfo $::errorInfo $msg
- }
- }
-
- }
-
- *,0,,/ {
-
- # Empty element
-
- # The trailing slash sneaks through into the param variable
- regsub -all /[cl $::sgml::Wsp]*\$ $param {} param
-
- set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
- set state(haveDocElement) 1
- switch $code {
- 0 {# OK}
- 3 {
- # break
- return {}
- }
- 4 {
- # continue
- # Pretty useless since it closes straightaway
- }
- default {
- return -code $code -errorinfo $::errorInfo $msg
- }
- }
- set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
- switch $code {
- 0 {# OK}
- 3 {
- # break
- return {}
- }
- 4 {
- # continue
- # skip sibling nodes
- set state(continue:tag) [lindex $state(stack) end]
- set state(continue:level) 1
- set state(mode) continue
- continue
- }
- default {
- return -code $code -errorinfo $::errorInfo $msg
- }
- }
-
- }
-
- *,1,* {
- # Processing instructions or XML declaration
- switch -glob -- $tag {
-
- {\?xml} {
- # XML Declaration
- if {$state(haveXMLDecl)} {
- uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
- } elseif {![regexp {\?$} $param]} {
- uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
- } else {
-
- # We can do the parsing in one step with Tcl 8.1 RE's
- # This has the benefit of performing better WF checking
-
- set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]
-
- if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
- # Otherwise we must fallback to 8.0.
- # This won't detect certain well-formedness errors
-
- # Get the version number
- if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
- if {[string compare $version "1.0"]} {
- # Should we support future versions?
- # At least 1.X?
- uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
- }
- } else {
- uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
- }
-
- # Get the encoding declaration
- set encoding {}
- regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
- regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
-
- # Get the standalone declaration
- set standalone {}
- regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
- regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
-
- # Invoke the callback
- uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
-
- } elseif {$matches == 0} {
- uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
- } else {
-
- # Invoke the callback
- uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
-
- }
-
- }
-
- }
-
- {\?*} {
- # Processing instruction
- set tag [string range $tag 1 end]
- if {[regsub {\?$} $tag {} tag]} {
- if {[string length [string trim $param]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
- }
- } elseif {![regexp ^$Name\$ $tag]} {
- uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
- } elseif {[regexp {[xX][mM][lL]} $tag]} {
- uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
- } elseif {![regsub {\?$} $param {} param]} {
- uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
- }
- set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
- switch $code {
- 0 {# OK}
- 3 {
- # break
- return {}
- }
- 4 {
- # continue
- # skip sibling nodes
- set state(continue:tag) [lindex $state(stack) end]
- set state(continue:level) 1
- set state(mode) continue
- continue
- }
- default {
- return -code $code -errorinfo $::errorInfo $msg
- }
- }
- }
-
- !DOCTYPE {
- # External entity reference
- # This should move into xml.tcl
- # Parse the params supplied. Looking for Name, ExternalID and MarkupDecl
- set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
- set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
- set externalID {}
- set pubidlit {}
- set systemlit {}
- set externalID {}
- if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
- switch [string toupper $id] {
- SYSTEM {
- if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
- set externalID [list SYSTEM $systemlit] ;# "
- } else {
- uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
- }
- }
- PUBLIC {
- if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
- if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
- set externalID [list PUBLIC $pubidlit $systemlit]
- } else {
- uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
- }
- } else {
- uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
- }
- }
- }
- if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
- lappend externalID $notation
- }
- }
-
- set state(inDTD) 1
-
- ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)
-
- set state(inDTD) 0
-
- }
-
- !--* {
-
- # Start of a comment
- # See if it ends in the same tag, otherwise change the
- # parsing mode
-
- regexp {!--(.*)} $tag discard comm1
- if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
- # processed comment (end in tag)
- uplevel #0 $options(-commentcommand) [list $comm1_1]
- } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
- # processed comment (end in attributes)
- uplevel #0 $options(-commentcommand) [list $comm1$comm2]
- } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
- # processed comment (end in text)
- uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
- } else {
- # start of comment
- set state(mode) comment
- set state(commentdata) "$comm1$param$empty>$text"
- continue
- }
- }
-
- {!\[CDATA\[*} {
-
- regexp {!\[CDATA\[(.*)} $tag discard cdata1
- if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
- # processed CDATA (end in tag)
- PCDATA [array get options] [subst -novariable -nocommand $cdata2]
- set text [subst -novariable -nocommand $text]
- } elseif {[regexp {(.*)]]$} $param discard cdata2]} {
- # processed CDATA (end in attribute)
- # Backslashes in param are quoted at this stage
- PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
- set text [subst -novariable -nocommand $text]
- } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
- # processed CDATA (end in text)
- # Backslashes in param and text are quoted at this stage
- PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
- set text [subst -novariable -nocommand $text]
- } else {
- # start CDATA
- set state(cdata) "$cdata1$param>$text"
- set state(mode) cdata
- continue
- }
-
- }
-
- !ELEMENT -
- !ATTLIST -
- !ENTITY -
- !NOTATION {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
- }
-
- default {
- uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
- }
- }
- }
- *,1,* -
- *,0,/,/ {
- # Syntax error
- uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
- }
- }
-
- # Process character data
-
- if {$state(haveDocElement) && [llength $state(stack)]} {
-
- # Check if the internal DTD entity is in the text
- regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text
-
- # Look for entity references
- if {([array size entities] || \
- [string length $options(-entityreferencecommand)]) && \
- $options(-defaultexpandinternalentities) && \
- [regexp {&[^;]+;} $text]} {
-
- # protect Tcl specials
- # NB. braces and backslashes may already be protected
- regsub -all {\\({|}|\\)} $text {\1} text
- regsub -all {([][$\\{}])} $text {\\\1} text
-
- # Mark entity references
- regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
- set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
- eval $text
- } else {
-
- # Restore protected special characters
- regsub -all {\\([][{}\\])} $text {\1} text
- PCDATA [array get options] $text
- }
- } elseif {[string length [string trim $text]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
- }
-
- }
-
- # If this is the end of the document, close all open containers
- if {$options(-final) && [llength $state(stack)]} {
- eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
- }
-
- return {}
-}
-
-# sgml::DeProtect --
-#
-# Invoke given command after removing protecting backslashes
-# from given text.
-#
-# Arguments:
-# cmd Command to invoke
-# text Text to deprotect
-#
-# Results:
-# Depends on command
-
-proc sgml::DeProtect1 {cmd text} {
- if {[string compare {} $text]} {
- regsub -all {\\([]$[{}\\])} $text {\1} text
- uplevel #0 $cmd [list $text]
- }
-}
-proc sgml::DeProtect {cmd text} {
- set text [lindex $text 0]
- if {[string compare {} $text]} {
- regsub -all {\\([]$[{}\\])} $text {\1} text
- uplevel #0 $cmd [list $text]
- }
-}
-
-# sgml::ParserDelete --
-#
-# Free all memory associated with parser
-#
-# Arguments:
-# var global state array
-#
-# Results:
-# Variables unset
-
-proc sgml::ParserDelete var {
- upvar #0 $var state
-
- if {![info exists state]} {
- return -code error "unknown parser"
- }
-
- catch {unset $state(entities)}
- catch {unset $state(parameterentities)}
- catch {unset $state(elementdecls)}
- catch {unset $state(attlistdecls)}
- catch {unset $state(notationdecls)}
- catch {unset $state(namespaces)}
-
- unset state
-
- return {}
-}
-
-# sgml::ParseEvent:ElementOpen --
-#
-# Start of an element.
-#
-# Arguments:
-# tag Element name
-# attr Attribute list
-# opts Options
-# args further configuration options
-#
-# Options:
-# -empty boolean
-# indicates whether the element was an empty element
-#
-# Results:
-# Modify state and invoke callback
-
-proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
- variable Name
- variable Wsp
-
- array set options $opts
- upvar #0 $options(-statevariable) state
- array set cfg {-empty 0}
- array set cfg $args
- set handleEmpty 0
-
- if {$options(-normalize)} {
- set tag [string toupper $tag]
- }
-
- # Update state
- lappend state(stack) $tag
-
- # Parse attribute list into a key-value representation
- if {[string compare $options(-parseattributelistcommand) {}]} {
- if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
- if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
- uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
- set attr {}
- } else {
-
- # It is most likely that a ">" character was in an attribute value.
- # This manifests itself by ">" appearing in the element's text.
- # In this case the callback should 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.
-
- foreach {msg attlist brokenattr} $attr break
-
- upvar text elemText
- if {[string first > $elemText] >= 0} {
-
- # Now piece the attribute list back together
- regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
- regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
- regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist
-
- # Gotcha: watch out for empty element syntax
- if {[string match */ [string trimright $remattlist]]} {
- set remattlist [string range $remattlist 0 end-1]
- set handleEmpty 1
- set cfg(-empty) 1
- }
-
- append attvalue >$remattvalue
- lappend attlist $attname $attvalue
-
- # Complete parsing the attribute list
- if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
- uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
- set attr {}
- set attlist {}
- } else {
- eval lappend attlist $attr
- }
-
- set attr $attlist
-
- } else {
- uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
- set attr {}
- }
- }
- }
- }
-
- set empty {}
- if {$cfg(-empty) && $options(-reportempty)} {
- set empty {-empty 1}
- }
-
- # Check for namespace declarations
- upvar #0 $options(namespaces) namespaces
- set nsdecls {}
- if {[llength $attr]} {
- array set attrlist $attr
- foreach {attrName attrValue} [array get attrlist xmlns*] {
- unset attrlist($attrName)
- set colon [set prefix {}]
- if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
- switch -glob [string length $colon],[string length $prefix] {
- 0,0 {
- # default NS declaration
- lappend state(defaultNSURI) $attrValue
- lappend state(defaultNS) [llength $state(stack)]
- lappend nsdecls $attrValue {}
- }
- 0,* {
- # Huh?
- }
- *,0 {
- # Error
- uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
- }
- default {
- set namespaces($prefix,[llength $state(stack)]) $attrValue
- lappend nsdecls $attrValue $prefix
- }
- }
- }
- }
- if {[llength $nsdecls]} {
- set nsdecls [list -namespacedecls $nsdecls]
- }
- set attr [array get attrlist]
- }
-
- # Check whether this element has an expanded name
- set ns {}
- if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
- set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
- if {[llength $nsspec]} {
- set nsuri $namespaces([lindex $nsspec 0])
- set ns [list -namespace $nsuri]
- } else {
- uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
- }
- } elseif {[llength $state(defaultNSURI)]} {
- set ns [list -namespace [lindex $state(defaultNSURI) end]]
- }
-
- # Invoke callback
- set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]
-
- # Sometimes empty elements must be handled here (see above)
- if {$code == 0 && $handleEmpty} {
- ParseEvent:ElementClose $tag $opts -empty 1
- }
-
- return -code $code -errorinfo $::errorInfo $msg
-}
-
-# sgml::ParseEvent:ElementClose --
-#
-# End of an element.
-#
-# Arguments:
-# tag Element name
-# opts Options
-# args further configuration options
-#
-# Options:
-# -empty boolean
-# indicates whether the element as an empty element
-#
-# Results:
-# Modify state and invoke callback
-
-proc sgml::ParseEvent:ElementClose {tag opts args} {
- array set options $opts
- upvar #0 $options(-statevariable) state
- array set cfg {-empty 0}
- array set cfg $args
-
- # WF check
- if {[string compare $tag [lindex $state(stack) end]]} {
- uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
- return
- }
-
- # Check whether this element has an expanded name
- upvar #0 $options(namespaces) namespaces
- set ns {}
- if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
- set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
- set ns [list -namespace $nsuri]
- } elseif {[llength $state(defaultNSURI)]} {
- set ns [list -namespace [lindex $state(defaultNSURI) end]]
- }
-
- # Pop namespace stacks, if any
- if {[llength $state(defaultNS)]} {
- if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
- set state(defaultNS) [lreplace $state(defaultNS) end end]
- }
- }
- foreach nsspec [array names namespaces *,[llength $state(stack)]] {
- unset namespaces($nsspec)
- }
-
- # Update state
- set state(stack) [lreplace $state(stack) end end]
-
- set empty {}
- if {$cfg(-empty) && $options(-reportempty)} {
- set empty {-empty 1}
- }
-
- # Invoke callback
- # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
- set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
- return -code $code -errorinfo $::errorInfo $msg
-}
-
-# sgml::PCDATA --
-#
-# Process PCDATA before passing to application
-#
-# Arguments:
-# opts options
-# pcdata Character data to be processed
-#
-# Results:
-# Checks that characters are legal,
-# checks -ignorewhitespace setting.
-
-proc sgml::PCDATA {opts pcdata} {
- array set options $opts
-
- if {$options(-ignorewhitespace) && \
- ![string length [string trim $pcdata]]} {
- return {}
- }
-
- if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
- upvar \#0 $options(-statevariable) state
- uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
- }
-
- uplevel \#0 $options(-characterdatacommand) [list $pcdata]
-}
-
-# sgml::Normalize --
-#
-# Perform name normalization if required
-#
-# Arguments:
-# name name to normalize
-# req normalization required
-#
-# Results:
-# Name returned as upper-case if normalization required
-
-proc sgml::Normalize {name req} {
- if {$req} {
- return [string toupper $name]
- } else {
- return $name
- }
-}
-
-# sgml::Entity --
-#
-# Resolve XML entity references (syntax: &xxx;).
-#
-# Arguments:
-# opts options
-# entityrefcmd application callback for entity references
-# pcdatacmd application callback for character data
-# entities name of array containing entity definitions.
-# ref entity reference (the "xxx" bit)
-#
-# Results:
-# Returns substitution text for given entity.
-
-proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
- array set options $opts
- upvar #0 $options(-statevariable) state
-
- if {![string length $entities]} {
- set entities [namespace current]::EntityPredef
- }
-
- # SRB: Bug fix 2008-11-18 #812051: surround case labels in braces for compatibility with Freewrap
- switch -glob -- $ref {
- {%*} {
- # Parameter entity - not recognised outside of a DTD
- }
- {#x*} {
- # Character entity - hex
- if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
- return -code error "malformed character entity \"$ref\""
- }
- uplevel #0 $pcdatacmd [list $char]
-
- return {}
-
- }
- {#*} {
- # Character entity - decimal
- if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
- return -code error "malformed character entity \"$ref\""
- }
- uplevel #0 $pcdatacmd [list $char]
-
- return {}
-
- }
- default {
- # General entity
- upvar #0 $entities map
- if {[info exists map($ref)]} {
-
- if {![regexp {<|&} $map($ref)]} {
-
- # Simple text replacement - optimise
- uplevel #0 $pcdatacmd [list $map($ref)]
-
- return {}
-
- }
-
- # Otherwise an additional round of parsing is required.
- # This only applies to XML, since HTML doesn't have general entities
-
- # Must parse the replacement text for start & end tags, etc
- # This text must be self-contained: balanced closing tags, and so on
-
- set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
- set options(-final) 0
- eval parseEvent [list $tokenised] [array get options]
-
- return {}
-
- } elseif {[string compare $entityrefcmd "::sgml::noop"]} {
-
- set result [uplevel #0 $entityrefcmd [list $ref]]
-
- if {[string length $result]} {
- uplevel #0 $pcdatacmd [list $result]
- }
-
- return {}
-
- } else {
-
- # Reconstitute entity reference
-
- uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]
-
- return {}
-
- }
- }
- }
-
- # If all else fails leave the entity reference untouched
- uplevel #0 $pcdatacmd [list &$ref\;]
-
- return {}
-}
-
-####################################
-#
-# DTD parser for SGML (XML).
-#
-# This DTD actually only handles XML DTDs. Other language's
-# DTD's, such as HTML, must be written in terms of a XML DTD.
-#
-####################################
-
-# sgml::ParseEvent:DocTypeDecl --
-#
-# Entry point for DTD parsing
-#
-# Arguments:
-# opts configuration options
-# docEl document element name
-# pubId public identifier
-# sysId system identifier (a URI)
-# intSSet internal DTD subset
-
-proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
- array set options {}
- array set options $opts
-
- set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
- switch $code {
- 3 {
- # break
- return {}
- }
- 0 -
- 4 {
- # continue
- }
- default {
- return -code $code $err
- }
- }
-
- # Otherwise we'll parse the DTD and report it piecemeal
-
- # The internal DTD subset is processed first (XML 2.8)
- # During this stage, parameter entities are only allowed
- # between markup declarations
-
- ParseDTD:Internal [array get options] $intSSet
-
- # The external DTD subset is processed last (XML 2.8)
- # During this stage, parameter entities may occur anywhere
-
- # We must resolve the external identifier to obtain the
- # DTD data. The application may supply its own resolver.
-
- if {[string length $pubId] || [string length $sysId]} {
- uplevel #0 $options(-externalentitycommand) [list $options(-cmd) $options(-baseuri) $sysId $pubId]
- }
-
- return {}
-}
-
-# sgml::ParseDTD:Internal --
-#
-# Parse the internal DTD subset.
-#
-# Parameter entities are only allowed between markup declarations.
-#
-# Arguments:
-# opts configuration options
-# dtd DTD data
-#
-# Results:
-# Markup declarations parsed may cause callback invocation
-
-proc sgml::ParseDTD:Internal {opts dtd} {
- variable MarkupDeclExpr
- variable MarkupDeclSub
-
- array set options {}
- array set options $opts
-
- upvar #0 $options(-statevariable) state
- upvar #0 $options(parameterentities) PEnts
- upvar #0 $options(externalparameterentities) ExtPEnts
-
- # Bug 583947: remove comments before further processing
- regsub -all {<!--.*?-->} $dtd {} dtd
-
- # Tokenize the DTD
-
- # Protect Tcl special characters
- regsub -all {([{}\\])} $dtd {\\\1} dtd
-
- regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd
-
- # Entities may have angle brackets in their replacement
- # text, which breaks the RE processing. So, we must
- # use a similar technique to processing doc instances
- # to rebuild the declarations from the pieces
-
- set mode {} ;# normal
- set delimiter {}
- set name {}
- set param {}
-
- set state(inInternalDTD) 1
-
- # Process the tokens
- foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {
-
- # Keep track of line numbers
- incr state(line) [regsub -all \n $text {} discard]
-
- ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
-
- ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param
-
- # There may be parameter entity references between markup decls
-
- if {[regexp {%.*;} $text]} {
-
- # Protect Tcl special characters
- regsub -all {([{}\\])} $text {\\\1} text
-
- regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text
-
- set PElist "\{$text\}"
- set PElist [lreplace $PElist end end]
- foreach {text entref} $PElist {
- if {[string length [string trim $text]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"]
- }
-
- # Expand parameter entity and recursively parse
- # BUG: no checks yet for recursive entity references
-
- if {[info exists PEnts($entref)]} {
- set externalParser [$options(-cmd) entityparser]
- $externalParser parse $PEnts($entref) -dtdsubset internal
- } elseif {[info exists ExtPEnts($entref)]} {
- set externalParser [$options(-cmd) entityparser]
- $externalParser parse $ExtPEnts($entref) -dtdsubset external
- #$externalParser free
- } else {
- uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""]
- }
- }
-
- }
-
- }
-
- return {}
-}
-
-# sgml::ParseDTD:EntityMode --
-#
-# Perform special processing for various parser modes
-#
-# Arguments:
-# opts configuration options
-# modeVar pass-by-reference mode variable
-# replTextVar pass-by-ref
-# declVar pass-by-ref
-# valueVar pass-by-ref
-# textVar pass-by-ref
-# delimiter delimiter currently in force
-# name
-# param
-#
-# Results:
-# Depends on current mode
-
-proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} {
- upvar 1 $modeVar mode
- upvar 1 $replTextVar replText
- upvar 1 $declVar decl
- upvar 1 $valueVar value
- upvar 1 $textVar text
- array set options $opts
-
- switch $mode {
- {} {
- # Pass through to normal processing section
- }
- entity {
- # Look for closing delimiter
- if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
- append replText <$val1
- DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
- set decl /
- set text $remainder\ $value>$text
- set value {}
- set mode {}
- } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
- append replText <$decl\ $val2
- DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
- set decl /
- set text $remainder>$text
- set value {}
- set mode {}
- } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
- append replText <$decl\ $value>$val3
- DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
- set decl /
- set text $remainder
- set value {}
- set mode {}
- } else {
-
- # Remain in entity mode
- append replText <$decl\ $value>$text
- return -code continue
-
- }
- }
-
- ignore {
- upvar #0 $options(-statevariable) state
-
- if {[regexp {]](.*)$} $decl discard remainder]} {
- set state(condSections) [lreplace $state(condSections) end end]
- set decl $remainder
- set mode {}
- } elseif {[regexp {]](.*)$} $value discard remainder]} {
- set state(condSections) [lreplace $state(condSections) end end]
- regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
- set mode {}
- } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
- set state(condSections) [lreplace $state(condSections) end end]
- set decl /
- set value {}
- set text $remainder
- #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
- set mode {}
- } else {
- set decl /
- }
-
- }
-
- comment {
- # Look for closing comment delimiter
-
- upvar #0 $options(-statevariable) state
-
- if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
- } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
- } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
- } else {
- # comment continues
- append state(commentdata) <$decl\ $value>$text
- set decl /
- set value {}
- set text {}
- }
- }
-
- }
-
- return {}
-}
-
-# sgml::ParseDTD:ProcessMarkupDecl --
-#
-# Process a single markup declaration
-#
-# Arguments:
-# opts configuration options
-# declVar pass-by-ref
-# valueVar pass-by-ref
-# delimiterVar pass-by-ref for current delimiter in force
-# nameVar pass-by-ref
-# modeVar pass-by-ref for current parser mode
-# replTextVar pass-by-ref
-# textVar pass-by-ref
-# paramVar pass-by-ref
-#
-# Results:
-# Depends on markup declaration. May change parser mode
-
-proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} {
- upvar 1 $modeVar mode
- upvar 1 $replTextVar replText
- upvar 1 $textVar text
- upvar 1 $declVar decl
- upvar 1 $valueVar value
- upvar 1 $nameVar name
- upvar 1 $delimiterVar delimiter
- upvar 1 $paramVar param
-
- variable declExpr
- variable ExternalEntityExpr
-
- array set options $opts
- upvar #0 $options(-statevariable) state
-
- switch -glob -- $decl {
-
- / {
- # continuation from entity processing
- }
-
- !ELEMENT {
- # Element declaration
- if {[regexp $declExpr $value discard tag cmodel]} {
- DTD:ELEMENT [array get options] $tag $cmodel
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"]
- }
- }
-
- !ATTLIST {
- # Attribute list declaration
- variable declExpr
- if {[regexp $declExpr $value discard tag attdefns]} {
- if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
- #puts stderr "Stack trace: $::errorInfo\n***\n"
- # Atttribute parsing has bugs at the moment
- #return -code error "$err around line $state(line)"
- return {}
- }
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"]
- }
- }
-
- !ENTITY {
- # Entity declaration
- variable EntityExpr
-
- if {[regexp $EntityExpr $value discard param name value]} {
-
- # Entity replacement text may have a '>' character.
- # In this case, the real delimiter will be in the following
- # text. This is complicated by the possibility of there
- # being several '<','>' pairs in the replacement text.
- # At this point, we are searching for the matching quote delimiter.
-
- if {[regexp $ExternalEntityExpr $value]} {
- DTD:ENTITY [array get options] $name [string trim $param] $value
- } elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {
-
- if {[string length [string trim $value]]} {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
- } else {
- DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
- }
- } elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
- append replText >$text
- set text {}
- set mode entity
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"]
- }
-
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
- }
- }
-
- !NOTATION {
- # Notation declaration
- if {[regexp $declExpr param discard tag notation]} {
- DTD:ENTITY [array get options] $tag $notation
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
- }
- }
-
- !--* {
- # Start of a comment
-
- if {[regexp !--(.*?)--\$ $decl discard data]} {
- if {[string length [string trim $value]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""]
- }
- uplevel #0 $options(-commentcommand) [list $data]
- set decl /
- set value {}
- } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
- regexp !--(.*)\$ $decl discard data1
- uplevel #0 $options(-commentcommand) [list $data1\ $data2]
- set decl /
- set value {}
- } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
- regexp !--(.*)\$ $decl discard data1
- uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
- set decl /
- set value {}
- set text $remainder
- } else {
- regexp !--(.*)\$ $decl discard data1
- set state(commentdata) $data1\ $value>$text
- set decl /
- set value {}
- set text {}
- set mode comment
- }
- }
-
- !*INCLUDE* -
- !*IGNORE* {
- if {$state(inInternalDTD)} {
- uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"]
- }
-
- if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
- # Push conditional section stack, popped by ]]> sequence
-
- if {[regexp {(.*?)]]$} $remainder discard r2]} {
- # section closed immediately
- if {[string length [string trim $r2]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
- }
- } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
- # section closed immediately
- if {[string length [string trim $r2]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
- }
- if {[string length [string trim $r3]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
- }
- } else {
-
- lappend state(condSections) INCLUDE
-
- set parser [$options(-cmd) entityparser]
- $parser parse $remainder\ $value> -dtdsubset external
- #$parser free
-
- if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
- if {[string length [string trim $t1]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
- }
- if {![llength $state(condSections)]} {
- uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
- }
- set state(condSections) [lreplace $state(condSections) end end]
- set text $t2
- }
-
- }
- } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
- # Set ignore mode. Still need a stack
- set mode ignore
-
- if {[regexp {(.*?)]]$} $remainder discard r2]} {
- # section closed immediately
- if {[string length [string trim $r2]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
- }
- } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
- # section closed immediately
- if {[string length [string trim $r2]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
- }
- if {[string length [string trim $r3]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
- }
- } else {
-
- lappend state(condSections) IGNORE
-
- if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
- if {[string length [string trim $t1]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
- }
- if {![llength $state(condSections)]} {
- uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
- }
- set state(condSections) [lreplace $state(condSections) end end]
- set text $t2
- }
-
- }
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"]
- }
-
- }
-
- default {
- if {[regexp {^\?(.*)} $decl discard target]} {
- # Processing instruction
- } else {
- uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""]
- }
- }
- }
-
- return {}
-}
-
-# sgml::ParseDTD:External --
-#
-# Parse the external DTD subset.
-#
-# Parameter entities are allowed anywhere.
-#
-# Arguments:
-# opts configuration options
-# dtd DTD data
-#
-# Results:
-# Markup declarations parsed may cause callback invocation
-
-proc sgml::ParseDTD:External {opts dtd} {
- variable MarkupDeclExpr
- variable MarkupDeclSub
- variable declExpr
-
- array set options $opts
- upvar #0 $options(parameterentities) PEnts
- upvar #0 $options(externalparameterentities) ExtPEnts
- upvar #0 $options(-statevariable) state
-
- # As with the internal DTD subset, watch out for
- # entities with angle brackets
- set mode {} ;# normal
- set delimiter {}
- set name {}
- set param {}
-
- set oldState 0
- catch {set oldState $state(inInternalDTD)}
- set state(inInternalDTD) 0
-
- # Initialise conditional section stack
- if {![info exists state(condSections)]} {
- set state(condSections) {}
- }
- set startCondSectionDepth [llength $state(condSections)]
-
- while {[string length $dtd]} {
- set progress 0
- set PEref {}
- if {![string compare $mode "ignore"]} {
- set progress 1
- if {[regexp {]]>(.*)} $dtd discard dtd]} {
- set remainder {}
- set mode {} ;# normal
- set state(condSections) [lreplace $state(condSections) end end]
- continue
- } else {
- uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"]
- }
- } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
- set progress 1
- } else {
- set data $dtd
- set dtd {}
- set remainder {}
- }
-
- # Tokenize the DTD (so far)
-
- # Protect Tcl special characters
- regsub -all {([{}\\])} $data {\\\1} dataP
-
- set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]
-
- if {$n} {
- set progress 1
- # All but the last markup declaration should have no text
- set dataP [lrange "{} {} \{$dataP\}" 3 end]
- if {[llength $dataP] > 3} {
- foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
- ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
- ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
-
- if {[string length [string trim $text]]} {
- # check for conditional section close
- if {[regexp {]]>(.*)$} $text discard text]} {
- if {[string length [string trim $text]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
- }
- if {![llength $state(condSections)]} {
- uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
- }
- set state(condSections) [lreplace $state(condSections) end end]
- if {![string compare $mode "ignore"]} {
- set mode {} ;# normal
- }
- } else {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
- }
- }
- }
- }
- # Do the last declaration
- foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
- ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
- ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
- }
- }
-
- # Now expand the PE reference, if any
- switch -glob $mode,[string length $PEref],$n {
- ignore,0,* {
- set dtd $text
- }
- ignore,*,* {
- set dtd $text$remainder
- }
- *,0,0 {
- set dtd $data
- }
- *,0,* {
- set dtd $text
- }
- *,*,0 {
- if {[catch {append data $PEnts($PEref)}]} {
- if {[info exists ExtPEnts($PEref)]} {
- set externalParser [$options(-cmd) entityparser]
- $externalParser parse $ExtPEnts($PEref) -dtdsubset external
- #$externalParser free
- } else {
- uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
- }
- }
- set dtd $data$remainder
- }
- default {
- if {[catch {append text $PEnts($PEref)}]} {
- if {[info exists ExtPEnts($PEref)]} {
- set externalParser [$options(-cmd) entityparser]
- $externalParser parse $ExtPEnts($PEref) -dtdsubset external
- #$externalParser free
- } else {
- uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
- }
- }
- set dtd $text$remainder
- }
- }
-
- # Check whether a conditional section has been terminated
- if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
- if {![regexp <.*> $t1]} {
- if {[string length [string trim $t1]]} {
- uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
- }
- if {![llength $state(condSections)]} {
- uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
- }
- set state(condSections) [lreplace $state(condSections) end end]
- if {![string compare $mode "ignore"]} {
- set mode {} ;# normal
- }
- set dtd $t2
- set progress 1
- }
- }
-
- if {!$progress} {
- # No parameter entity references were found and
- # the text does not contain a well-formed markup declaration
- # Avoid going into an infinite loop
- upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"]
- break
- }
- }
-
- set state(inInternalDTD) $oldState
-
- # Check that conditional sections have been closed properly
- if {[llength $state(condSections)] > $startCondSectionDepth} {
- uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"]
- }
- if {[llength $state(condSections)] < $startCondSectionDepth} {
- uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"]
- }
-
- return {}
-}
-
-# Procedures for handling the various declarative elements in a DTD.
-# New elements may be added by creating a procedure of the form
-# parse:DTD:_element_
-
-# For each of these procedures, the various regular expressions they use
-# are created outside of the proc to avoid overhead at runtime
-
-# sgml::DTD:ELEMENT --
-#
-# <!ELEMENT ...> defines an element.
-#
-# The content model for the element is stored in the contentmodel array,
-# indexed by the element name. The content model is parsed into the
-# following list form:
-#
-# {} Content model is EMPTY.
-# Indicated by an empty list.
-# * Content model is ANY.
-# Indicated by an asterix.
-# {ELEMENT ...}
-# Content model is element-only.
-# {MIXED {element1 element2 ...}}
-# Content model is mixed (PCDATA and elements).
-# The second element of the list contains the
-# elements that may occur. #PCDATA is assumed
-# (ie. the list is normalised).
-#
-# Arguments:
-# opts configuration options
-# name element GI
-# modspec unparsed content model specification
-
-proc sgml::DTD:ELEMENT {opts name modspec} {
- variable Wsp
- array set options $opts
-
- upvar #0 $options(elementdecls) elements
-
- if {$options(-validate) && [info exists elements($name)]} {
- eval $options(-errorcommand) [list elementdeclared "element \"$name\" already declared"]
- } else {
- switch -- $modspec {
- EMPTY {
- set elements($name) {}
- uplevel #0 $options(-elementdeclcommand) $name {{}}
- }
- ANY {
- set elements($name) *
- uplevel #0 $options(-elementdeclcommand) $name *
- }
- default {
- # Don't parse the content model for now,
- # just pass the model to the application
- if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
- set cm($name) [list MIXED [split $mtoks |]]
- } elseif {0} {
- if {[catch {CModelParse $state(state) $value} result]} {
- eval $options(-errorcommand) [list element? $result]
- } else {
- set cm($id) [list ELEMENT $result]
- }
- } else {
- set elements($name) $modspec
- uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
- }
- }
- }
- }
-}
-
-# sgml::CModelParse --
-#
-# Parse an element content model (non-mixed).
-# A syntax tree is constructed.
-# A transition table is built next.
-#
-# This is going to need alot of work!
-#
-# Arguments:
-# state state array variable
-# value the content model data
-#
-# Results:
-# A Tcl list representing the content model.
-
-proc sgml::CModelParse {state value} {
- upvar #0 $state var
-
- # First build syntax tree
- set syntaxTree [CModelMakeSyntaxTree $state $value]
-
- # Build transition table
- set transitionTable [CModelMakeTransitionTable $state $syntaxTree]
-
- return [list $syntaxTree $transitionTable]
-}
-
-# sgml::CModelMakeSyntaxTree --
-#
-# Construct a syntax tree for the regular expression.
-#
-# Syntax tree is represented as a Tcl list:
-# rep {:choice|:seq {{rep list1} {rep list2} ...}}
-# where: rep is repetition character, *, + or ?. {} for no repetition
-# listN is nested expression or Name
-#
-# Arguments:
-# spec Element specification
-#
-# Results:
-# Syntax tree for element spec as nested Tcl list.
-#
-# Examples:
-# (memo)
-# {} {:seq {{} memo}}
-# (front, body, back?)
-# {} {:seq {{} front} {{} body} {? back}}
-# (head, (p | list | note)*, div2*)
-# {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
-# (p | a | ul)+
-# + {:choice {{} p} {{} a} {{} ul}}
-
-proc sgml::CModelMakeSyntaxTree {state spec} {
- upvar #0 $state var
- variable Wsp
- variable name
-
- # Translate the spec into a Tcl list.
-
- # None of the Tcl special characters are allowed in a content model spec.
- if {[regexp {\$|\[|\]|\{|\}} $spec]} {
- return -code error "illegal characters in specification"
- }
-
- regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
- regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
- regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec
-
- array set var {stack {} state start}
- eval $spec
-
- # Peel off the outer seq, its redundant
- return [lindex [lindex $var(stack) 1] 0]
-}
-
-# sgml::CModelSTname --
-#
-# Processes a name in a content model spec.
-#
-# Arguments:
-# state state array variable
-# name name specified
-# rep repetition operator
-# cs choice or sequence delimiter
-#
-# Results:
-# See CModelSTcp.
-
-proc sgml::CModelSTname {state name rep cs args} {
- if {[llength $args]} {
- return -code error "syntax error in specification: \"$args\""
- }
-
- CModelSTcp $state $name $rep $cs
-}
-
-# sgml::CModelSTcp --
-#
-# Process a content particle.
-#
-# Arguments:
-# state state array variable
-# name name specified
-# rep repetition operator
-# cs choice or sequence delimiter
-#
-# Results:
-# The content particle is added to the current group.
-
-proc sgml::CModelSTcp {state cp rep cs} {
- upvar #0 $state var
-
- switch -glob -- [lindex $var(state) end]=$cs {
- start= {
- set var(state) [lreplace $var(state) end end end]
- # Add (dummy) grouping, either choice or sequence will do
- CModelSTcsSet $state ,
- CModelSTcpAdd $state $cp $rep
- }
- :choice= -
- :seq= {
- set var(state) [lreplace $var(state) end end end]
- CModelSTcpAdd $state $cp $rep
- }
- start=| -
- start=, {
- set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
- CModelSTcsSet $state $cs
- CModelSTcpAdd $state $cp $rep
- }
- :choice=| -
- :seq=, {
- CModelSTcpAdd $state $cp $rep
- }
- :choice=, -
- :seq=| {
- return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
- }
- end=* {
- return -code error "syntax error in specification: no delimiter before \"$cp\""
- }
- default {
- return -code error "syntax error"
- }
- }
-
-}
-
-# sgml::CModelSTcsSet --
-#
-# Start a choice or sequence on the stack.
-#
-# Arguments:
-# state state array
-# cs choice oir sequence
-#
-# Results:
-# state is modified: end element of state is appended.
-
-proc sgml::CModelSTcsSet {state cs} {
- upvar #0 $state var
-
- set cs [expr {$cs == "," ? ":seq" : ":choice"}]
-
- if {[llength $var(stack)]} {
- set var(stack) [lreplace $var(stack) end end $cs]
- } else {
- set var(stack) [list $cs {}]
- }
-}
-
-# sgml::CModelSTcpAdd --
-#
-# Append a content particle to the top of the stack.
-#
-# Arguments:
-# state state array
-# cp content particle
-# rep repetition
-#
-# Results:
-# state is modified: end element of state is appended.
-
-proc sgml::CModelSTcpAdd {state cp rep} {
- upvar #0 $state var
-
- if {[llength $var(stack)]} {
- set top [lindex $var(stack) end]
- lappend top [list $rep $cp]
- set var(stack) [lreplace $var(stack) end end $top]
- } else {
- set var(stack) [list $rep $cp]
- }
-}
-
-# sgml::CModelSTopenParen --
-#
-# Processes a '(' in a content model spec.
-#
-# Arguments:
-# state state array
-#
-# Results:
-# Pushes stack in state array.
-
-proc sgml::CModelSTopenParen {state args} {
- upvar #0 $state var
-
- if {[llength $args]} {
- return -code error "syntax error in specification: \"$args\""
- }
-
- lappend var(state) start
- lappend var(stack) [list {} {}]
-}
-
-# sgml::CModelSTcloseParen --
-#
-# Processes a ')' in a content model spec.
-#
-# Arguments:
-# state state array
-# rep repetition
-# cs choice or sequence delimiter
-#
-# Results:
-# Stack is popped, and former top of stack is appended to previous element.
-
-proc sgml::CModelSTcloseParen {state rep cs args} {
- upvar #0 $state var
-
- if {[llength $args]} {
- return -code error "syntax error in specification: \"$args\""
- }
-
- set cp [lindex $var(stack) end]
- set var(stack) [lreplace $var(stack) end end]
- set var(state) [lreplace $var(state) end end]
- CModelSTcp $state $cp $rep $cs
-}
-
-# sgml::CModelMakeTransitionTable --
-#
-# Given a content model's syntax tree, constructs
-# the transition table for the regular expression.
-#
-# See "Compilers, Principles, Techniques, and Tools",
-# Aho, Sethi and Ullman. Section 3.9, algorithm 3.5.
-#
-# Arguments:
-# state state array variable
-# st syntax tree
-#
-# Results:
-# The transition table is returned, as a key/value Tcl list.
-
-proc sgml::CModelMakeTransitionTable {state st} {
- upvar #0 $state var
-
- # Construct nullable, firstpos and lastpos functions
- array set var {number 0}
- foreach {nullable firstpos lastpos} [ \
- TraverseDepth1st $state $st {
- # Evaluated for leaf nodes
- # Compute nullable(n)
- # Compute firstpos(n)
- # Compute lastpos(n)
- set nullable [nullable leaf $rep $name]
- set firstpos [list {} $var(number)]
- set lastpos [list {} $var(number)]
- set var(pos:$var(number)) $name
- } {
- # Evaluated for nonterminal nodes
- # Compute nullable, firstpos, lastpos
- set firstpos [firstpos $cs $firstpos $nullable]
- set lastpos [lastpos $cs $lastpos $nullable]
- set nullable [nullable nonterm $rep $cs $nullable]
- } \
- ] break
-
- set accepting [incr var(number)]
- set var(pos:$accepting) #
-
- # var(pos:N) maps from position to symbol.
- # Construct reverse map for convenience.
- # NB. A symbol may appear in more than one position.
- # var is about to be reset, so use different arrays.
-
- foreach {pos symbol} [array get var pos:*] {
- set pos [lindex [split $pos :] 1]
- set pos2symbol($pos) $symbol
- lappend sym2pos($symbol) $pos
- }
-
- # Construct the followpos functions
- catch {unset var}
- followpos $state $st $firstpos $lastpos
-
- # Construct transition table
- # Dstates is [union $marked $unmarked]
- set unmarked [list [lindex $firstpos 1]]
- while {[llength $unmarked]} {
- set T [lindex $unmarked 0]
- lappend marked $T
- set unmarked [lrange $unmarked 1 end]
-
- # Find which input symbols occur in T
- set symbols {}
- foreach pos $T {
- if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
- lappend symbols $pos2symbol($pos)
- }
- }
- foreach a $symbols {
- set U {}
- foreach pos $sym2pos($a) {
- if {[lsearch $T $pos] >= 0} {
- # add followpos($pos)
- if {$var($pos) == {}} {
- lappend U $accepting
- } else {
- eval lappend U $var($pos)
- }
- }
- }
- set U [makeSet $U]
- if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
- lappend unmarked $U
- }
- set Dtran($T,$a) $U
- }
-
- }
-
- return [list [array get Dtran] [array get sym2pos] $accepting]
-}
-
-# sgml::followpos --
-#
-# Compute the followpos function, using the already computed
-# firstpos and lastpos.
-#
-# Arguments:
-# state array variable to store followpos functions
-# st syntax tree
-# firstpos firstpos functions for the syntax tree
-# lastpos lastpos functions
-#
-# Results:
-# followpos functions for each leaf node, in name/value format
-
-proc sgml::followpos {state st firstpos lastpos} {
- upvar #0 $state var
-
- switch -- [lindex [lindex $st 1] 0] {
- :seq {
- for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
- followpos $state [lindex [lindex $st 1] $i] \
- [lindex [lindex $firstpos 0] [expr $i - 1]] \
- [lindex [lindex $lastpos 0] [expr $i - 1]]
- foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
- eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
- set var($pos) [makeSet $var($pos)]
- }
- }
- }
- :choice {
- for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
- followpos $state [lindex [lindex $st 1] $i] \
- [lindex [lindex $firstpos 0] [expr $i - 1]] \
- [lindex [lindex $lastpos 0] [expr $i - 1]]
- }
- }
- default {
- # No action at leaf nodes
- }
- }
-
- switch -- [lindex $st 0] {
- ? {
- # We having nothing to do here ! Doing the same as
- # for * effectively converts this qualifier into the other.
- }
- * {
- foreach pos [lindex $lastpos 1] {
- eval lappend var($pos) [lindex $firstpos 1]
- set var($pos) [makeSet $var($pos)]
- }
- }
- }
-
-}
-
-# sgml::TraverseDepth1st --
-#
-# Perform depth-first traversal of a tree.
-# A new tree is constructed, with each node computed by f.
-#
-# Arguments:
-# state state array variable
-# t The tree to traverse, a Tcl list
-# leaf Evaluated at a leaf node
-# nonTerm Evaluated at a nonterminal node
-#
-# Results:
-# A new tree is returned.
-
-proc sgml::TraverseDepth1st {state t leaf nonTerm} {
- upvar #0 $state var
-
- set nullable {}
- set firstpos {}
- set lastpos {}
-
- switch -- [lindex [lindex $t 1] 0] {
- :seq -
- :choice {
- set rep [lindex $t 0]
- set cs [lindex [lindex $t 1] 0]
-
- foreach child [lrange [lindex $t 1] 1 end] {
- foreach {childNullable childFirstpos childLastpos} \
- [TraverseDepth1st $state $child $leaf $nonTerm] break
- lappend nullable $childNullable
- lappend firstpos $childFirstpos
- lappend lastpos $childLastpos
- }
-
- eval $nonTerm
- }
- default {
- incr var(number)
- set rep [lindex [lindex $t 0] 0]
- set name [lindex [lindex $t 1] 0]
- eval $leaf
- }
- }
-
- return [list $nullable $firstpos $lastpos]
-}
-
-# sgml::firstpos --
-#
-# Computes the firstpos function for a nonterminal node.
-#
-# Arguments:
-# cs node type, choice or sequence
-# firstpos firstpos functions for the subtree
-# nullable nullable functions for the subtree
-#
-# Results:
-# firstpos function for this node is returned.
-
-proc sgml::firstpos {cs firstpos nullable} {
- switch -- $cs {
- :seq {
- set result [lindex [lindex $firstpos 0] 1]
- for {set i 0} {$i < [llength $nullable]} {incr i} {
- if {[lindex [lindex $nullable $i] 1]} {
- eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
- } else {
- break
- }
- }
- }
- :choice {
- foreach child $firstpos {
- eval lappend result $child
- }
- }
- }
-
- return [list $firstpos [makeSet $result]]
-}
-
-# sgml::lastpos --
-#
-# Computes the lastpos function for a nonterminal node.
-# Same as firstpos, only logic is reversed
-#
-# Arguments:
-# cs node type, choice or sequence
-# lastpos lastpos functions for the subtree
-# nullable nullable functions forthe subtree
-#
-# Results:
-# lastpos function for this node is returned.
-
-proc sgml::lastpos {cs lastpos nullable} {
- switch -- $cs {
- :seq {
- set result [lindex [lindex $lastpos end] 1]
- for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
- if {[lindex [lindex $nullable $i] 1]} {
- eval lappend result [lindex [lindex $lastpos $i] 1]
- } else {
- break
- }
- }
- }
- :choice {
- foreach child $lastpos {
- eval lappend result $child
- }
- }
- }
-
- return [list $lastpos [makeSet $result]]
-}
-
-# sgml::makeSet --
-#
-# Turn a list into a set, ie. remove duplicates.
-#
-# Arguments:
-# s a list
-#
-# Results:
-# A set is returned, which is a list with duplicates removed.
-
-proc sgml::makeSet s {
- foreach r $s {
- if {[llength $r]} {
- set unique($r) {}
- }
- }
- return [array names unique]
-}
-
-# sgml::nullable --
-#
-# Compute the nullable function for a node.
-#
-# Arguments:
-# nodeType leaf or nonterminal
-# rep repetition applying to this node
-# name leaf node: symbol for this node, nonterm node: choice or seq node
-# subtree nonterm node: nullable functions for the subtree
-#
-# Results:
-# Returns nullable function for this branch of the tree.
-
-proc sgml::nullable {nodeType rep name {subtree {}}} {
- switch -glob -- $rep:$nodeType {
- :leaf -
- +:leaf {
- return [list {} 0]
- }
- \\*:leaf -
- \\?:leaf {
- return [list {} 1]
- }
- \\*:nonterm -
- \\?:nonterm {
- return [list $subtree 1]
- }
- :nonterm -
- +:nonterm {
- switch -- $name {
- :choice {
- set result 0
- foreach child $subtree {
- set result [expr $result || [lindex $child 1]]
- }
- }
- :seq {
- set result 1
- foreach child $subtree {
- set result [expr $result && [lindex $child 1]]
- }
- }
- }
- return [list $subtree $result]
- }
- }
-}
-
-# sgml::DTD:ATTLIST --
-#
-# <!ATTLIST ...> defines an attribute list.
-#
-# Arguments:
-# opts configuration opions
-# name Element GI
-# attspec unparsed attribute definitions
-#
-# Results:
-# Attribute list variables are modified.
-
-proc sgml::DTD:ATTLIST {opts name attspec} {
- variable attlist_exp
- variable attlist_enum_exp
- variable attlist_fixed_exp
-
- array set options $opts
-
- # Parse the attribute list. If it were regular, could just use foreach,
- # but some attributes may have values.
- regsub -all {([][$\\])} $attspec {\\\1} attspec
- regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
- regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
- regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec
-
- eval "noop \{$attspec\}"
-
- return {}
-}
-
-# sgml::DTDAttribute --
-#
-# Parse definition of a single attribute.
-#
-# Arguments:
-# callback attribute defn callback
-# name element name
-# var array variable
-# att attribute name
-# type type of this attribute
-# default default value of the attribute
-# value other information
-# text other text (should be empty)
-#
-# Results:
-# Attribute defn added to array, unless it already exists
-
-proc sgml::DTDAttribute args {
- # BUG: Some problems with parameter passing - deal with it later
- foreach {callback name var att type default value text} $args break
-
- upvar #0 $var atts
-
- if {[string length [string trim $text]]} {
- return -code error "unexpected text \"$text\" in attribute definition"
- }
-
- # What about overridden attribute defns?
- # A non-validating app may want to know about them
- # (eg. an editor)
- if {![info exists atts($name/$att)]} {
- set atts($name/$att) [list $type $default $value]
- uplevel #0 $callback [list $name $att $type $default $value]
- }
-
- return {}
-}
-
-# sgml::DTD:ENTITY --
-#
-# <!ENTITY ...> declaration.
-#
-# Callbacks:
-# -entitydeclcommand for general entity declaration
-# -unparsedentitydeclcommand for unparsed external entity declaration
-# -parameterentitydeclcommand for parameter entity declaration
-#
-# Arguments:
-# opts configuration options
-# name name of entity being defined
-# param whether a parameter entity is being defined
-# value unparsed replacement text
-#
-# Results:
-# Modifies the caller's entities array variable
-
-proc sgml::DTD:ENTITY {opts name param value} {
-
- array set options $opts
-
- if {[string compare % $param]} {
- # Entity declaration - general or external
- upvar #0 $options(entities) ents
- upvar #0 $options(extentities) externals
-
- if {[info exists ents($name)] || [info exists externals($name)]} {
- eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
- } else {
- if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
- return -code error "unable to parse entity declaration due to \"$value\""
- }
- switch -glob [lindex $value 0],[lindex $value 3] {
- internal, {
- set ents($name) [EntitySubst [array get options] [lindex $value 1]]
- uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
- }
- internal,* {
- return -code error "unexpected NDATA declaration"
- }
- external, {
- set externals($name) [lrange $value 1 2]
- uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
- }
- external,* {
- set externals($name) [lrange $value 1 3]
- uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
- }
- default {
- return -code error "internal error: unexpected parser state"
- }
- }
- }
- } else {
- # Parameter entity declaration
- upvar #0 $options(parameterentities) PEnts
- upvar #0 $options(externalparameterentities) ExtPEnts
-
- if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
- eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
- } else {
- if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
- return -code error "unable to parse parameter entity declaration due to \"$value\""
- }
- if {[string length [lindex $value 3]]} {
- return -code error "NDATA illegal in parameter entity declaration"
- }
- switch [lindex $value 0] {
- internal {
- # Substitute character references and PEs (XML: 4.5)
- set value [EntitySubst [array get options] [lindex $value 1]]
-
- set PEnts($name) $value
- uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
- }
- external -
- default {
- # Get the replacement text now.
- # Could wait until the first reference, but easier
- # to just do it now.
-
- set token [uri::geturl [uri::resolve $options(-baseuri) [lindex $value 1]]]
-
- set ExtPEnts($name) [lindex [array get $token data] 1]
- uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
- }
- }
- }
- }
-}
-
-# sgml::EntitySubst --
-#
-# Perform entity substitution on an entity replacement text.
-# This differs slightly from other substitution procedures,
-# because only parameter and character entity substitution
-# is performed, not general entities.
-# See XML Rec. section 4.5.
-#
-# Arguments:
-# opts configuration options
-# value Literal entity value
-#
-# Results:
-# Expanded replacement text
-
-proc sgml::EntitySubst {opts value} {
- array set options $opts
-
- # Protect Tcl special characters
- regsub -all {([{}\\])} $value {\\\1} value
-
- # Find entity references
- regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value
-
- set result [subst $value]
-
- return $result
-}
-
-# sgml::EntitySubstValue --
-#
-# Handle a single character or parameter entity substitution
-#
-# Arguments:
-# PEvar array variable containing PE declarations
-# ref character or parameter entity reference
-#
-# Results:
-# Replacement text
-
-proc sgml::EntitySubstValue {PEvar 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 3 end] %x hex
- return [format %c $hex]
- }
- {&#*} {
- return [format %c [string range $ref 2 end]]
- }
- {%*} {
- upvar #0 $PEvar PEs
- set ref [string range $ref 1 end]
- if {[info exists PEs($ref)]} {
- return $PEs($ref)
- } else {
- return -code error "parameter entity \"$ref\" not declared"
- }
- }
- default {
- return -code error "internal error - unexpected entity reference"
- }
- }
- return {}
-}
-
-# sgml::DTD:NOTATION --
-#
-# Process notation declaration
-#
-# Arguments:
-# opts configuration options
-# name notation name
-# value unparsed notation spec
-
-proc sgml::DTD:NOTATION {opts name value} {
- return {}
-
- variable notation_exp
- upvar opts state
-
- if {[regexp $notation_exp $value x scheme data] == 2} {
- } else {
- eval $state(-errorcommand) [list notationvalue "notation value \"$value\" incorrectly specified"]
- }
-}
-
-# sgml::ResolveEntity --
-#
-# Default entity resolution routine
-#
-# Arguments:
-# cmd command of parent parser
-# base base URL for relative URLs
-# sysId system identifier
-# pubId public identifier
-
-proc sgml::ResolveEntity {cmd base sysId pubId} {
- variable ParseEventNum
-
- if {[catch {uri::resolve $base $sysId} url]} {
- return -code error "unable to resolve system identifier \"$sysId\""
- }
- if {[catch {uri::geturl $url} token]} {
- return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
- }
-
- upvar #0 $token data
-
- set parser [uplevel #0 $cmd entityparser]
-
- set body {}
- catch {set body $data(body)}
- catch {set body $data(data)}
- if {[string length $body]} {
- uplevel #0 $parser parse [list $body] -dtdsubset external
- }
- $parser free
-
- return {}
-}
generated by cgit v0.12 at 2024-10-13 01:04:43 (GMT)