home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclxml2.0 / sgmlparser.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  78.3 KB  |  2,750 lines
  1. # sgmlparser.tcl --
  2. #
  3. #    This file provides the generic part of a parser for SGML-based
  4. #    languages, namely HTML and XML.
  5. #
  6. #    NB.  It is a misnomer.  There is no support for parsing
  7. #    arbitrary SGML as such.
  8. #
  9. #    See sgml.tcl for variable definitions.
  10. #
  11. # Copyright (c) 1998-2001 Zveno Pty Ltd
  12. # http://www.zveno.com/
  13. #
  14. # Zveno makes this software available free of charge for any purpose.
  15. # Copies may be made of this software but all of this notice must be included
  16. # on any copy.
  17. #
  18. # The software was developed for research purposes only and Zveno does not
  19. # warrant that it is error free or fit for any purpose.  Zveno disclaims any
  20. # liability for all claims, expenses, losses, damages and costs any user may
  21. # incur as a result of using, copying or modifying this software.
  22. #
  23. # Copyright (c) 1997 ANU and CSIRO on behalf of the
  24. # participants in the CRC for Advanced Computational Systems ('ACSys').
  25. # 
  26. # ACSys makes this software and all associated data and documentation 
  27. # ('Software') available free of charge for any purpose.  You may make copies 
  28. # of the Software but you must include all of this notice on any copy.
  29. # 
  30. # The Software was developed for research purposes and ACSys does not warrant
  31. # that it is error free or fit for any purpose.  ACSys disclaims any
  32. # liability for all claims, expenses, losses, damages and costs any user may
  33. # incur as a result of using, copying or modifying the Software.
  34. #
  35. # $Id: sgmlparser.tcl,v 1.17 2001/08/02 05:11:53 balls Exp $
  36.  
  37. package require sgml 1.8
  38.  
  39. package provide sgmlparser 1.0
  40.  
  41. namespace eval sgml {
  42.     namespace export tokenise parseEvent
  43.  
  44.     namespace export parseDTD
  45.  
  46.     # NB. Most namespace variables are defined in sgml-8.[01].tcl
  47.     # to account for differences between versions of Tcl.
  48.     # This especially includes the regular expressions used.
  49.  
  50.     variable ParseEventNum
  51.     if {![info exists ParseEventNum]} {
  52.     set ParseEventNum 0
  53.     }
  54.     variable ParseDTDnum
  55.     if {![info exists ParseDTDNum]} {
  56.     set ParseDTDNum 0
  57.     }
  58.  
  59.     variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
  60.     variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)
  61.  
  62.     #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
  63.     #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
  64.     variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
  65.     variable MarkupDeclSub "\} {\\1} {\\2} \{"
  66.  
  67.     variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$
  68.  
  69.     variable StdOptions
  70.     array set StdOptions [list \
  71.     -elementstartcommand        [namespace current]::noop    \
  72.     -elementendcommand        [namespace current]::noop    \
  73.     -characterdatacommand        [namespace current]::noop    \
  74.     -processinginstructioncommand    [namespace current]::noop    \
  75.     -externalentitycommand        {}                \
  76.     -xmldeclcommand            [namespace current]::noop    \
  77.     -doctypecommand            [namespace current]::noop    \
  78.     -commentcommand            [namespace current]::noop    \
  79.     -entitydeclcommand        [namespace current]::noop    \
  80.     -unparsedentitydeclcommand    [namespace current]::noop    \
  81.     -parameterentitydeclcommand    [namespace current]::noop    \
  82.     -notationdeclcommand        [namespace current]::noop    \
  83.     -elementdeclcommand        [namespace current]::noop    \
  84.     -attlistdeclcommand        [namespace current]::noop    \
  85.     -paramentityparsing        1                \
  86.     -defaultexpandinternalentities    1                \
  87.     -startdoctypedeclcommand    [namespace current]::noop    \
  88.     -enddoctypedeclcommand        [namespace current]::noop    \
  89.     -entityreferencecommand        {}                \
  90.     -warningcommand            [namespace current]::noop    \
  91.     -errorcommand            [namespace current]::Error    \
  92.     -final                1                \
  93.     -validate            0                \
  94.     -baseurl            {}                \
  95.     -name                {}                \
  96.     -emptyelement            [namespace current]::EmptyElement    \
  97.     -parseattributelistcommand    [namespace current]::noop    \
  98.     -parseentitydeclcommand        [namespace current]::noop    \
  99.     -normalize            1                \
  100.     -internaldtd            {}                \
  101.     -reportempty            0                \
  102.     ]
  103. }
  104.  
  105. # sgml::tokenise --
  106. #
  107. #    Transform the given HTML/XML text into a Tcl list.
  108. #
  109. # Arguments:
  110. #    sgml        text to tokenize
  111. #    elemExpr    RE to recognise tags
  112. #    elemSub        transform for matched tags
  113. #    args        options
  114. #
  115. # Valid Options:
  116. #    -final        boolean        True if no more data is to be supplied
  117. #    -statevariable    varName        Name of a variable used to store info
  118. #
  119. # Results:
  120. #    Returns a Tcl list representing the document.
  121.  
  122. proc sgml::tokenise {sgml elemExpr elemSub args} {
  123.     array set options {-final 1}
  124.     catch {array set options $args}
  125.     set options(-final) [Boolean $options(-final)]
  126.  
  127.     # If the data is not final then there must be a variable to store
  128.     # unused data.
  129.     if {!$options(-final) && ![info exists options(-statevariable)]} {
  130.     return -code error {option "-statevariable" required if not final}
  131.     }
  132.  
  133.     # Pre-process stage
  134.     #
  135.     # Extract the internal DTD subset, if any
  136.  
  137.     catch {upvar #0 $options(-internaldtdvariable) dtd}
  138.     if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
  139.     regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
  140.     }
  141.  
  142.     # Protect Tcl special characters
  143.     regsub -all {([{}\\])} $sgml {\\\1} sgml
  144.  
  145.     # Do the translation
  146.  
  147.     if {[info exists options(-statevariable)]} {
  148.     upvar #0 $opts(-statevariable) unused
  149.     if {[info exists unused]} {
  150.         regsub -all $elemExpr $unused$sgml $elemSub sgml
  151.         unset unused
  152.     } else {
  153.         regsub -all $elemExpr $sgml $elemSub sgml
  154.     }
  155.     set sgml "{} {} {} \{$sgml\}"
  156.  
  157.     # Performance note (Tcl 8.0):
  158.     #    Use of lindex, lreplace will cause parsing to list object
  159.  
  160.     if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text unused]} {
  161.         set sgml [lreplace $sgml end end $text]
  162.     }
  163.  
  164.     } else {
  165.  
  166.     # Performance note (Tcl 8.0):
  167.     #    In this case, no conversion to list object is performed
  168.  
  169.     regsub -all $elemExpr $sgml $elemSub sgml
  170.     set sgml "{} {} {} \{$sgml\}"
  171.     }
  172.  
  173.     return $sgml
  174.  
  175. }
  176.  
  177. # sgml::parseEvent --
  178. #
  179. #    Produces an event stream for a XML/HTML document,
  180. #    given the Tcl list format returned by tokenise.
  181. #
  182. #    This procedure checks that the document is well-formed,
  183. #    and throws an error if the document is found to be not
  184. #    well formed.  Warnings are passed via the -warningcommand script.
  185. #
  186. #    The procedure only check for well-formedness,
  187. #    no DTD is required.  However, facilities are provided for entity expansion.
  188. #
  189. # Arguments:
  190. #    sgml        Instance data, as a Tcl list.
  191. #    args        option/value pairs
  192. #
  193. # Valid Options:
  194. #    -final            Indicates end of document data
  195. #    -validate        Boolean to enable validation
  196. #    -baseurl        URL for resolving relative URLs
  197. #    -elementstartcommand    Called when an element starts
  198. #    -elementendcommand    Called when an element ends
  199. #    -characterdatacommand    Called when character data occurs
  200. #    -entityreferencecommand    Called when an entity reference occurs
  201. #    -processinginstructioncommand    Called when a PI occurs
  202. #    -externalentitycommand    Called for an external entity reference
  203. #
  204. #    -xmldeclcommand        Called when the XML declaration occurs
  205. #    -doctypecommand        Called when the document type declaration occurs
  206. #    -commentcommand        Called when a comment occurs
  207. #    -entitydeclcommand    Called when a parsed entity is declared
  208. #    -unparsedentitydeclcommand    Called when an unparsed external entity is declared
  209. #    -parameterentitydeclcommand    Called when a parameter entity is declared
  210. #    -notationdeclcommand    Called when a notation is declared
  211. #    -elementdeclcommand    Called when an element is declared
  212. #    -attlistdeclcommand    Called when an attribute list is declared
  213. #    -paramentityparsing    Boolean to enable/disable parameter entity substitution
  214. #    -defaultexpandinternalentities    Boolean to enable/disable expansion of entities declared in internal DTD subset
  215. #
  216. #    -startdoctypedeclcommand    Called when the Doc Type declaration starts (see also -doctypecommand)
  217. #    -enddoctypedeclcommand    Called when the Doc Type declaration ends (see also -doctypecommand)
  218. #
  219. #    -errorcommand        Script to evaluate for a fatal error
  220. #    -warningcommand        Script to evaluate for a reportable warning
  221. #    -statevariable        global state variable
  222. #    -normalize        whether to normalize names
  223. #    -reportempty        whether to include an indication of empty elements
  224. #
  225. # Results:
  226. #    The various callback scripts are invoked.
  227. #    Returns empty string.
  228. #
  229. # BUGS:
  230. #    If command options are set to empty string then they should not be invoked.
  231.  
  232. proc sgml::parseEvent {sgml args} {
  233.     variable Wsp
  234.     variable noWsp
  235.     variable Nmtoken
  236.     variable Name
  237.     variable ParseEventNum
  238.     variable StdOptions
  239.  
  240.     array set options [array get StdOptions]
  241.     catch {array set options $args}
  242.  
  243.     foreach {opt value} [array get options *command] {
  244.     if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
  245.         set options($opt) [namespace current]::noop
  246.     }
  247.     }
  248.  
  249.     if {![info exists options(-statevariable)]} {
  250.     set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
  251.     }
  252.     if {![info exists options(entities)]} {
  253.     set options(entities) [namespace current]::Entities$ParseEventNum
  254.     array set $options(entities) [array get [namespace current]::EntityPredef]
  255.     }
  256.     if {![info exists options(extentities)]} {
  257.     set options(extentities) [namespace current]::ExtEntities$ParseEventNum
  258.     }
  259.     if {![info exists options(parameterentities)]} {
  260.     set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
  261.     }
  262.     if {![info exists options(externalparameterentities)]} {
  263.     set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
  264.     }
  265.     if {![info exists options(elementdecls)]} {
  266.     set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
  267.     }
  268.     if {![info exists options(attlistdecls)]} {
  269.     set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
  270.     }
  271.     if {![info exists options(notationdecls)]} {
  272.     set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
  273.     }
  274.     if {![info exists options(namespaces)]} {
  275.     set options(namespaces) [namespace current]::Namespaces$ParseEventNum
  276.     }
  277.  
  278.     # Choose an external entity resolver
  279.  
  280.     if {![string length $options(-externalentitycommand)]} {
  281.     if {$options(-validate)} {
  282.         set options(-externalentitycommand) [namespace code ResolveEntity]
  283.     } else {
  284.         set options(-externalentitycommand) [namespace code noop]
  285.     }
  286.     }
  287.  
  288.     upvar #0 $options(-statevariable) state
  289.     upvar #0 $options(entities) entities
  290.  
  291.     if {![info exists state]} {
  292.     # Initialise the state variable
  293.     array set state {
  294.         mode normal
  295.         haveXMLDecl 0
  296.         haveDocElement 0
  297.         inDTD 0
  298.         context {}
  299.         stack {}
  300.         line 0
  301.         defaultNS {}
  302.         defaultNSURI {}
  303.     }
  304.     }
  305.  
  306.     foreach {tag close param text} $sgml {
  307.  
  308.     # Keep track of lines in the input
  309.     incr state(line) [regsub -all \n $param {} discard]
  310.     incr state(line) [regsub -all \n $text {} discard]
  311.  
  312.     # If the current mode is cdata or comment then we must undo what the
  313.     # regsub has done to reconstitute the data
  314.  
  315.     set empty {}
  316.     switch $state(mode) {
  317.         comment {
  318.         # This had "[string length $param] && " as a guard -
  319.         # can't remember why :-(
  320.         if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
  321.             # end of comment (in tag)
  322.             set tag {}
  323.             set close {}
  324.             set state(mode) normal
  325.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$comm1]
  326.             unset state(commentdata)
  327.         } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
  328.             # end of comment (in attributes)
  329.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag>$comm1]
  330.             unset state(commentdata)
  331.             set tag {}
  332.             set param {}
  333.             set close {}
  334.             set state(mode) normal
  335.         } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
  336.             # end of comment (in text)
  337.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$param>$comm1]
  338.             unset state(commentdata)
  339.             set tag {}
  340.             set param {}
  341.             set close {}
  342.             set state(mode) normal
  343.         } else {
  344.             # comment continues
  345.             append state(commentdata) <$close$tag$param>$text
  346.             continue
  347.         }
  348.         }
  349.         cdata {
  350.         if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
  351.             # end of CDATA (in tag)
  352.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$cdata1]]
  353.             set text [subst -novariable -nocommand $text]
  354.             set tag {}
  355.             unset state(cdata)
  356.             set state(mode) normal
  357.         } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
  358.             # end of CDATA (in attributes)
  359.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]]
  360.             set text [subst -novariable -nocommand $text]
  361.             set tag {}
  362.             set param {}
  363.             unset state(cdata)
  364.             set state(mode) normal
  365.         } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
  366.             # end of CDATA (in text)
  367.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]]
  368.             set text [subst -novariable -nocommand $text]
  369.             set tag {}
  370.             set param {}
  371.             set close {}
  372.             unset state(cdata)
  373.             set state(mode) normal
  374.         } else {
  375.             # CDATA continues
  376.             append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
  377.             continue
  378.         }
  379.         }
  380.         continue {
  381.         # We're skipping elements looking for the close tag
  382.         switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
  383.             0,* {
  384.             continue
  385.             }
  386.             *,0, {
  387.             if {![string compare $tag $state(continue:tag)]} {
  388.                 set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
  389.                 if {![string length $empty]} {
  390.                 incr state(continue:level)
  391.                 }
  392.             }
  393.             continue
  394.             }
  395.             *,0,/ {
  396.             if {![string compare $tag $state(continue:tag)]} {
  397.                 incr state(continue:level) -1
  398.             }
  399.             if {!$state(continue:level)} {
  400.                 unset state(continue:tag)
  401.                 unset state(continue:level)
  402.                 set state(mode) {}
  403.             }
  404.             }
  405.             default {
  406.             continue
  407.             }
  408.         }
  409.         }
  410.         default {
  411.         # The trailing slash on empty elements can't be automatically separated out
  412.         # in the RE, so we must do it here.
  413.         regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
  414.         }
  415.     }
  416.  
  417.     # default: normal mode
  418.  
  419.     # Bug: if the attribute list has a right angle bracket then the empty
  420.     # element marker will not be seen
  421.  
  422.     set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
  423.  
  424.     switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {
  425.  
  426.         0,0,, {
  427.         # Ignore empty tag - dealt with non-normal mode above
  428.         }
  429.         *,0,, {
  430.  
  431.         # Start tag for an element.
  432.  
  433.         # Check if the internal DTD entity is in an attribute value
  434.         regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param
  435.  
  436.         set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
  437.         set state(haveDocElement) 1
  438.         switch $code {
  439.             0 {# OK}
  440.             3 {
  441.             # break
  442.             return {}
  443.             }
  444.             4 {
  445.             # continue
  446.             # Remember this tag and look for its close
  447.             set state(continue:tag) $tag
  448.             set state(continue:level) 1
  449.             set state(mode) continue
  450.             continue
  451.             }
  452.             default {
  453.             return -code $code -errorinfo $::errorInfo $msg
  454.             }
  455.         }
  456.  
  457.         }
  458.  
  459.         *,0,/, {
  460.  
  461.         # End tag for an element.
  462.  
  463.         set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
  464.         switch $code {
  465.             0 {# OK}
  466.             3 {
  467.             # break
  468.             return {}
  469.             }
  470.             4 {
  471.             # continue
  472.             # skip sibling nodes
  473.             set state(continue:tag) [lindex $state(stack) end]
  474.             set state(continue:level) 1
  475.             set state(mode) continue
  476.             continue
  477.             }
  478.             default {
  479.             return -code $code -errorinfo $::errorInfo $msg
  480.             }
  481.         }
  482.  
  483.         }
  484.  
  485.         *,0,,/ {
  486.  
  487.         # Empty element
  488.  
  489.         # The trailing slash sneaks through into the param variable
  490.         regsub -all /[cl $::sgml::Wsp]*\$ $param {} param
  491.  
  492.         set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
  493.         set state(haveDocElement) 1
  494.         switch $code {
  495.             0 {# OK}
  496.             3 {
  497.             # break
  498.             return {}
  499.             }
  500.             4 {
  501.             # continue
  502.             # Pretty useless since it closes straightaway
  503.             }
  504.             default {
  505.             return -code $code -errorinfo $::errorInfo $msg
  506.             }
  507.         }
  508.         set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
  509.         switch $code {
  510.             0 {# OK}
  511.             3 {
  512.             # break
  513.             return {}
  514.             }
  515.             4 {
  516.             # continue
  517.             # skip sibling nodes
  518.             set state(continue:tag) [lindex $state(stack) end]
  519.             set state(continue:level) 1
  520.             set state(mode) continue
  521.             continue
  522.             }
  523.             default {
  524.             return -code $code -errorinfo $::errorInfo $msg
  525.             }
  526.         }
  527.  
  528.         }
  529.  
  530.         *,1,* {
  531.         # Processing instructions or XML declaration
  532.         switch -glob -- $tag {
  533.  
  534.             {\?xml} {
  535.             # XML Declaration
  536.             if {$state(haveXMLDecl)} {
  537.                 uplevel #0 $options(-errorcommand) "unexpected characters \"<$tag\" around line $state(line)"
  538.             } elseif {![regexp {\?$} $param]} {
  539.                 uplevel #0 $options(-errorcommand) "XML Declaration missing characters \"?>\" around line $state(line)"
  540.             } else {
  541.  
  542.                 # We can do the parsing in one step with Tcl 8.1 RE's
  543.                 # This has the benefit of performing better WF checking
  544.  
  545.                 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]
  546.  
  547.                 if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
  548.                 # Otherwise we must fallback to 8.0.
  549.                 # This won't detect certain well-formedness errors
  550.  
  551.                 # Get the version number
  552.                 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]} {
  553.                     if {[string compare $version "1.0"]} {
  554.                     # Should we support future versions?
  555.                     # At least 1.X?
  556.                     uplevel #0 $options(-errorcommand) "document XML version \"$version\" is incompatible with XML version 1.0"
  557.                     }
  558.                 } else {
  559.                     uplevel #0 $options(-errorcommand) "XML Declaration missing version information around line $state(line)"
  560.                 }
  561.  
  562.                 # Get the encoding declaration
  563.                 set encoding {}
  564.                 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
  565.                 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
  566.  
  567.                 # Get the standalone declaration
  568.                 set standalone {}
  569.                 regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
  570.                 regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
  571.  
  572.                 # Invoke the callback
  573.                 uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
  574.  
  575.                 } elseif {$matches == 0} {
  576.                 uplevel #0 $options(-errorcommand) "XML Declaration not well-formed around line $state(line)"
  577.                 } else {
  578.  
  579.                 # Invoke the callback
  580.                 uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
  581.  
  582.                 }
  583.  
  584.             }
  585.  
  586.             }
  587.  
  588.             {\?*} {
  589.             # Processing instruction
  590.             set tag [string range $tag 1 end]
  591.             if {[regsub {\?$} $tag {} tag]} {
  592.                 if {[string length [string trim $param]]} {
  593.                 uplevel #0 $options(-errorcommand) [list "unexpected text \"$param\" in processing instruction around line $state(line)"]
  594.                 }
  595.             } elseif {![regexp ^$Name\$ $tag]} {
  596.                 uplevel #0 $options(-errorcommand) [list "illegal character in processing instruction target \"$tag\""]
  597.             } elseif {[regexp {[xX][mM][lL]} $tag]} {
  598.                 uplevel #0 $options(-errorcommand) [list "characters \"xml\" not permitted in processing instruction target \"$tag\""]
  599.             } elseif {![regsub {\?$} $param {} param]} {
  600.                 uplevel #0 $options(-errorcommand) "PI: expected '?' character around line $state(line)"
  601.             }
  602.             set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
  603.             switch $code {
  604.                 0 {# OK}
  605.                 3 {
  606.                 # break
  607.                 return {}
  608.                 }
  609.                 4 {
  610.                 # continue
  611.                 # skip sibling nodes
  612.                 set state(continue:tag) [lindex $state(stack) end]
  613.                 set state(continue:level) 1
  614.                 set state(mode) continue
  615.                 continue
  616.                 }
  617.                 default {
  618.                 return -code $code -errorinfo $::errorInfo $msg
  619.                 }
  620.             }
  621.             }
  622.  
  623.             !DOCTYPE {
  624.             # External entity reference
  625.             # This should move into xml.tcl
  626.             # Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
  627.             set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
  628.             set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
  629.             set externalID {}
  630.             set pubidlit {}
  631.             set systemlit {}
  632.             set externalID {}
  633.             if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
  634.                 switch [string toupper $id] {
  635.                 SYSTEM {
  636.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
  637.                     set externalID [list SYSTEM $systemlit] ;# "
  638.                     } else {
  639.                     uplevel #0 $options(-errorcommand) {{syntax error: SYSTEM identifier not followed by literal}}
  640.                     }
  641.                 }
  642.                 PUBLIC {
  643.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
  644.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
  645.                         set externalID [list PUBLIC $pubidlit $systemlit]
  646.                     } else {
  647.                         uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"
  648.                     }
  649.                     } else {
  650.                     uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by literal around line $state(line)"
  651.                     }
  652.                 }
  653.                 }
  654.                 if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
  655.                 lappend externalID $notation
  656.                 }
  657.             }
  658.  
  659.             set state(inDTD) 1
  660.  
  661.             ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)
  662.  
  663.             set state(inDTD) 0
  664.  
  665.             }
  666.  
  667.             !--* {
  668.  
  669.             # Start of a comment
  670.             # See if it ends in the same tag, otherwise change the
  671.             # parsing mode
  672.  
  673.             regexp {!--(.*)} $tag discard comm1
  674.             if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
  675.                 # processed comment (end in tag)
  676.                 uplevel #0 $options(-commentcommand) [list $comm1_1]
  677.             } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
  678.                 # processed comment (end in attributes)
  679.                 uplevel #0 $options(-commentcommand) [list $comm1$comm2]
  680.             } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
  681.                 # processed comment (end in text)
  682.                 uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
  683.             } else {
  684.                 # start of comment
  685.                 set state(mode) comment
  686.                 set state(commentdata) "$comm1$param$empty>$text"
  687.                 continue
  688.             }
  689.             }
  690.  
  691.             {!\[CDATA\[*} {
  692.  
  693.             regexp {!\[CDATA\[(.*)} $tag discard cdata1
  694.             if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
  695.                 # processed CDATA (end in tag)
  696.                 uplevel #0 $options(-characterdatacommand) [list [subst -novariable -nocommand $cdata2]]
  697.                 set text [subst -novariable -nocommand $text]
  698.             } elseif {[regexp {(.*)]]$} $param discard cdata2]} {
  699.                 # processed CDATA (end in attribute)
  700.                 # Backslashes in param are quoted at this stage
  701.                 uplevel #0 $options(-characterdatacommand) [list $cdata1[subst -novariable -nocommand $cdata2]]
  702.                 set text [subst -novariable -nocommand $text]
  703.             } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
  704.                 # processed CDATA (end in text)
  705.                 # Backslashes in param and text are quoted at this stage
  706.                 uplevel #0 $options(-characterdatacommand) [list $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]]
  707.                 set text [subst -novariable -nocommand $text]
  708.             } else {
  709.                 # start CDATA
  710.                 set state(cdata) "$cdata1$param>$text"
  711.                 set state(mode) cdata
  712.                 continue
  713.             }
  714.  
  715.             }
  716.  
  717.             !ELEMENT -
  718.             !ATTLIST -
  719.             !ENTITY -
  720.             !NOTATION {
  721.             uplevel #0 $options(-errorcommand) "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"
  722.             }
  723.  
  724.             default {
  725.             uplevel #0 $options(-errorcommand) [list "unknown processing instruction \"<$tag>\" around line $state(line)"]
  726.             }
  727.         }
  728.         }
  729.         *,1,* -
  730.         *,0,/,/ {
  731.         # Syntax error
  732.             uplevel #0 $options(-errorcommand) [list [list syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)]]
  733.         }
  734.     }
  735.  
  736.     # Process character data
  737.  
  738.     if {$state(haveDocElement) && [llength $state(stack)]} {
  739.  
  740.         # Check if the internal DTD entity is in the text
  741.         regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text
  742.  
  743.         # Look for entity references
  744.         if {([array size entities] || \
  745.             [string length $options(-entityreferencecommand)]) && \
  746.             $options(-defaultexpandinternalentities) && \
  747.             [regexp {&[^;]+;} $text]} {
  748.  
  749.         # protect Tcl specials
  750.         # NB. braces and backslashes may already be protected
  751.         regsub -all {\\({|}|\\)} $text {\1} text
  752.         regsub -all {([][$\\{}])} $text {\\\1} text
  753.  
  754.         # Mark entity references
  755.         regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) $options(-characterdatacommand) $options(entities)]] [namespace code [list DeProtect $options(-characterdatacommand)]] \{\{] text
  756.         set text "uplevel #0 [namespace code [list DeProtect1 $options(-characterdatacommand)]] {{$text}}"
  757.         eval $text
  758.         } else {
  759.         # Restore protected special characters
  760.         regsub -all {\\([][{}\\])} $text {\1} text
  761.         uplevel #0 $options(-characterdatacommand) [list $text]
  762.         }
  763.     } elseif {[string length [string trim $text]]} {
  764.         uplevel #0 $options(-errorcommand) "unexpected text \"$text\" in document prolog around line $state(line)"
  765.     }
  766.  
  767.     }
  768.  
  769.     # If this is the end of the document, close all open containers
  770.     if {$options(-final) && [llength $state(stack)]} {
  771.     eval $options(-errorcommand) [list [list element [lindex $state(stack) end] remains unclosed around line $state(line)]]
  772.     }
  773.  
  774.     return {}
  775. }
  776.  
  777. # sgml::DeProtect --
  778. #
  779. #    Invoke given command after removing protecting backslashes
  780. #    from given text.
  781. #
  782. # Arguments:
  783. #    cmd    Command to invoke
  784. #    text    Text to deprotect
  785. #
  786. # Results:
  787. #    Depends on command
  788.  
  789. proc sgml::DeProtect1 {cmd text} {
  790.     if {[string compare {} $text]} {
  791.     regsub -all {\\([][{}\\])} $text {\1} text
  792.     uplevel #0 $cmd [list $text]
  793.     }
  794. }
  795. proc sgml::DeProtect {cmd text} {
  796.     set text [lindex $text 0]
  797.     if {[string compare {} $text]} {
  798.     regsub -all {\\([][{}\\])} $text {\1} text
  799.     uplevel #0 $cmd [list $text]
  800.     }
  801. }
  802.  
  803. # sgml::ParserDelete --
  804. #
  805. #    Free all memory associated with parser
  806. #
  807. # Arguments:
  808. #    var    global state array
  809. #
  810. # Results:
  811. #    Variables unset
  812.  
  813. proc sgml::ParserDelete var {
  814.     upvar #0 $var state
  815.  
  816.     if {![info exists state]} {
  817.     return -code error "unknown parser"
  818.     }
  819.  
  820.     catch {unset $state(entities)}
  821.     catch {unset $state(parameterentities)}
  822.     catch {unset $state(elementdecls)}
  823.     catch {unset $state(attlistdecls)}
  824.     catch {unset $state(notationdecls)}
  825.     catch {unset $state(namespaces)}
  826.  
  827.     unset state
  828.  
  829.     return {}
  830. }
  831.  
  832. # sgml::ParseEvent:ElementOpen --
  833. #
  834. #    Start of an element.
  835. #
  836. # Arguments:
  837. #    tag    Element name
  838. #    attr    Attribute list
  839. #    opts    Options
  840. #    args    further configuration options
  841. #
  842. # Options:
  843. #    -empty boolean
  844. #        indicates whether the element was an empty element
  845. #
  846. # Results:
  847. #    Modify state and invoke callback
  848.  
  849. proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
  850.     variable Name
  851.     variable Wsp
  852.  
  853.     array set options $opts
  854.     upvar #0 $options(-statevariable) state
  855.     array set cfg {-empty 0}
  856.     array set cfg $args
  857.  
  858.     if {$options(-normalize)} {
  859.     set tag [string toupper $tag]
  860.     }
  861.  
  862.     # Update state
  863.     lappend state(stack) $tag
  864.  
  865.     # Parse attribute list into a key-value representation
  866.     if {[string compare $options(-parseattributelistcommand) {}]} {
  867.     if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $attr]} attr]} {
  868.         if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
  869.         uplevel #0 $options(-errorcommand) "$attr around line $state(line)"
  870.         set attr {}
  871.         } else {
  872.  
  873.         # It is most likely that a ">" character was in an attribute value.
  874.         # This manifests itself by ">" appearing in the element's text.
  875.         # In this case the callback should return a three element list;
  876.         # the message "unterminated attribute value", the attribute list it
  877.         # did manage to parse and the remainder of the attribute list.
  878.  
  879.         foreach {msg attlist brokenattr} $attr break
  880.  
  881.         upvar text elemText
  882.         if {[string first > $elemText] >= 0} {
  883.  
  884.             # Now piece the attribute list back together
  885.             regexp ($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
  886.             regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
  887.             regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist
  888.  
  889.             append attvalue >$remattvalue
  890.             lappend attlist $attname $attvalue
  891.  
  892.             # Complete parsing the attribute list
  893.             if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $remattlist]} attr]} {
  894.             uplevel #0 $options(-errorcommand) [list $attr around line $state(line)]
  895.             set attr {}
  896.             set attlist {}
  897.             } else {
  898.             eval lappend attlist $attr
  899.             }
  900.  
  901.             set attr $attlist
  902.  
  903.         } else {
  904.             uplevel #0 $options(-errorcommand) [list $attr around line $state(line)]
  905.             set attr {}
  906.         }
  907.         }
  908.     }
  909.     }
  910.  
  911.     set empty {}
  912.     if {$cfg(-empty) && $options(-reportempty)} {
  913.     set empty {-empty 1}
  914.     }
  915.  
  916.     # Check for namespace declarations
  917.     upvar #0 $options(namespaces) namespaces
  918.     set nsdecls {}
  919.     if {[llength $attr]} {
  920.     array set attrlist $attr
  921.     foreach {attrName attrValue} [array get attrlist xmlns*] {
  922.         unset attrlist($attrName)
  923.         set colon [set prefix {}]
  924.         if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
  925.         switch -glob [string length $colon],[string length $prefix] {
  926.             0,0 {
  927.             # default NS declaration
  928.             lappend state(defaultNSURI) $attrValue
  929.             lappend state(defaultNS) [llength $state(stack)]
  930.             lappend nsdecls $attrValue {}
  931.             }
  932.             0,* {
  933.             # Huh?
  934.             }
  935.             *,0 {
  936.             # Error
  937.             uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
  938.             }
  939.             default {
  940.             set namespaces($prefix,[llength $state(stack)]) $attrValue
  941.             lappend nsdecls $attrValue $prefix
  942.             }
  943.         }
  944.         }
  945.     }
  946.     if {[llength $nsdecls]} {
  947.         set nsdecls [list -namespacedecls $nsdecls]
  948.     }
  949.     set attr [array get attrlist]
  950.     }
  951.  
  952.     # Check whether this element has an expanded name
  953.     set ns {}
  954.     if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
  955.     set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
  956.     if {[llength $nsspec]} {
  957.         set nsuri $namespaces([lindex $nsspec 0])
  958.         set ns [list -namespace $nsuri]
  959.     } else {
  960.         uplevel #0 $options(-errorcommand) "no namespace declared for prefix \"$prefix\" in element $tag"
  961.     }
  962.     } elseif {[llength $state(defaultNSURI)]} {
  963.     set ns [list -namespace [lindex $state(defaultNSURI) end]]
  964.     }
  965.  
  966.     # Invoke callback
  967.     set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]
  968.     return -code $code -errorinfo $::errorInfo $msg
  969. }
  970.  
  971. # sgml::ParseEvent:ElementClose --
  972. #
  973. #    End of an element.
  974. #
  975. # Arguments:
  976. #    tag    Element name
  977. #    opts    Options
  978. #    args    further configuration options
  979. #
  980. # Options:
  981. #    -empty boolean
  982. #        indicates whether the element as an empty element
  983. #
  984. # Results:
  985. #    Modify state and invoke callback
  986.  
  987. proc sgml::ParseEvent:ElementClose {tag opts args} {
  988.     array set options $opts
  989.     upvar #0 $options(-statevariable) state
  990.     array set cfg {-empty 0}
  991.     array set cfg $args
  992.  
  993.     # WF check
  994.     if {[string compare $tag [lindex $state(stack) end]]} {
  995.     uplevel #0 $options(-errorcommand) [list "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
  996.     return
  997.     }
  998.  
  999.     # Check whether this element has an expanded name
  1000.     upvar #0 $options(namespaces) namespaces
  1001.     set ns {}
  1002.     if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
  1003.     set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
  1004.     set ns [list -namespace $nsuri]
  1005.     } elseif {[llength $state(defaultNSURI)]} {
  1006.     set ns [list -namespace [lindex $state(defaultNSURI) end]]
  1007.     }
  1008.  
  1009.     # Pop namespace stacks, if any
  1010.     if {[llength $state(defaultNS)]} {
  1011.     if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
  1012.         set state(defaultNS) [lreplace $state(defaultNS) end end]
  1013.     }
  1014.     }
  1015.     foreach nsspec [array names namespaces *,[llength $state(stack)]] {
  1016.     unset namespaces($nsspec)
  1017.     }
  1018.  
  1019.     # Update state
  1020.     set state(stack) [lreplace $state(stack) end end]
  1021.  
  1022.     set empty {}
  1023.     if {$cfg(-empty) && $options(-reportempty)} {
  1024.     set empty {-empty 1}
  1025.     }
  1026.  
  1027.     # Invoke callback
  1028.     uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns
  1029.  
  1030.     return {}
  1031. }
  1032.  
  1033. # sgml::Normalize --
  1034. #
  1035. #    Perform name normalization if required
  1036. #
  1037. # Arguments:
  1038. #    name    name to normalize
  1039. #    req    normalization required
  1040. #
  1041. # Results:
  1042. #    Name returned as upper-case if normalization required
  1043.  
  1044. proc sgml::Normalize {name req} {
  1045.     if {$req} {
  1046.     return [string toupper $name]
  1047.     } else {
  1048.     return $name
  1049.     }
  1050. }
  1051.  
  1052. # sgml::Entity --
  1053. #
  1054. #    Resolve XML entity references (syntax: &xxx;).
  1055. #
  1056. # Arguments:
  1057. #    opts        options
  1058. #    entityrefcmd    application callback for entity references
  1059. #    pcdatacmd    application callback for character data
  1060. #    entities    name of array containing entity definitions.
  1061. #    ref        entity reference (the "xxx" bit)
  1062. #
  1063. # Results:
  1064. #    Returns substitution text for given entity.
  1065.  
  1066. proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
  1067.     array set options $opts
  1068.     upvar #0 $options(-statevariable) state
  1069.  
  1070.     if {![string length $entities]} {
  1071.     set entities [namespace current EntityPredef]
  1072.     }
  1073.  
  1074.     switch -glob -- $ref {
  1075.     %* {
  1076.         # Parameter entity - not recognised outside of a DTD
  1077.     }
  1078.     #x* {
  1079.         # Character entity - hex
  1080.         if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
  1081.         return -code error "malformed character entity \"$ref\""
  1082.         }
  1083.         uplevel #0 $pcdatacmd [list $char]
  1084.  
  1085.         return {}
  1086.  
  1087.     }
  1088.     #* {
  1089.         # Character entity - decimal
  1090.         if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
  1091.         return -code error "malformed character entity \"$ref\""
  1092.         }
  1093.         uplevel #0 $pcdatacmd [list $char]
  1094.  
  1095.         return {}
  1096.  
  1097.     }
  1098.     default {
  1099.         # General entity
  1100.         upvar #0 $entities map
  1101.         if {[info exists map($ref)]} {
  1102.  
  1103.         if {![regexp {<|&} $map($ref)]} {
  1104.  
  1105.             # Simple text replacement - optimise
  1106.             uplevel #0 $pcdatacmd [list $map($ref)]
  1107.  
  1108.             return {}
  1109.  
  1110.         }
  1111.  
  1112.         # Otherwise an additional round of parsing is required.
  1113.         # This only applies to XML, since HTML doesn't have general entities
  1114.  
  1115.         # Must parse the replacement text for start & end tags, etc
  1116.         # This text must be self-contained: balanced closing tags, and so on
  1117.  
  1118.         set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
  1119.         set options(-final) 0
  1120.         eval parseEvent [list $tokenised] [array get options]
  1121.  
  1122.         return {}
  1123.  
  1124.         } elseif {[string compare $entityrefcmd "::sgml::noop"]} {
  1125.  
  1126.         set result [uplevel #0 $entityrefcmd [list $ref]]
  1127.  
  1128.         if {[string length $result]} {
  1129.             uplevel #0 $pcdatacmd [list $result]
  1130.         }
  1131.  
  1132.         return {}
  1133.  
  1134.         } else {
  1135.  
  1136.         # Reconstitute entity reference
  1137.  
  1138.         uplevel #0 $options(-errorcommand) [list "undefined entity reference \"$ref\""]
  1139.  
  1140.         return {}
  1141.  
  1142.         }
  1143.     }
  1144.     }
  1145.  
  1146.     # If all else fails leave the entity reference untouched
  1147.     uplevel #0 $pcdatacmd [list &$ref\;]
  1148.  
  1149.     return {}
  1150. }
  1151.  
  1152. ####################################
  1153. #
  1154. # DTD parser for SGML (XML).
  1155. #
  1156. # This DTD actually only handles XML DTDs.  Other language's
  1157. # DTD's, such as HTML, must be written in terms of a XML DTD.
  1158. #
  1159. ####################################
  1160.  
  1161. # sgml::ParseEvent:DocTypeDecl --
  1162. #
  1163. #    Entry point for DTD parsing
  1164. #
  1165. # Arguments:
  1166. #    opts    configuration options
  1167. #    docEl    document element name
  1168. #    pubId    public identifier
  1169. #    sysId    system identifier (a URI)
  1170. #    intSSet    internal DTD subset
  1171.  
  1172. proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
  1173.     array set options {}
  1174.     array set options $opts
  1175.  
  1176.     set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
  1177.     switch $code {
  1178.     3 {
  1179.         # break
  1180.         return {}
  1181.     }
  1182.     0 -
  1183.     4 {
  1184.         # continue
  1185.     }
  1186.     default {
  1187.         return -code $code $err
  1188.     }
  1189.     }
  1190.  
  1191.     # Otherwise we'll parse the DTD and report it piecemeal
  1192.  
  1193.     # The internal DTD subset is processed first (XML 2.8)
  1194.     # During this stage, parameter entities are only allowed
  1195.     # between markup declarations
  1196.  
  1197.     ParseDTD:Internal [array get options] $intSSet
  1198.  
  1199.     # The external DTD subset is processed last (XML 2.8)
  1200.     # During this stage, parameter entities may occur anywhere
  1201.  
  1202.     # We must resolve the external identifier to obtain the
  1203.     # DTD data.  The application may supply its own resolver.
  1204.  
  1205.     if {[string length $pubId] || [string length $sysId]} {
  1206.     uplevel #0 $options(-externalentitycommand) [list $options(-name) $options(-baseurl) $sysId $pubId]
  1207.     }
  1208.  
  1209.     return {}
  1210. }
  1211.  
  1212. # sgml::ParseDTD:Internal --
  1213. #
  1214. #    Parse the internal DTD subset.
  1215. #
  1216. #    Parameter entities are only allowed between markup declarations.
  1217. #
  1218. # Arguments:
  1219. #    opts    configuration options
  1220. #    dtd    DTD data
  1221. #
  1222. # Results:
  1223. #    Markup declarations parsed may cause callback invocation
  1224.  
  1225. proc sgml::ParseDTD:Internal {opts dtd} {
  1226.     variable MarkupDeclExpr
  1227.     variable MarkupDeclSub
  1228.  
  1229.     array set options {}
  1230.     array set options $opts
  1231.  
  1232.     upvar #0 $options(-statevariable) state
  1233.     upvar #0 $options(parameterentities) PEnts
  1234.     upvar #0 $options(externalparameterentities) ExtPEnts
  1235.  
  1236.     # Tokenize the DTD
  1237.  
  1238.     # Protect Tcl special characters
  1239.     regsub -all {([{}\\])} $dtd {\\\1} dtd
  1240.  
  1241.     regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd
  1242.  
  1243.     # Entities may have angle brackets in their replacement
  1244.     # text, which breaks the RE processing.  So, we must
  1245.     # use a similar technique to processing doc instances
  1246.     # to rebuild the declarations from the pieces
  1247.  
  1248.     set mode {} ;# normal
  1249.     set delimiter {}
  1250.     set name {}
  1251.     set param {}
  1252.  
  1253.     set state(inInternalDTD) 1
  1254.  
  1255.     # Process the tokens
  1256.     foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {
  1257.  
  1258.     # Keep track of line numbers
  1259.     incr state(line) [regsub -all \n $text {} discard]
  1260.  
  1261.     ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
  1262.  
  1263.     ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param
  1264.  
  1265.     # There may be parameter entity references between markup decls
  1266.  
  1267.     if {[regexp {%.*;} $text]} {
  1268.  
  1269.         # Protect Tcl special characters
  1270.         regsub -all {([{}\\])} $text {\\\1} text
  1271.  
  1272.         regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text
  1273.  
  1274.         set PElist "\{$text\}"
  1275.         set PElist [lreplace $PElist end end]
  1276.         foreach {text entref} $PElist {
  1277.         if {[string length [string trim $text]]} {
  1278.             uplevel #0 $options(-errorcommand) "unexpected text in internal DTD subset around line $state(line)"
  1279.         }
  1280.  
  1281.         # Expand parameter entity and recursively parse
  1282.         # BUG: no checks yet for recursive entity references
  1283.  
  1284.         if {[info exists PEnts($entref)]} {
  1285.             set externalParser [$options(-name) entityparser]
  1286.             $externalParser parse $PEnts($entref) -dtdsubset internal
  1287.         } elseif {[info exists ExtPEnts($entref)]} {
  1288.             set externalParser [$options(-name) entityparser]
  1289.             $externalParser parse $ExtPEnts($entref) -dtdsubset external
  1290.             #$externalParser free
  1291.         } else {
  1292.             uplevel #0 $options(-errorcommand) "reference to undeclared parameter entity \"$entref\""
  1293.         }
  1294.         }
  1295.  
  1296.     }
  1297.  
  1298.     }
  1299.  
  1300.     return {}
  1301. }
  1302.  
  1303. # sgml::ParseDTD:EntityMode --
  1304. #
  1305. #    Perform special processing for various parser modes
  1306. #
  1307. # Arguments:
  1308. #    opts    configuration options
  1309. #    modeVar    pass-by-reference mode variable
  1310. #    replTextVar    pass-by-ref
  1311. #    declVar    pass-by-ref
  1312. #    valueVar    pass-by-ref
  1313. #    textVar    pass-by-ref
  1314. #    delimiter    delimiter currently in force
  1315. #    name
  1316. #    param
  1317. #
  1318. # Results:
  1319. #    Depends on current mode
  1320.  
  1321. proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} {
  1322.     upvar 1 $modeVar mode
  1323.     upvar 1 $replTextVar replText
  1324.     upvar 1 $declVar decl
  1325.     upvar 1 $valueVar value
  1326.     upvar 1 $textVar text
  1327.     array set options $opts
  1328.  
  1329.     switch $mode {
  1330.     {} {
  1331.         # Pass through to normal processing section
  1332.     }
  1333.     entity {
  1334.         # Look for closing delimiter
  1335.         if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
  1336.         append replText <$val1
  1337.         DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
  1338.         set decl /
  1339.         set text $remainder\ $value>$text
  1340.         set value {}
  1341.         set mode {}
  1342.         } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
  1343.         append replText <$decl\ $val2
  1344.         DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
  1345.         set decl /
  1346.         set text $remainder>$text
  1347.         set value {}
  1348.         set mode {}
  1349.         } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
  1350.         append replText <$decl\ $value>$val3
  1351.         DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
  1352.         set decl /
  1353.         set text $remainder
  1354.         set value {}
  1355.         set mode {}
  1356.         } else {
  1357.  
  1358.         # Remain in entity mode
  1359.         append replText <$decl\ $value>$text
  1360.         return -code continue
  1361.  
  1362.         }
  1363.     }
  1364.  
  1365.     ignore {
  1366.         upvar #0 $options(-statevariable) state
  1367.  
  1368.         if {[regexp {]](.*)$} $decl discard remainder]} {
  1369.         set state(condSections) [lreplace $state(condSections) end end]
  1370.         set decl $remainder
  1371.         set mode {}
  1372.         } elseif {[regexp {]](.*)$} $value discard remainder]} {
  1373.         set state(condSections) [lreplace $state(condSections) end end]
  1374.         regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
  1375.         set mode {}
  1376.         } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
  1377.         set state(condSections) [lreplace $state(condSections) end end]
  1378.         set decl /
  1379.         set value {}
  1380.         set text $remainder
  1381.         #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
  1382.         set mode {}
  1383.         } else {
  1384.         set decl /
  1385.         }
  1386.  
  1387.     }
  1388.  
  1389.     comment {
  1390.         # Look for closing comment delimiter
  1391.  
  1392.         upvar #0 $options(-statevariable) state
  1393.  
  1394.         if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
  1395.         } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
  1396.         } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
  1397.         } else {
  1398.         # comment continues
  1399.         append state(commentdata) <$decl\ $value>$text
  1400.         set decl /
  1401.         set value {}
  1402.         set text {}
  1403.         }
  1404.     }
  1405.  
  1406.     }
  1407.  
  1408.     return {}
  1409. }
  1410.  
  1411. # sgml::ParseDTD:ProcessMarkupDecl --
  1412. #
  1413. #    Process a single markup declaration
  1414. #
  1415. # Arguments:
  1416. #    opts    configuration options
  1417. #    declVar    pass-by-ref
  1418. #    valueVar    pass-by-ref
  1419. #    delimiterVar    pass-by-ref for current delimiter in force
  1420. #    nameVar    pass-by-ref
  1421. #    modeVar    pass-by-ref for current parser mode
  1422. #    replTextVar    pass-by-ref
  1423. #    textVar    pass-by-ref
  1424. #    paramVar    pass-by-ref
  1425. #
  1426. # Results:
  1427. #    Depends on markup declaration.  May change parser mode
  1428.  
  1429. proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} {
  1430.     upvar 1 $modeVar mode
  1431.     upvar 1 $replTextVar replText
  1432.     upvar 1 $textVar text
  1433.     upvar 1 $declVar decl
  1434.     upvar 1 $valueVar value
  1435.     upvar 1 $nameVar name
  1436.     upvar 1 $delimiterVar delimiter
  1437.     upvar 1 $paramVar param
  1438.  
  1439.     variable declExpr
  1440.     variable ExternalEntityExpr
  1441.  
  1442.     array set options $opts
  1443.     upvar #0 $options(-statevariable) state
  1444.  
  1445.     switch -glob -- $decl {
  1446.  
  1447.     / {
  1448.         # continuation from entity processing
  1449.     }
  1450.  
  1451.     !ELEMENT {
  1452.         # Element declaration
  1453.         if {[regexp $declExpr $value discard tag cmodel]} {
  1454.         DTD:ELEMENT [array get options] $tag $cmodel
  1455.         } else {
  1456.         uplevel #0 $options(-errorcommand) "malformed element declaration around line $state(line)"
  1457.         }
  1458.     }
  1459.  
  1460.     !ATTLIST {
  1461.         # Attribute list declaration
  1462.         variable declExpr
  1463.         if {[regexp $declExpr $value discard tag attdefns]} {
  1464.         if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
  1465.             #puts stderr "Stack trace: $::errorInfo\n***\n"
  1466.             # Atttribute parsing has bugs at the moment
  1467.             #return -code error "$err around line $state(line)"
  1468.             return {}
  1469.         }
  1470.         } else {
  1471.         uplevel #0 $options(-errorcommand) "malformed attribute list declaration around line $state(line)"
  1472.         }
  1473.     }
  1474.  
  1475.     !ENTITY {
  1476.         # Entity declaration
  1477.         variable EntityExpr
  1478.  
  1479.         if {[regexp $EntityExpr $value discard param name value]} {
  1480.  
  1481.         # Entity replacement text may have a '>' character.
  1482.         # In this case, the real delimiter will be in the following
  1483.         # text.  This is complicated by the possibility of there
  1484.         # being several '<','>' pairs in the replacement text.
  1485.         # At this point, we are searching for the matching quote delimiter.
  1486.  
  1487.         if {[regexp $ExternalEntityExpr $value]} {
  1488.             DTD:ENTITY [array get options] $name [string trim $param] $value
  1489.         } elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {
  1490.  
  1491.             if {[string length [string trim $value]]} {
  1492.             uplevel #0 $options(-errorcommand) "malformed entity declaration around line $state(line)"
  1493.             } else {
  1494.             DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
  1495.             }
  1496.         } elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
  1497.             append replText >$text
  1498.             set text {}
  1499.             set mode entity
  1500.         } else {
  1501.             uplevel #0 $options(-errorcommand) "no delimiter for entity declaration around line $state(line)"
  1502.         }
  1503.  
  1504.         } else {
  1505.         uplevel #0 $options(-errorcommand) "malformed entity declaration around line $state(line)"
  1506.         }
  1507.     }
  1508.  
  1509.     !NOTATION {
  1510.         # Notation declaration
  1511.         if {[regexp $declExpr param discard tag notation]} {
  1512.         DTD:ENTITY [array get options] $tag $notation
  1513.         } else {
  1514.         uplevel #0 $options(-errorcommand) "malformed entity declaration around line $state(line)"
  1515.         }
  1516.     }
  1517.  
  1518.     !--* {
  1519.         # Start of a comment
  1520.  
  1521.         if {[regexp !--(.*?)--\$ $decl discard data]} {
  1522.         if {[string length [string trim $value]]} {
  1523.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$value\""]
  1524.         }
  1525.         uplevel #0 $options(-commentcommand) [list $data]
  1526.         set decl /
  1527.         set value {}
  1528.         } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
  1529.         regexp !--(.*)\$ $decl discard data1
  1530.         uplevel #0 $options(-commentcommand) [list $data1\ $data2]
  1531.         set decl /
  1532.         set value {}
  1533.         } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
  1534.         regexp !--(.*)\$ $decl discard data1
  1535.         uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
  1536.         set decl /
  1537.         set value {}
  1538.         set text $remainder
  1539.         } else {
  1540.         regexp !--(.*)\$ $decl discard data1
  1541.         set state(commentdata) $data1\ $value>$text
  1542.         set decl /
  1543.         set value {}
  1544.         set text {}
  1545.         set mode comment
  1546.         }
  1547.     }
  1548.  
  1549.     !*INCLUDE* -
  1550.     !*IGNORE* {
  1551.         if {$state(inInternalDTD)} {
  1552.         uplevel #0 $options(-errorcommand) "conditional section not permitted in internal DTD subset around line $state(line)"
  1553.         }
  1554.  
  1555.         if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
  1556.         # Push conditional section stack, popped by ]]> sequence
  1557.  
  1558.         if {[regexp {(.*?)]]$} $remainder discard r2]} {
  1559.             # section closed immediately
  1560.             if {[string length [string trim $r2]]} {
  1561.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r2\" in conditional section"]
  1562.             }
  1563.         } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
  1564.             # section closed immediately
  1565.             if {[string length [string trim $r2]]} {
  1566.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r2\" in conditional section"]
  1567.             }
  1568.             if {[string length [string trim $r3]]} {
  1569.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r3\" in conditional section"]
  1570.             }
  1571.         } else {
  1572.  
  1573.             lappend state(condSections) INCLUDE
  1574.  
  1575.             set parser [$options(-name) entityparser]
  1576.             $parser parse $remainder\ $value> -dtdsubset external
  1577.             #$parser free
  1578.  
  1579.             if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
  1580.             if {[string length [string trim $t1]]} {
  1581.                 uplevel #0 $options(-errorcommand) [list "unexpected text \"$t1\""]
  1582.             }
  1583.             if {![llength $state(condSections)]} {
  1584.                 uplevel #0 $options(-errorcommand) [list "extraneous conditional section close"]
  1585.             }
  1586.             set state(condSections) [lreplace $state(condSections) end end]
  1587.             set text $t2
  1588.             }
  1589.  
  1590.         }
  1591.         } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
  1592.         # Set ignore mode.  Still need a stack
  1593.         set mode ignore
  1594.  
  1595.         if {[regexp {(.*?)]]$} $remainder discard r2]} {
  1596.             # section closed immediately
  1597.             if {[string length [string trim $r2]]} {
  1598.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r2\" in conditional section"]
  1599.             }
  1600.         } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
  1601.             # section closed immediately
  1602.             if {[string length [string trim $r2]]} {
  1603.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r2\" in conditional section"]
  1604.             }
  1605.             if {[string length [string trim $r3]]} {
  1606.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$r3\" in conditional section"]
  1607.             }
  1608.         } else {
  1609.             
  1610.             lappend state(condSections) IGNORE
  1611.  
  1612.             if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
  1613.             if {[string length [string trim $t1]]} {
  1614.                 uplevel #0 $options(-errorcommand) [list "unexpected text \"$t1\""]
  1615.             }
  1616.             if {![llength $state(condSections)]} {
  1617.                 uplevel #0 $options(-errorcommand) [list "extraneous conditional section close"]
  1618.             }
  1619.             set state(condSections) [lreplace $state(condSections) end end]
  1620.             set text $t2
  1621.             }
  1622.  
  1623.         }
  1624.         } else {
  1625.         uplevel #0 $options(-errorcommand) [list "illegal markup declaration \"$decl\" around line $state(line)"]
  1626.         }
  1627.  
  1628.     }
  1629.  
  1630.     default {
  1631.         if {[regexp {^\?(.*)} $decl discard target]} {
  1632.         # Processing instruction
  1633.         } else {
  1634.         uplevel #0 $options(-errorcommand) [list "illegal markup declaration \"$decl\""]
  1635.         }
  1636.     }
  1637.     }
  1638.  
  1639.     return {}
  1640. }
  1641.  
  1642. # sgml::ParseDTD:External --
  1643. #
  1644. #    Parse the external DTD subset.
  1645. #
  1646. #    Parameter entities are allowed anywhere.
  1647. #
  1648. # Arguments:
  1649. #    opts    configuration options
  1650. #    dtd    DTD data
  1651. #
  1652. # Results:
  1653. #    Markup declarations parsed may cause callback invocation
  1654.  
  1655. proc sgml::ParseDTD:External {opts dtd} {
  1656.     variable MarkupDeclExpr
  1657.     variable MarkupDeclSub
  1658.     variable declExpr
  1659.  
  1660.     array set options $opts
  1661.     upvar #0 $options(parameterentities) PEnts
  1662.     upvar #0 $options(externalparameterentities) ExtPEnts
  1663.     upvar #0 $options(-statevariable) state
  1664.  
  1665.     # As with the internal DTD subset, watch out for
  1666.     # entities with angle brackets
  1667.     set mode {} ;# normal
  1668.     set delimiter {}
  1669.     set name {}
  1670.     set param {}
  1671.  
  1672.     set oldState 0
  1673.     catch {set oldState $state(inInternalDTD)}
  1674.     set state(inInternalDTD) 0
  1675.  
  1676.     # Initialise conditional section stack
  1677.     if {![info exists state(condSections)]} {
  1678.     set state(condSections) {}
  1679.     }
  1680.     set startCondSectionDepth [llength $state(condSections)]
  1681.  
  1682.     while {[string length $dtd]} {
  1683.     set progress 0
  1684.     set PEref {}
  1685.     if {![string compare $mode "ignore"]} {
  1686.         set progress 1
  1687.         if {[regexp {]]>(.*)} $dtd discard dtd]} {
  1688.         set remainder {}
  1689.         set mode {} ;# normal
  1690.         set state(condSections) [lreplace $state(condSections) end end]
  1691.         continue
  1692.         } else {
  1693.         uplevel #0 $options(-errorcommand) [list "IGNORE conditional section closing delimiter not found"]
  1694.         }
  1695.     } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
  1696.         set progress 1
  1697.     } else {
  1698.         set data $dtd
  1699.         set dtd {}
  1700.         set remainder {}
  1701.     }
  1702.  
  1703.     # Tokenize the DTD (so far)
  1704.  
  1705.     # Protect Tcl special characters
  1706.     regsub -all {([{}\\])} $data {\\\1} dataP
  1707.  
  1708.     set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]
  1709.  
  1710.     if {$n} {
  1711.         set progress 1
  1712.         # All but the last markup declaration should have no text
  1713.         set dataP [lrange "{} {} \{$dataP\}" 3 end]
  1714.         if {[llength $dataP] > 3} {
  1715.         foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
  1716.             ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
  1717.             ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
  1718.  
  1719.             if {[string length [string trim $text]]} {
  1720.             # check for conditional section close
  1721.             if {[regexp {]]>(.*)$} $text discard text]} {
  1722.                 if {[string length [string trim $text]]} {
  1723.                 uplevel #0 $options(-errorcommand) [list "unexpected text \"$text\""]
  1724.                 }
  1725.                 if {![llength $state(condSections)]} {
  1726.                 uplevel #0 $options(-errorcommand) [list "extraneous conditional section close"]
  1727.                 }
  1728.                 set state(condSections) [lreplace $state(condSections) end end]
  1729.                 if {![string compare $mode "ignore"]} {
  1730.                 set mode {} ;# normal
  1731.                 }
  1732.             } else {
  1733.                 uplevel #0 $options(-errorcommand) [list "unexpected text \"$text\""]
  1734.             }
  1735.             }
  1736.         }
  1737.         }
  1738.         # Do the last declaration
  1739.         foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
  1740.         ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
  1741.         ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
  1742.         }
  1743.     }
  1744.  
  1745.     # Now expand the PE reference, if any
  1746.     switch -glob $mode,[string length $PEref],$n {
  1747.         ignore,0,* {
  1748.         set dtd $text
  1749.         }
  1750.         ignore,*,* {
  1751.         set dtd $text$remainder
  1752.         }
  1753.         *,0,0 {
  1754.         set dtd $data
  1755.         }
  1756.         *,0,* {
  1757.         set dtd $text
  1758.         }
  1759.         *,*,0 {
  1760.         if {[catch {append data $PEnts($PEref)}]} {
  1761.             if {[info exists ExtPEnts($PEref)]} {
  1762.             set externalParser [$options(-name) entityparser]
  1763.             $externalParser parse $ExtPEnts($PEref) -dtdsubset external
  1764.             #$externalParser free
  1765.             } else {
  1766.             uplevel #0 $options(-errorcommand) "parameter entity \"$PEref\" not declared"
  1767.             }
  1768.         }
  1769.         set dtd $data$remainder
  1770.         }
  1771.         default {
  1772.         if {[catch {append text $PEnts($PEref)}]} {
  1773.             if {[info exists ExtPEnts($PEref)]} {
  1774.             set externalParser [$options(-name) entityparser]
  1775.             $externalParser parse $ExtPEnts($PEref) -dtdsubset external
  1776.             #$externalParser free
  1777.             } else {
  1778.             uplevel #0 $options(-errorcommand) "parameter entity \"$PEref\" not declared"
  1779.             }
  1780.         }
  1781.         set dtd $text$remainder
  1782.         }
  1783.     }
  1784.  
  1785.     # Check whether a conditional section has been terminated
  1786.     if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
  1787.         if {![regexp <.*> $t1]} {
  1788.         if {[string length [string trim $t1]]} {
  1789.             uplevel #0 $options(-errorcommand) [list "unexpected text \"$t1\""]
  1790.         }
  1791.         if {![llength $state(condSections)]} {
  1792.             uplevel #0 $options(-errorcommand) [list "extraneous conditional section close"]
  1793.         }
  1794.         set state(condSections) [lreplace $state(condSections) end end]
  1795.         if {![string compare $mode "ignore"]} {
  1796.             set mode {} ;# normal
  1797.         }
  1798.         set dtd $t2
  1799.         set progress 1
  1800.         }
  1801.     }
  1802.  
  1803.     if {!$progress} {
  1804.         # No parameter entity references were found and 
  1805.         # the text does not contain a well-formed markup declaration
  1806.         # Avoid going into an infinite loop
  1807.         upvar #0 $options(-errorcommand) "external entity does not contain well-formed markup declaration"
  1808.         break
  1809.     }
  1810.     }
  1811.  
  1812.     set state(inInternalDTD) $oldState
  1813.  
  1814.     # Check that conditional sections have been closed properly
  1815.     if {[llength $state(condSections)] > $startCondSectionDepth} {
  1816.     uplevel #0 $options(-errorcommand) [list "[lindex $state(condSections) end] conditional section not closed"]
  1817.     }
  1818.     if {[llength $state(condSections)] < $startCondSectionDepth} {
  1819.     uplevel #0 $options(-errorcommand) [list "too many conditional section closures"]
  1820.     }
  1821.  
  1822.     return {}
  1823. }
  1824.  
  1825. # Procedures for handling the various declarative elements in a DTD.
  1826. # New elements may be added by creating a procedure of the form
  1827. # parse:DTD:_element_
  1828.  
  1829. # For each of these procedures, the various regular expressions they use
  1830. # are created outside of the proc to avoid overhead at runtime
  1831.  
  1832. # sgml::DTD:ELEMENT --
  1833. #
  1834. #    <!ELEMENT ...> defines an element.
  1835. #
  1836. #    The content model for the element is stored in the contentmodel array,
  1837. #    indexed by the element name.  The content model is parsed into the
  1838. #    following list form:
  1839. #
  1840. #        {}    Content model is EMPTY.
  1841. #            Indicated by an empty list.
  1842. #        *    Content model is ANY.
  1843. #            Indicated by an asterix.
  1844. #        {ELEMENT ...}
  1845. #            Content model is element-only.
  1846. #        {MIXED {element1 element2 ...}}
  1847. #            Content model is mixed (PCDATA and elements).
  1848. #            The second element of the list contains the 
  1849. #            elements that may occur.  #PCDATA is assumed 
  1850. #            (ie. the list is normalised).
  1851. #
  1852. # Arguments:
  1853. #    opts    configuration options
  1854. #    name    element GI
  1855. #    modspec    unparsed content model specification
  1856.  
  1857. proc sgml::DTD:ELEMENT {opts name modspec} {
  1858.     variable Wsp
  1859.     array set options $opts
  1860.  
  1861.     upvar #0 $options(elementdecls) elements
  1862.  
  1863.     if {$options(-validate) && [info exists elements($name)]} {
  1864.     eval $options(-errorcommand) element [list "element \"$name\" already declared"]
  1865.     } else {
  1866.     switch -- $modspec {
  1867.         EMPTY {
  1868.             set elements($name) {}
  1869.         uplevel #0 $options(-elementdeclcommand) $name {{}}
  1870.         }
  1871.         ANY {
  1872.             set elements($name) *
  1873.         uplevel #0 $options(-elementdeclcommand) $name *
  1874.         }
  1875.         default {
  1876.         # Don't parse the content model for now,
  1877.         # just pass the model to the application
  1878.         if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
  1879.             set cm($name) [list MIXED [split $mtoks |]]
  1880.         } elseif {0} {
  1881.             if {[catch {CModelParse $state(state) $value} result]} {
  1882.             eval $options(-errorcommand) element [list $result]
  1883.             } else {
  1884.             set cm($id) [list ELEMENT $result]
  1885.             }
  1886.         } else {
  1887.             set elements($name) $modspec
  1888.             uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
  1889.         }
  1890.         }
  1891.     }
  1892.     }
  1893. }
  1894.  
  1895. # sgml::CModelParse --
  1896. #
  1897. #    Parse an element content model (non-mixed).
  1898. #    A syntax tree is constructed.
  1899. #    A transition table is built next.
  1900. #
  1901. #    This is going to need alot of work!
  1902. #
  1903. # Arguments:
  1904. #    state    state array variable
  1905. #    value    the content model data
  1906. #
  1907. # Results:
  1908. #    A Tcl list representing the content model.
  1909.  
  1910. proc sgml::CModelParse {state value} {
  1911.     upvar #0 $state var
  1912.  
  1913.     # First build syntax tree
  1914.     set syntaxTree [CModelMakeSyntaxTree $state $value]
  1915.  
  1916.     # Build transition table
  1917.     set transitionTable [CModelMakeTransitionTable $state $syntaxTree]
  1918.  
  1919.     return [list $syntaxTree $transitionTable]
  1920. }
  1921.  
  1922. # sgml::CModelMakeSyntaxTree --
  1923. #
  1924. #    Construct a syntax tree for the regular expression.
  1925. #
  1926. #    Syntax tree is represented as a Tcl list:
  1927. #    rep {:choice|:seq {{rep list1} {rep list2} ...}}
  1928. #    where:    rep is repetition character, *, + or ?. {} for no repetition
  1929. #        listN is nested expression or Name
  1930. #
  1931. # Arguments:
  1932. #    spec    Element specification
  1933. #
  1934. # Results:
  1935. #    Syntax tree for element spec as nested Tcl list.
  1936. #
  1937. #    Examples:
  1938. #    (memo)
  1939. #        {} {:seq {{} memo}}
  1940. #    (front, body, back?)
  1941. #        {} {:seq {{} front} {{} body} {? back}}
  1942. #    (head, (p | list | note)*, div2*)
  1943. #        {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
  1944. #    (p | a | ul)+
  1945. #        + {:choice {{} p} {{} a} {{} ul}}
  1946.  
  1947. proc sgml::CModelMakeSyntaxTree {state spec} {
  1948.     upvar #0 $state var
  1949.     variable Wsp
  1950.     variable name
  1951.  
  1952.     # Translate the spec into a Tcl list.
  1953.  
  1954.     # None of the Tcl special characters are allowed in a content model spec.
  1955.     if {[regexp {\$|\[|\]|\{|\}} $spec]} {
  1956.     return -code error "illegal characters in specification"
  1957.     }
  1958.  
  1959.     regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
  1960.     regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
  1961.     regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec
  1962.  
  1963.     array set var {stack {} state start}
  1964.     eval $spec
  1965.  
  1966.     # Peel off the outer seq, its redundant
  1967.     return [lindex [lindex $var(stack) 1] 0]
  1968. }
  1969.  
  1970. # sgml::CModelSTname --
  1971. #
  1972. #    Processes a name in a content model spec.
  1973. #
  1974. # Arguments:
  1975. #    state    state array variable
  1976. #    name    name specified
  1977. #    rep    repetition operator
  1978. #    cs    choice or sequence delimiter
  1979. #
  1980. # Results:
  1981. #    See CModelSTcp.
  1982.  
  1983. proc sgml::CModelSTname {state name rep cs args} {
  1984.     if {[llength $args]} {
  1985.     return -code error "syntax error in specification: \"$args\""
  1986.     }
  1987.  
  1988.     CModelSTcp $state $name $rep $cs
  1989. }
  1990.  
  1991. # sgml::CModelSTcp --
  1992. #
  1993. #    Process a content particle.
  1994. #
  1995. # Arguments:
  1996. #    state    state array variable
  1997. #    name    name specified
  1998. #    rep    repetition operator
  1999. #    cs    choice or sequence delimiter
  2000. #
  2001. # Results:
  2002. #    The content particle is added to the current group.
  2003.  
  2004. proc sgml::CModelSTcp {state cp rep cs} {
  2005.     upvar #0 $state var
  2006.  
  2007.     switch -glob -- [lindex $var(state) end]=$cs {
  2008.     start= {
  2009.         set var(state) [lreplace $var(state) end end end]
  2010.         # Add (dummy) grouping, either choice or sequence will do
  2011.         CModelSTcsSet $state ,
  2012.         CModelSTcpAdd $state $cp $rep
  2013.     }
  2014.     :choice= -
  2015.     :seq= {
  2016.         set var(state) [lreplace $var(state) end end end]
  2017.         CModelSTcpAdd $state $cp $rep
  2018.     }
  2019.     start=| -
  2020.     start=, {
  2021.         set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
  2022.         CModelSTcsSet $state $cs
  2023.         CModelSTcpAdd $state $cp $rep
  2024.     }
  2025.     :choice=| -
  2026.     :seq=, {
  2027.         CModelSTcpAdd $state $cp $rep
  2028.     }
  2029.     :choice=, -
  2030.     :seq=| {
  2031.         return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
  2032.     }
  2033.     end=* {
  2034.         return -code error "syntax error in specification: no delimiter before \"$cp\""
  2035.     }
  2036.     default {
  2037.         return -code error "syntax error"
  2038.     }
  2039.     }
  2040.     
  2041. }
  2042.  
  2043. # sgml::CModelSTcsSet --
  2044. #
  2045. #    Start a choice or sequence on the stack.
  2046. #
  2047. # Arguments:
  2048. #    state    state array
  2049. #    cs    choice oir sequence
  2050. #
  2051. # Results:
  2052. #    state is modified: end element of state is appended.
  2053.  
  2054. proc sgml::CModelSTcsSet {state cs} {
  2055.     upvar #0 $state var
  2056.  
  2057.     set cs [expr {$cs == "," ? ":seq" : ":choice"}]
  2058.  
  2059.     if {[llength $var(stack)]} {
  2060.     set var(stack) [lreplace $var(stack) end end $cs]
  2061.     } else {
  2062.     set var(stack) [list $cs {}]
  2063.     }
  2064. }
  2065.  
  2066. # sgml::CModelSTcpAdd --
  2067. #
  2068. #    Append a content particle to the top of the stack.
  2069. #
  2070. # Arguments:
  2071. #    state    state array
  2072. #    cp    content particle
  2073. #    rep    repetition
  2074. #
  2075. # Results:
  2076. #    state is modified: end element of state is appended.
  2077.  
  2078. proc sgml::CModelSTcpAdd {state cp rep} {
  2079.     upvar #0 $state var
  2080.  
  2081.     if {[llength $var(stack)]} {
  2082.     set top [lindex $var(stack) end]
  2083.         lappend top [list $rep $cp]
  2084.     set var(stack) [lreplace $var(stack) end end $top]
  2085.     } else {
  2086.     set var(stack) [list $rep $cp]
  2087.     }
  2088. }
  2089.  
  2090. # sgml::CModelSTopenParen --
  2091. #
  2092. #    Processes a '(' in a content model spec.
  2093. #
  2094. # Arguments:
  2095. #    state    state array
  2096. #
  2097. # Results:
  2098. #    Pushes stack in state array.
  2099.  
  2100. proc sgml::CModelSTopenParen {state args} {
  2101.     upvar #0 $state var
  2102.  
  2103.     if {[llength $args]} {
  2104.     return -code error "syntax error in specification: \"$args\""
  2105.     }
  2106.  
  2107.     lappend var(state) start
  2108.     lappend var(stack) [list {} {}]
  2109. }
  2110.  
  2111. # sgml::CModelSTcloseParen --
  2112. #
  2113. #    Processes a ')' in a content model spec.
  2114. #
  2115. # Arguments:
  2116. #    state    state array
  2117. #    rep    repetition
  2118. #    cs    choice or sequence delimiter
  2119. #
  2120. # Results:
  2121. #    Stack is popped, and former top of stack is appended to previous element.
  2122.  
  2123. proc sgml::CModelSTcloseParen {state rep cs args} {
  2124.     upvar #0 $state var
  2125.  
  2126.     if {[llength $args]} {
  2127.     return -code error "syntax error in specification: \"$args\""
  2128.     }
  2129.  
  2130.     set cp [lindex $var(stack) end]
  2131.     set var(stack) [lreplace $var(stack) end end]
  2132.     set var(state) [lreplace $var(state) end end]
  2133.     CModelSTcp $state $cp $rep $cs
  2134. }
  2135.  
  2136. # sgml::CModelMakeTransitionTable --
  2137. #
  2138. #    Given a content model's syntax tree, constructs
  2139. #    the transition table for the regular expression.
  2140. #
  2141. #    See "Compilers, Principles, Techniques, and Tools",
  2142. #    Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
  2143. #
  2144. # Arguments:
  2145. #    state    state array variable
  2146. #    st    syntax tree
  2147. #
  2148. # Results:
  2149. #    The transition table is returned, as a key/value Tcl list.
  2150.  
  2151. proc sgml::CModelMakeTransitionTable {state st} {
  2152.     upvar #0 $state var
  2153.  
  2154.     # Construct nullable, firstpos and lastpos functions
  2155.     array set var {number 0}
  2156.     foreach {nullable firstpos lastpos} [    \
  2157.     TraverseDepth1st $state $st {
  2158.         # Evaluated for leaf nodes
  2159.         # Compute nullable(n)
  2160.         # Compute firstpos(n)
  2161.         # Compute lastpos(n)
  2162.         set nullable [nullable leaf $rep $name]
  2163.         set firstpos [list {} $var(number)]
  2164.         set lastpos [list {} $var(number)]
  2165.         set var(pos:$var(number)) $name
  2166.     } {
  2167.         # Evaluated for nonterminal nodes
  2168.         # Compute nullable, firstpos, lastpos
  2169.         set firstpos [firstpos $cs $firstpos $nullable]
  2170.         set lastpos  [lastpos  $cs $lastpos  $nullable]
  2171.         set nullable [nullable nonterm $rep $cs $nullable]
  2172.     }    \
  2173.     ] break
  2174.  
  2175.     set accepting [incr var(number)]
  2176.     set var(pos:$accepting) #
  2177.  
  2178.     # var(pos:N) maps from position to symbol.
  2179.     # Construct reverse map for convenience.
  2180.     # NB. A symbol may appear in more than one position.
  2181.     # var is about to be reset, so use different arrays.
  2182.  
  2183.     foreach {pos symbol} [array get var pos:*] {
  2184.     set pos [lindex [split $pos :] 1]
  2185.     set pos2symbol($pos) $symbol
  2186.     lappend sym2pos($symbol) $pos
  2187.     }
  2188.  
  2189.     # Construct the followpos functions
  2190.     catch {unset var}
  2191.     followpos $state $st $firstpos $lastpos
  2192.  
  2193.     # Construct transition table
  2194.     # Dstates is [union $marked $unmarked]
  2195.     set unmarked [list [lindex $firstpos 1]]
  2196.     while {[llength $unmarked]} {
  2197.     set T [lindex $unmarked 0]
  2198.     lappend marked $T
  2199.     set unmarked [lrange $unmarked 1 end]
  2200.  
  2201.     # Find which input symbols occur in T
  2202.     set symbols {}
  2203.     foreach pos $T {
  2204.         if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
  2205.         lappend symbols $pos2symbol($pos)
  2206.         }
  2207.     }
  2208.     foreach a $symbols {
  2209.         set U {}
  2210.         foreach pos $sym2pos($a) {
  2211.         if {[lsearch $T $pos] >= 0} {
  2212.             # add followpos($pos)
  2213.                 if {$var($pos) == {}} {
  2214.                     lappend U $accepting
  2215.                 } else {
  2216.                     eval lappend U $var($pos)
  2217.                 }
  2218.         }
  2219.         }
  2220.         set U [makeSet $U]
  2221.         if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
  2222.         lappend unmarked $U
  2223.         }
  2224.         set Dtran($T,$a) $U
  2225.     }
  2226.     
  2227.     }
  2228.  
  2229.     return [list [array get Dtran] [array get sym2pos] $accepting]
  2230. }
  2231.  
  2232. # sgml::followpos --
  2233. #
  2234. #    Compute the followpos function, using the already computed
  2235. #    firstpos and lastpos.
  2236. #
  2237. # Arguments:
  2238. #    state        array variable to store followpos functions
  2239. #    st        syntax tree
  2240. #    firstpos    firstpos functions for the syntax tree
  2241. #    lastpos        lastpos functions
  2242. #
  2243. # Results:
  2244. #    followpos functions for each leaf node, in name/value format
  2245.  
  2246. proc sgml::followpos {state st firstpos lastpos} {
  2247.     upvar #0 $state var
  2248.  
  2249.     switch -- [lindex [lindex $st 1] 0] {
  2250.     :seq {
  2251.         for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
  2252.             followpos $state [lindex [lindex $st 1] $i]            \
  2253.             [lindex [lindex $firstpos 0] [expr $i - 1]]    \
  2254.             [lindex [lindex $lastpos 0] [expr $i - 1]]
  2255.             foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
  2256.             eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
  2257.             set var($pos) [makeSet $var($pos)]
  2258.             }
  2259.         }
  2260.     }
  2261.     :choice {
  2262.         for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
  2263.         followpos $state [lindex [lindex $st 1] $i]            \
  2264.             [lindex [lindex $firstpos 0] [expr $i - 1]]    \
  2265.             [lindex [lindex $lastpos 0] [expr $i - 1]]
  2266.         }
  2267.     }
  2268.     default {
  2269.         # No action at leaf nodes
  2270.     }
  2271.     }
  2272.  
  2273.     switch -- [lindex $st 0] {
  2274.     ? {
  2275.         # We having nothing to do here ! Doing the same as
  2276.         # for * effectively converts this qualifier into the other.
  2277.     }
  2278.     * {
  2279.         foreach pos [lindex $lastpos 1] {
  2280.         eval lappend var($pos) [lindex $firstpos 1]
  2281.         set var($pos) [makeSet $var($pos)]
  2282.         }
  2283.     }
  2284.     }
  2285.  
  2286. }
  2287.  
  2288. # sgml::TraverseDepth1st --
  2289. #
  2290. #    Perform depth-first traversal of a tree.
  2291. #    A new tree is constructed, with each node computed by f.
  2292. #
  2293. # Arguments:
  2294. #    state    state array variable
  2295. #    t    The tree to traverse, a Tcl list
  2296. #    leaf    Evaluated at a leaf node
  2297. #    nonTerm    Evaluated at a nonterminal node
  2298. #
  2299. # Results:
  2300. #    A new tree is returned.
  2301.  
  2302. proc sgml::TraverseDepth1st {state t leaf nonTerm} {
  2303.     upvar #0 $state var
  2304.  
  2305.     set nullable {}
  2306.     set firstpos {}
  2307.     set lastpos {}
  2308.  
  2309.     switch -- [lindex [lindex $t 1] 0] {
  2310.     :seq -
  2311.     :choice {
  2312.         set rep [lindex $t 0]
  2313.         set cs [lindex [lindex $t 1] 0]
  2314.  
  2315.         foreach child [lrange [lindex $t 1] 1 end] {
  2316.         foreach {childNullable childFirstpos childLastpos} \
  2317.             [TraverseDepth1st $state $child $leaf $nonTerm] break
  2318.         lappend nullable $childNullable
  2319.         lappend firstpos $childFirstpos
  2320.         lappend lastpos  $childLastpos
  2321.         }
  2322.  
  2323.         eval $nonTerm
  2324.     }
  2325.     default {
  2326.         incr var(number)
  2327.         set rep [lindex [lindex $t 0] 0]
  2328.         set name [lindex [lindex $t 1] 0]
  2329.         eval $leaf
  2330.     }
  2331.     }
  2332.  
  2333.     return [list $nullable $firstpos $lastpos]
  2334. }
  2335.  
  2336. # sgml::firstpos --
  2337. #
  2338. #    Computes the firstpos function for a nonterminal node.
  2339. #
  2340. # Arguments:
  2341. #    cs        node type, choice or sequence
  2342. #    firstpos    firstpos functions for the subtree
  2343. #    nullable    nullable functions for the subtree
  2344. #
  2345. # Results:
  2346. #    firstpos function for this node is returned.
  2347.  
  2348. proc sgml::firstpos {cs firstpos nullable} {
  2349.     switch -- $cs {
  2350.     :seq {
  2351.         set result [lindex [lindex $firstpos 0] 1]
  2352.         for {set i 0} {$i < [llength $nullable]} {incr i} {
  2353.             if {[lindex [lindex $nullable $i] 1]} {
  2354.                 eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
  2355.         } else {
  2356.             break
  2357.         }
  2358.         }
  2359.     }
  2360.     :choice {
  2361.         foreach child $firstpos {
  2362.         eval lappend result $child
  2363.         }
  2364.     }
  2365.     }
  2366.  
  2367.     return [list $firstpos [makeSet $result]]
  2368. }
  2369.  
  2370. # sgml::lastpos --
  2371. #
  2372. #    Computes the lastpos function for a nonterminal node.
  2373. #    Same as firstpos, only logic is reversed
  2374. #
  2375. # Arguments:
  2376. #    cs        node type, choice or sequence
  2377. #    lastpos        lastpos functions for the subtree
  2378. #    nullable    nullable functions forthe subtree
  2379. #
  2380. # Results:
  2381. #    lastpos function for this node is returned.
  2382.  
  2383. proc sgml::lastpos {cs lastpos nullable} {
  2384.     switch -- $cs {
  2385.     :seq {
  2386.         set result [lindex [lindex $lastpos end] 1]
  2387.         for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
  2388.         if {[lindex [lindex $nullable $i] 1]} {
  2389.             eval lappend result [lindex [lindex $lastpos $i] 1]
  2390.         } else {
  2391.             break
  2392.         }
  2393.         }
  2394.     }
  2395.     :choice {
  2396.         foreach child $lastpos {
  2397.         eval lappend result $child
  2398.         }
  2399.     }
  2400.     }
  2401.  
  2402.     return [list $lastpos [makeSet $result]]
  2403. }
  2404.  
  2405. # sgml::makeSet --
  2406. #
  2407. #    Turn a list into a set, ie. remove duplicates.
  2408. #
  2409. # Arguments:
  2410. #    s    a list
  2411. #
  2412. # Results:
  2413. #    A set is returned, which is a list with duplicates removed.
  2414.  
  2415. proc sgml::makeSet s {
  2416.     foreach r $s {
  2417.     if {[llength $r]} {
  2418.         set unique($r) {}
  2419.     }
  2420.     }
  2421.     return [array names unique]
  2422. }
  2423.  
  2424. # sgml::nullable --
  2425. #
  2426. #    Compute the nullable function for a node.
  2427. #
  2428. # Arguments:
  2429. #    nodeType    leaf or nonterminal
  2430. #    rep        repetition applying to this node
  2431. #    name        leaf node: symbol for this node, nonterm node: choice or seq node
  2432. #    subtree        nonterm node: nullable functions for the subtree
  2433. #
  2434. # Results:
  2435. #    Returns nullable function for this branch of the tree.
  2436.  
  2437. proc sgml::nullable {nodeType rep name {subtree {}}} {
  2438.     switch -glob -- $rep:$nodeType {
  2439.     :leaf -
  2440.     +:leaf {
  2441.         return [list {} 0]
  2442.     }
  2443.     \\*:leaf -
  2444.     \\?:leaf {
  2445.         return [list {} 1]
  2446.     }
  2447.     \\*:nonterm -
  2448.     \\?:nonterm {
  2449.         return [list $subtree 1]
  2450.     }
  2451.     :nonterm -
  2452.     +:nonterm {
  2453.         switch -- $name {
  2454.         :choice {
  2455.             set result 0
  2456.             foreach child $subtree {
  2457.             set result [expr $result || [lindex $child 1]]
  2458.             }
  2459.         }
  2460.         :seq {
  2461.             set result 1
  2462.             foreach child $subtree {
  2463.             set result [expr $result && [lindex $child 1]]
  2464.             }
  2465.         }
  2466.         }
  2467.         return [list $subtree $result]
  2468.     }
  2469.     }
  2470. }
  2471.  
  2472. # sgml::DTD:ATTLIST --
  2473. #
  2474. #    <!ATTLIST ...> defines an attribute list.
  2475. #
  2476. # Arguments:
  2477. #    opts    configuration opions
  2478. #    name    Element GI
  2479. #    attspec    unparsed attribute definitions
  2480. #
  2481. # Results:
  2482. #    Attribute list variables are modified.
  2483.  
  2484. proc sgml::DTD:ATTLIST {opts name attspec} {
  2485.     variable attlist_exp
  2486.     variable attlist_enum_exp
  2487.     variable attlist_fixed_exp
  2488.  
  2489.     array set options $opts
  2490.  
  2491.     # Parse the attribute list.  If it were regular, could just use foreach,
  2492.     # but some attributes may have values.
  2493.     regsub -all {([][$\\])} $attspec {\\\1} attspec
  2494.     regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
  2495.     regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
  2496.     regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec
  2497.  
  2498.     eval "noop \{$attspec\}"
  2499.  
  2500.     return {}
  2501. }
  2502.  
  2503. # sgml::DTDAttribute --
  2504. #
  2505. #    Parse definition of a single attribute.
  2506. #
  2507. # Arguments:
  2508. #    callback    attribute defn callback
  2509. #    name    element name
  2510. #    var    array variable
  2511. #    att    attribute name
  2512. #    type    type of this attribute
  2513. #    default    default value of the attribute
  2514. #    value    other information
  2515. #    text    other text (should be empty)
  2516. #
  2517. # Results:
  2518. #    Attribute defn added to array, unless it already exists
  2519.  
  2520. proc sgml::DTDAttribute args {
  2521.     # BUG: Some problems with parameter passing - deal with it later
  2522.     foreach {callback name var att type default value text} $args break
  2523.  
  2524.     upvar #0 $var atts
  2525.  
  2526.     if {[string length [string trim $text]]} {
  2527.     return -code error "unexpected text \"$text\" in attribute definition"
  2528.     }
  2529.  
  2530.     # What about overridden attribute defns?
  2531.     # A non-validating app may want to know about them
  2532.     # (eg. an editor)
  2533.     if {![info exists atts($name/$att)]} {
  2534.     set atts($name/$att) [list $type $default $value]
  2535.     uplevel #0 $callback [list $name $att $type $default $value]
  2536.     }
  2537.  
  2538.     return {}
  2539. }
  2540.  
  2541. # sgml::DTD:ENTITY --
  2542. #
  2543. #    <!ENTITY ...> declaration.
  2544. #
  2545. #    Callbacks:
  2546. #    -entitydeclcommand for general entity declaration
  2547. #    -unparsedentitydeclcommand for unparsed external entity declaration
  2548. #    -parameterentitydeclcommand for parameter entity declaration
  2549. #
  2550. # Arguments:
  2551. #    opts    configuration options
  2552. #    name    name of entity being defined
  2553. #    param    whether a parameter entity is being defined
  2554. #    value    unparsed replacement text
  2555. #
  2556. # Results:
  2557. #    Modifies the caller's entities array variable
  2558.  
  2559. proc sgml::DTD:ENTITY {opts name param value} {
  2560.  
  2561.     array set options $opts
  2562.  
  2563.     if {[string compare % $param]} {
  2564.     # Entity declaration - general or external
  2565.     upvar #0 $options(entities) ents
  2566.     upvar #0 $options(extentities) externals
  2567.  
  2568.     if {[info exists ents($name)] || [info exists externals($name)]} {
  2569.         eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
  2570.     } else {
  2571.         if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
  2572.         return -code error "unable to parse entity declaration due to \"$value\""
  2573.         }
  2574.         switch -glob [lindex $value 0],[lindex $value 3] {
  2575.         internal, {
  2576.             set ents($name) [EntitySubst [array get options] [lindex $value 1]]
  2577.             uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
  2578.         }
  2579.         internal,* {
  2580.             return -code error "unexpected NDATA declaration"
  2581.         }
  2582.         external, {
  2583.             set externals($name) [lrange $value 1 2]
  2584.             uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
  2585.         }
  2586.         external,* {
  2587.             set externals($name) [lrange $value 1 3]
  2588.             uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
  2589.         }
  2590.         default {
  2591.             return -code error "internal error: unexpected parser state"
  2592.         }
  2593.         }
  2594.     }
  2595.     } else {
  2596.     # Parameter entity declaration
  2597.     upvar #0 $options(parameterentities) PEnts
  2598.     upvar #0 $options(externalparameterentities) ExtPEnts
  2599.  
  2600.     if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
  2601.         eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
  2602.     } else {
  2603.         if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
  2604.         return -code error "unable to parse parameter entity declaration due to \"$value\""
  2605.         }
  2606.         if {[string length [lindex $value 3]]} {
  2607.         return -code error "NDATA illegal in parameter entity declaration"
  2608.         }
  2609.         switch [lindex $value 0] {
  2610.         internal {
  2611.             # Substitute character references and PEs (XML: 4.5)
  2612.             set value [EntitySubst [array get options] [lindex $value 1]]
  2613.  
  2614.             set PEnts($name) $value
  2615.             uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
  2616.         }
  2617.         external -
  2618.         default {
  2619.             # Get the replacement text now.
  2620.             # Could wait until the first reference, but easier
  2621.             # to just do it now.
  2622.             package require uri
  2623.             set token [uri::geturl [uri::resolve $options(-baseurl) [lindex $value 1]]]
  2624.  
  2625.             set ExtPEnts($name) [lindex [array get $token data] 1]
  2626.             uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
  2627.         }
  2628.         }
  2629.     }
  2630.     }
  2631. }
  2632.  
  2633. # sgml::EntitySubst --
  2634. #
  2635. #    Perform entity substitution on an entity replacement text.
  2636. #    This differs slightly from other substitution procedures,
  2637. #    because only parameter and character entity substitution
  2638. #    is performed, not general entities.
  2639. #    See XML Rec. section 4.5.
  2640. #
  2641. # Arguments:
  2642. #    opts    configuration options
  2643. #    value    Literal entity value
  2644. #
  2645. # Results:
  2646. #    Expanded replacement text
  2647.  
  2648. proc sgml::EntitySubst {opts value} {
  2649.     array set options $opts
  2650.  
  2651.     # Protect Tcl special characters
  2652.     regsub -all {([{}\\])} $value {\\\1} value
  2653.  
  2654.     # Find entity references
  2655.     regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value
  2656.  
  2657.     set result [subst $value]
  2658.  
  2659.     return $result
  2660. }
  2661.  
  2662. # sgml::EntitySubstValue --
  2663. #
  2664. #    Handle a single character or parameter entity substitution
  2665. #
  2666. # Arguments:
  2667. #    PEvar    array variable containing PE declarations
  2668. #    ref    character or parameter entity reference
  2669. #
  2670. # Results:
  2671. #    Replacement text
  2672.  
  2673. proc sgml::EntitySubstValue {PEvar ref} {
  2674.     switch -glob -- $ref {
  2675.     &#x* {
  2676.         scan [string range $ref 3 end] %x hex
  2677.         return [format %c $hex]
  2678.     }
  2679.     &#* {
  2680.         return [format %c [string range $ref 2 end]]
  2681.     }
  2682.     %* {
  2683.         upvar #0 $PEvar PEs
  2684.         set ref [string range $ref 1 end]
  2685.         if {[info exists PEs($ref)]} {
  2686.         return $PEs($ref)
  2687.         } else {
  2688.         return -code error "parameter entity \"$ref\" not declared"
  2689.         }
  2690.     }
  2691.     default {
  2692.         return -code error "internal error - unexpected entity reference"
  2693.     }
  2694.     }
  2695.     return {}
  2696. }
  2697.  
  2698. # sgml::DTD:NOTATION --
  2699. #
  2700. #    Process notation declaration
  2701. #
  2702. # Arguments:
  2703. #    opts    configuration options
  2704. #    name    notation name
  2705. #    value    unparsed notation spec
  2706.  
  2707. proc sgml::DTD:NOTATION {opts name value} {
  2708.     return {}
  2709.  
  2710.     variable notation_exp
  2711.     upvar opts state
  2712.  
  2713.     if {[regexp $notation_exp $value x scheme data] == 2} {
  2714.     } else {
  2715.     eval $state(-errorcommand) notationvalue [list "notation value \"$value\" incorrectly specified"]
  2716.     }
  2717. }
  2718.  
  2719. # sgml::ResolveEntity --
  2720. #
  2721. #    Default entity resolution routine
  2722. #
  2723. # Arguments:
  2724. #    name    name of parent parser
  2725. #    base    base URL for relative URLs
  2726. #    sysId    system identifier
  2727. #    pubId    public identifier
  2728.  
  2729. proc sgml::ResolveEntity {name base sysId pubId} {
  2730.     variable ParseEventNum
  2731.  
  2732.     package require tcllib
  2733.  
  2734.     if {[catch {uri::resolve $base $sysId} url]} {
  2735.     return -code error "unable to resolve system identifier \"$sysId\""
  2736.     }
  2737.     if {[catch {uri::geturl $url} token]} {
  2738.     return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
  2739.     }
  2740.  
  2741.     upvar #0 $token data
  2742.  
  2743.     set parser [uplevel #0 $name entityparser]
  2744.  
  2745.     $parser parse $data(data) -dtdsubset external
  2746.     #$parser free
  2747.  
  2748.     return {}
  2749. }
  2750.