home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / xuibuilder / TclXML-1.1.1 / sgml.tcl < prev    next >
Text File  |  2000-11-02  |  46KB  |  1,654 lines
  1. # sgml.tcl --
  2. #
  3. #    This file provides generic parsing services 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. # Copyright (c) 1998,1999 Zveno Pty Ltd
  10. # http://www.zveno.com/
  11. #
  12. # Zveno makes this software available free of charge for any purpose.
  13. # Copies may be made of this software but all of this notice must be included
  14. # on any copy.
  15. #
  16. # The software was developed for research purposes only and Zveno does not
  17. # warrant that it is error free or fit for any purpose.  Zveno disclaims any
  18. # liability for all claims, expenses, losses, damages and costs any user may
  19. # incur as a result of using, copying or modifying this software.
  20. #
  21. # Copyright (c) 1997 ANU and CSIRO on behalf of the
  22. # participants in the CRC for Advanced Computational Systems ('ACSys').
  23. # 
  24. # ACSys makes this software and all associated data and documentation 
  25. # ('Software') available free of charge for any purpose.  You may make copies 
  26. # of the Software but you must include all of this notice on any copy.
  27. # 
  28. # The Software was developed for research purposes and ACSys does not warrant
  29. # that it is error free or fit for any purpose.  ACSys disclaims any
  30. # liability for all claims, expenses, losses, damages and costs any user may
  31. # incur as a result of using, copying or modifying the Software.
  32. #
  33. # $Id: sgml.tcl,v 1.1.1.1 1996/02/22 06:06:14 daniel Exp $
  34.  
  35. package provide sgml 1.6
  36.  
  37. namespace eval sgml {
  38.     namespace export tokenise parseEvent
  39.  
  40.     namespace export parseDTD
  41.  
  42.     # Convenience routine
  43.     proc cl x {
  44.     return "\[$x\]"
  45.     }
  46.  
  47.     # Define various regular expressions
  48.     # white space
  49.     variable Wsp " \t\r\n"
  50.     variable noWsp [cl ^$Wsp]
  51.  
  52.     # Various XML names
  53.     variable nmtoken [cl -a-zA-Z0-9._]+
  54.     variable name [cl a-zA-Z_][cl -a-zA-Z0-9._]*
  55.  
  56.     # Other
  57.     variable ParseEventNum
  58.     if {![info exists ParseEventNum]} {
  59.     set ParseEventNum 0
  60.     }
  61.     variable ParseDTDnum
  62.     if {![info exists ParseDTDNum]} {
  63.     set ParseDTDNum 0
  64.     }
  65.  
  66.     # table of predefined entities for XML
  67.  
  68.     variable EntityPredef
  69.     array set EntityPredef {
  70.     lt <   gt >   amp &   quot \"   apos '
  71.     }
  72.  
  73. }
  74.  
  75. # sgml::tokenise --
  76. #
  77. #    Transform the given HTML/XML text into a Tcl list.
  78. #
  79. # Arguments:
  80. #    sgml        text to tokenize
  81. #    elemExpr    RE to recognise tags
  82. #    elemSub        transform for matched tags
  83. #    args        options
  84. #
  85. # Valid Options:
  86. #    -final        boolean        True if no more data is to be supplied
  87. #    -statevariable    varName        Name of a variable used to store info
  88. #
  89. # Results:
  90. #    Returns a Tcl list representing the document.
  91.  
  92. proc sgml::tokenise {sgml elemExpr elemSub args} {
  93.     array set options {-final 1}
  94.     catch {array set options $args}
  95.     set options(-final) [Boolean $options(-final)]
  96.  
  97.     # If the data is not final then there must be a variable to store
  98.     # unused data.
  99.     if {!$options(-final) && ![info exists options(-statevariable)]} {
  100.     return -code error {option "-statevariable" required if not final}
  101.     }
  102.  
  103.     # Pre-process stage
  104.     #
  105.     # Extract the internal DTD subset, if any
  106.  
  107.     catch {upvar #0 $options(-internaldtdvariable) dtd}
  108.     if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
  109.     regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
  110.     }
  111.  
  112.     # Protect Tcl special characters
  113.     regsub -all {([{}\\])} $sgml {\\\1} sgml
  114.  
  115.     # Do the translation
  116.  
  117.     if {[info exists options(-statevariable)]} {
  118.     upvar #0 $opts(-statevariable) unused
  119.     if {[info exists unused]} {
  120.         regsub -all $elemExpr $unused$sgml $elemSub sgml
  121.         unset unused
  122.     } else {
  123.         regsub -all $elemExpr $sgml $elemSub sgml
  124.     }
  125.     set sgml "{} {} {} {} \{$sgml\}"
  126.  
  127.     # Performance note (Tcl 8.0):
  128.     #    Use of lindex, lreplace will cause parsing to list object
  129.  
  130.     if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text unused]} {
  131.         set sgml [lreplace $sgml end end $text]
  132.     }
  133.  
  134.     } else {
  135.  
  136.     # Performance note (Tcl 8.0):
  137.     #    In this case, no conversion to list object is performed
  138.  
  139.     regsub -all $elemExpr $sgml $elemSub sgml
  140.     set sgml "{} {} {} {} \{$sgml\}"
  141.     }
  142.  
  143.     return $sgml
  144.  
  145. }
  146.  
  147. # sgml::parseEvent --
  148. #
  149. #    Produces an event stream for a XML/HTML document,
  150. #    given the Tcl list format returned by tokenise.
  151. #
  152. #    This procedure checks that the document is well-formed,
  153. #    and throws an error if the document is found to be not
  154. #    well formed.  Warnings are passed via the -warningcommand script.
  155. #
  156. #    The procedure only check for well-formedness,
  157. #    no DTD is required.  However, facilities are provided for entity expansion.
  158. #
  159. # Arguments:
  160. #    sgml        Instance data, as a Tcl list.
  161. #    args        option/value pairs
  162. #
  163. # Valid Options:
  164. #    -final            Indicates end of document data
  165. #    -elementstartcommand    Called when an element starts
  166. #    -elementendcommand    Called when an element ends
  167. #    -characterdatacommand    Called when character data occurs
  168. #    -entityreferencecommand    Called when an entity reference occurs
  169. #    -processinginstructioncommand    Called when a PI occurs
  170. #    -externalentityrefcommand    Called for an external entity reference
  171. #
  172. #    (Not compatible with expat)
  173. #    -xmldeclcommand        Called when the XML declaration occurs
  174. #    -doctypecommand        Called when the document type declaration occurs
  175. #    -commentcommand        Called when a comment occurs
  176. #
  177. #    -errorcommand        Script to evaluate for a fatal error
  178. #    -warningcommand        Script to evaluate for a reportable warning
  179. #    -statevariable        global state variable
  180. #    -normalize        whether to normalize names
  181. #    -reportempty        whether to include an indication of empty elements
  182. #
  183. # Results:
  184. #    The various callback scripts are invoked.
  185. #    Returns empty string.
  186. #
  187. # BUGS:
  188. #    If command options are set to empty string then they should not be invoked.
  189.  
  190. proc sgml::parseEvent {sgml args} {
  191.     variable Wsp
  192.     variable noWsp
  193.     variable nmtoken
  194.     variable name
  195.     variable ParseEventNum
  196.  
  197.     array set options [list \
  198.     -elementstartcommand        [namespace current]::noop    \
  199.     -elementendcommand        [namespace current]::noop    \
  200.     -characterdatacommand        [namespace current]::noop    \
  201.     -processinginstructioncommand    [namespace current]::noop    \
  202.     -externalentityrefcommand    [namespace current]::noop    \
  203.     -xmldeclcommand            [namespace current]::noop    \
  204.     -doctypecommand            [namespace current]::noop    \
  205.     -commentcommand            [namespace current]::noop    \
  206.     -entityreferencecommand        {}                \
  207.     -warningcommand            [namespace current]::noop    \
  208.     -errorcommand            [namespace current]::Error    \
  209.     -final                1                \
  210.     -emptyelement            [namespace current]::EmptyElement    \
  211.     -parseattributelistcommand    [namespace current]::noop    \
  212.     -normalize            1                \
  213.     -internaldtd            {}                \
  214.     -reportempty            0                \
  215.     -entityvariable            [namespace current]::EntityPredef    \
  216.     ]
  217.     catch {array set options $args}
  218.  
  219.     if {![info exists options(-statevariable)]} {
  220.     set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
  221.     }
  222.  
  223.     upvar #0 $options(-statevariable) state
  224.     upvar #0 $options(-entityvariable) entities
  225.  
  226.     if {![info exists state]} {
  227.     # Initialise the state variable
  228.     array set state {
  229.         mode normal
  230.         haveXMLDecl 0
  231.         haveDocElement 0
  232.         context {}
  233.         stack {}
  234.         line 0
  235.     }
  236.     }
  237.  
  238.     foreach {tag close empty param text} $sgml {
  239.  
  240.     # Keep track of lines in the input
  241.     incr state(line) [regsub -all \n $param {} discard]
  242.     incr state(line) [regsub -all \n $text {} discard]
  243.  
  244.     # If the current mode is cdata or comment then we must undo what the
  245.     # regsub has done to reconstitute the data
  246.  
  247.     switch $state(mode) {
  248.         comment {
  249.         # This had "[string length $param] && " as a guard -
  250.         # can't remember why :-(
  251.         if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
  252.             # end of comment (in tag)
  253.             set tag {}
  254.             set close {}
  255.             set empty {}
  256.             set state(mode) normal
  257.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$comm1]
  258.             unset state(commentdata)
  259.         } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
  260.             # end of comment (in attributes)
  261.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$empty>$comm1]
  262.             unset state(commentdata)
  263.             set tag {}
  264.             set param {}
  265.             set close {}
  266.             set empty {}
  267.             set state(mode) normal
  268.         } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
  269.             # end of comment (in text)
  270.             uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$param$empty>$comm1]
  271.             unset state(commentdata)
  272.             set tag {}
  273.             set param {}
  274.             set close {}
  275.             set empty {}
  276.             set state(mode) normal
  277.         } else {
  278.             # comment continues
  279.             append state(commentdata) <$close$tag$param$empty>$text
  280.             continue
  281.         }
  282.         }
  283.         cdata {
  284.         if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
  285.             # end of CDATA (in tag)
  286.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$cdata1$text]
  287.             set text {}
  288.             set tag {}
  289.             unset state(cdata)
  290.             set state(mode) normal
  291.         } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
  292.             # end of CDATA (in attributes)
  293.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$tag$cdata1$text]
  294.             set text {}
  295.             set tag {}
  296.             set param {}
  297.             unset state(cdata)
  298.             set state(mode) normal
  299.         } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
  300.             # end of CDATA (in text)
  301.             uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$tag$param$empty>$cdata1$text]
  302.             set text {}
  303.             set tag {}
  304.             set param {}
  305.             set close {}
  306.             set empty {}
  307.             unset state(cdata)
  308.             set state(mode) normal
  309.         } else {
  310.             # CDATA continues
  311.             append state(cdata) <$close$tag$param$empty>$text
  312.             continue
  313.         }
  314.         }
  315.     }
  316.  
  317.     # default: normal mode
  318.  
  319.     # Bug: if the attribute list has a right angle bracket then the empty
  320.     # element marker will not be seen
  321.  
  322.     set isEmpty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
  323.     if {[llength $isEmpty]} {
  324.         foreach {empty tag param} $isEmpty break
  325.     }
  326.  
  327.     switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {
  328.  
  329.         0,0,, {
  330.         # Ignore empty tag - dealt with non-normal mode above
  331.         }
  332.         *,0,, {
  333.  
  334.         # Start tag for an element.
  335.  
  336.         # Check for a right angle bracket in an attribute value
  337.         # This manifests itself by terminating the value before
  338.         # the delimiter is seen, and the delimiter appearing
  339.         # in the text
  340.  
  341.         # BUG: If two or more attribute values have right angle
  342.         # brackets then this will fail on the second one.
  343.  
  344.         if {[regexp [format {=[%s]*"[^"]*$} $Wsp] $param] && \
  345.             [regexp {([^"]*"[^>]*)>(.*)} $text discard attrListRemainder text]} {
  346.             append param >$attrListRemainder
  347.         } elseif {[regexp [format {=[%s]*'[^']*$} $Wsp] $param] && \
  348.             [regexp {([^']*'[^>]*)>(.*)} $text discard attrListRemainder text]} {
  349.             append param >$attrListRemainder
  350.         }
  351.  
  352.         # Check if the internal DTD entity is in an attribute
  353.         # value
  354.         regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param
  355.  
  356.         ParseEvent:ElementOpen $tag $param options
  357.         set state(haveDocElement) 1
  358.  
  359.         }
  360.  
  361.         *,0,/, {
  362.  
  363.         # End tag for an element.
  364.  
  365.         ParseEvent:ElementClose $tag options
  366.  
  367.         }
  368.  
  369.         *,0,,/ {
  370.  
  371.         # Empty element
  372.  
  373.         ParseEvent:ElementOpen $tag $param options -empty 1
  374.         ParseEvent:ElementClose $tag options -empty 1
  375.  
  376.         }
  377.  
  378.         *,1,* {
  379.         # Processing instructions or XML declaration
  380.         switch -glob -- $tag {
  381.  
  382.             {\?xml} {
  383.             # XML Declaration
  384.             if {$state(haveXMLDecl)} {
  385.                 uplevel #0 $options(-errorcommand) "unexpected characters \"<$tag\" around line $state(line)"
  386.             } elseif {![regexp {\?$} $param]} {
  387.                 uplevel #0 $options(-errorcommand) "XML Declaration missing characters \"?>\" around line $state(line)"
  388.             } else {
  389.  
  390.                 # Get the version number
  391.                 if {[regexp {[     ]*version="(-+|[a-zA-Z0-9_.:]+)"[     ]*} $param discard version] || [regexp {[     ]*version='(-+|[a-zA-Z0-9_.:]+)'[     ]*} $param discard version]} {
  392.                 if {[string compare $version "1.0"]} {
  393.                     # Should we support future versions?
  394.                     # At least 1.X?
  395.                     uplevel #0 $options(-errorcommand) "document XML version \"$version\" is incompatible with XML version 1.0"
  396.                 }
  397.                 } else {
  398.                 uplevel #0 $options(-errorcommand) "XML Declaration missing version information around line $state(line)"
  399.                 }
  400.  
  401.                 # Get the encoding declaration
  402.                 set encoding {}
  403.                 regexp {[     ]*encoding="([A-Za-z]([A-Za-z0-9._]|-)*)"[     ]*} $param discard encoding
  404.                 regexp {[     ]*encoding='([A-Za-z]([A-Za-z0-9._]|-)*)'[     ]*} $param discard encoding
  405.  
  406.                 # Get the standalone declaration
  407.                 set standalone {}
  408.                 regexp {[     ]*standalone="(yes|no)"[     ]*} $param discard standalone
  409.                 regexp {[     ]*standalone='(yes|no)'[     ]*} $param discard standalone
  410.  
  411.                 # Invoke the callback
  412.                 uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
  413.  
  414.             }
  415.  
  416.             }
  417.  
  418.             {\?*} {
  419.             # Processing instruction
  420.             if {![regsub {\?$} $param {} param]} {
  421.                 uplevel #0 $options(-errorcommand) "PI: expected '?' character around line $state(line)"
  422.             } else {
  423.                 uplevel #0 $options(-processinginstructioncommand) [list [string range $tag 1 end] [string trimleft $param]]
  424.             }
  425.             }
  426.  
  427.             !DOCTYPE {
  428.             # External entity reference
  429.             # This should move into xml.tcl
  430.             # Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
  431.             regexp ^[cl $Wsp]*($name)(.*) $param x state(doc_name) param
  432.             set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
  433.             set externalID {}
  434.             set pubidlit {}
  435.             set systemlit {}
  436.             set externalID {}
  437.             if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
  438.                 switch [string toupper $id] {
  439.                 SYSTEM {
  440.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
  441.                     set externalID [list SYSTEM $systemlit] ;# "
  442.                     } else {
  443.                     uplevel #0 $options(-errorcommand) {{syntax error: SYSTEM identifier not followed by literal}}
  444.                     }
  445.                 }
  446.                 PUBLIC {
  447.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
  448.                     if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
  449.                         set externalID [list PUBLIC $pubidlit $systemlit]
  450.                     } else {
  451.                         uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"
  452.                     }
  453.                     } else {
  454.                     uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by literal around line $state(line)"
  455.                     }
  456.                 }
  457.                 }
  458.                 if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($name)(.*) $param x notation param]} {
  459.                 lappend externalID $notation
  460.                 }
  461.             }
  462.  
  463.             uplevel #0 $options(-doctypecommand) $state(doc_name) [list $pubidlit $systemlit $options(-internaldtd)]
  464.  
  465.             }
  466.  
  467.             !--* {
  468.  
  469.             # Start of a comment
  470.             # See if it ends in the same tag, otherwise change the
  471.             # parsing mode
  472.  
  473.             regexp {!--(.*)} $tag discard comm1
  474.             if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
  475.                 # processed comment (end in tag)
  476.                 uplevel #0 $options(-commentcommand) [list $comm1_1]
  477.             } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
  478.                 # processed comment (end in attributes)
  479.                 uplevel #0 $options(-commentcommand) [list $comm1$comm2]
  480.             } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
  481.                 # processed comment (end in text)
  482.                 uplevel #0 $options(-commentcommand) [list $comm1$param>$comm2]
  483.             } else {
  484.                 # start of comment
  485.                 set state(mode) comment
  486.                 set state(commentdata) "$comm1$param>$text"
  487.                 continue
  488.             }
  489.             }
  490.  
  491.             {!\[CDATA\[*} {
  492.  
  493.             regexp {!\[CDATA\[(.*)} $tag discard cdata1
  494.             if {[regexp {(.*)]]$} $param discard cdata2]} {
  495.                 # processed CDATA (end in attribute)
  496.                 uplevel #0 $options(-characterdatacommand) [list $cdata1$cdata2$text]
  497.                 set text {}
  498.             } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
  499.                 # processed CDATA (end in text)
  500.                 uplevel #0 $options(-characterdatacommand) [list $cdata1$param$empty>$cdata2$text]
  501.                 set text {}
  502.             } else {
  503.                 # start CDATA
  504.                 set state(cdata) "$cdata1$param>$text"
  505.                 set state(mode) cdata
  506.                 continue
  507.             }
  508.  
  509.             }
  510.  
  511.             !ELEMENT {
  512.             # Internal DTD declaration
  513.             }
  514.             !ATTLIST {
  515.             }
  516.             !ENTITY {
  517.             }
  518.             !NOTATION {
  519.             }
  520.  
  521.  
  522.             !* {
  523.             uplevel #0 $options(-processinginstructioncommand) [list $tag $param]
  524.             }
  525.             default {
  526.             uplevel #0 $options(-errorcommand) [list "unknown processing instruction \"<$tag>\" around line $state(line)"]
  527.             }
  528.         }
  529.         }
  530.         *,1,* -
  531.         *,0,/,/ {
  532.         # Syntax error
  533.             uplevel #0 $options(-errorcommand) [list [list syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)]]
  534.         }
  535.     }
  536.  
  537.     # Process character data
  538.  
  539.     if {$state(haveDocElement) && [llength $state(stack)]} {
  540.  
  541.         # Check if the internal DTD entity is in the text
  542.         regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text
  543.  
  544.         # Look for entity references
  545.         if {([array size entities] || [string length $options(-entityreferencecommand)]) && \
  546.         [regexp {&[^;]+;} $text]} {
  547.  
  548.         # protect Tcl specials
  549.         regsub -all {([][$\\])} $text {\\\1} text
  550.         # Mark entity references
  551.         regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity options $options(-entityreferencecommand) $options(-characterdatacommand) $options(-entityvariable)]] [list uplevel #0 $options(-characterdatacommand)] \{\{] text
  552.         set text "uplevel #0 $options(-characterdatacommand) {{$text}}"
  553.         eval $text
  554.         } else {
  555.         # Restore protected special characters
  556.         regsub -all {\\([{}\\])} $text {\1} text
  557.         uplevel #0 $options(-characterdatacommand) [list $text]
  558.         }
  559.     } elseif {[string length [string trim $text]]} {
  560.         uplevel #0 $options(-errorcommand) "unexpected text \"$text\" in document prolog around line $state(line)"
  561.     }
  562.  
  563.     }
  564.  
  565.     # If this is the end of the document, close all open containers
  566.     if {$options(-final) && [llength $state(stack)]} {
  567.     eval $options(-errorcommand) [list [list element [lindex $state(stack) end] remains unclosed around line $state(line)]]
  568.     }
  569.  
  570.     return {}
  571. }
  572.  
  573. # sgml::ParseEvent:ElementOpen --
  574. #
  575. #    Start of an element.
  576. #
  577. # Arguments:
  578. #    tag    Element name
  579. #    attr    Attribute list
  580. #    opts    Option variable in caller
  581. #    args    further configuration options
  582. #
  583. # Options:
  584. #    -empty boolean
  585. #        indicates whether the element was an empty element
  586. #
  587. # Results:
  588. #    Modify state and invoke callback
  589.  
  590. proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
  591.     upvar $opts options
  592.     upvar #0 $options(-statevariable) state
  593.     array set cfg {-empty 0}
  594.     array set cfg $args
  595.  
  596.     if {$options(-normalize)} {
  597.     set tag [string toupper $tag]
  598.     }
  599.  
  600.     # Update state
  601.     lappend state(stack) $tag
  602.  
  603.     # Parse attribute list into a key-value representation
  604.     if {[string compare $options(-parseattributelistcommand) {}]} {
  605.     if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $attr]} attr]} {
  606.         uplevel #0 $options(-errorcommand) [list $attr around line $state(line)]
  607.         set attr {}
  608.     }
  609.     }
  610.  
  611.     set empty {}
  612.     if {$cfg(-empty) && $options(-reportempty)} {
  613.     set empty {-empty 1}
  614.     }
  615.  
  616.     # Invoke callback
  617.     uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty
  618.  
  619.     return {}
  620. }
  621.  
  622. # sgml::ParseEvent:ElementClose --
  623. #
  624. #    End of an element.
  625. #
  626. # Arguments:
  627. #    tag    Element name
  628. #    opts    Option variable in caller
  629. #    args    further configuration options
  630. #
  631. # Options:
  632. #    -empty boolean
  633. #        indicates whether the element as an empty element
  634. #
  635. # Results:
  636. #    Modify state and invoke callback
  637.  
  638. proc sgml::ParseEvent:ElementClose {tag opts args} {
  639.     upvar $opts options
  640.     upvar #0 $options(-statevariable) state
  641.     array set cfg {-empty 0}
  642.     array set cfg $args
  643.  
  644.     # WF check
  645.     if {[string compare $tag [lindex $state(stack) end]]} {
  646.     uplevel #0 $options(-errorcommand) [list "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
  647.     return
  648.     }
  649.  
  650.     # Update state
  651.     set state(stack) [lreplace $state(stack) end end]
  652.  
  653.     set empty {}
  654.     if {$cfg(-empty) && $options(-reportempty)} {
  655.     set empty {-empty 1}
  656.     }
  657.  
  658.     # Invoke callback
  659.     uplevel #0 $options(-elementendcommand) [list $tag] $empty
  660.  
  661.     return {}
  662. }
  663.  
  664. # sgml::Normalize --
  665. #
  666. #    Perform name normalization if required
  667. #
  668. # Arguments:
  669. #    name    name to normalize
  670. #    req    normalization required
  671. #
  672. # Results:
  673. #    Name returned as upper-case if normalization required
  674.  
  675. proc sgml::Normalize {name req} {
  676.     if {$req} {
  677.     return [string toupper $name]
  678.     } else {
  679.     return $name
  680.     }
  681. }
  682.  
  683. # sgml::Entity --
  684. #
  685. #    Resolve XML entity references (syntax: &xxx;).
  686. #
  687. # Arguments:
  688. #    opts        options array variable in caller
  689. #    entityrefcmd    application callback for entity references
  690. #    pcdatacmd    application callback for character data
  691. #    entities    name of array containing entity definitions.
  692. #    ref        entity reference (the "xxx" bit)
  693. #
  694. # Results:
  695. #    Returns substitution text for given entity.
  696.  
  697. proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
  698.     upvar 2 $opts options
  699.     upvar #0 $options(-statevariable) state
  700.  
  701.     if {![string length $entities]} {
  702.     set entities [namespace current EntityPredef]
  703.     }
  704.  
  705.     switch -glob -- $ref {
  706.     %* {
  707.         # Parameter entity - not recognised outside of a DTD
  708.     }
  709.     #x* {
  710.         # Character entity - hex
  711.         if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
  712.         return -code error "malformed character entity \"$ref\""
  713.         }
  714.         uplevel #0 $pcdatacmd [list $char]
  715.  
  716.         return {}
  717.  
  718.     }
  719.     #* {
  720.         # Character entity - decimal
  721.         if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
  722.         return -code error "malformed character entity \"$ref\""
  723.         }
  724.         uplevel #0 $pcdatacmd [list $char]
  725.  
  726.         return {}
  727.  
  728.     }
  729.     default {
  730.         # General entity
  731.         upvar #0 $entities map
  732.         if {[info exists map($ref)]} {
  733.  
  734.         if {![regexp {<|&} $map($ref)]} {
  735.  
  736.             # Simple text replacement - optimise
  737.  
  738.             uplevel #0 $pcdatacmd [list $map($ref)]
  739.  
  740.             return {}
  741.  
  742.         }
  743.  
  744.         # Otherwise an additional round of parsing is required.
  745.         # This only applies to XML, since HTML doesn't have general entities
  746.  
  747.         # Must parse the replacement text for start & end tags, etc
  748.         # This text must be self-contained: balanced closing tags, and so on
  749.  
  750.         set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
  751.         set final $options(-final)
  752.         unset options(-final)
  753.         eval parseEvent [list $tokenised] [array get options] -final 0
  754.         set options(-final) $final
  755.  
  756.         return {}
  757.  
  758.         } elseif {[string length $entityrefcmd]} {
  759.  
  760.         uplevel #0 $entityrefcmd [list $ref]
  761.  
  762.         return {}
  763.  
  764.         }
  765.     }
  766.     }
  767.  
  768.     # If all else fails leave the entity reference untouched
  769.     uplevel #0 $pcdatacmd [list &$ref\;]
  770.  
  771.     return {}
  772. }
  773.  
  774. ####################################
  775. #
  776. # DTD parser for SGML (XML).
  777. #
  778. # This DTD actually only handles XML DTDs.  Other language's
  779. # DTD's, such as HTML, must be written in terms of a XML DTD.
  780. #
  781. # A DTD is represented as a three element Tcl list.
  782. # The first element contains the content models for elements,
  783. # the second contains the attribute lists for elements and
  784. # the last element contains the entities for the document.
  785. #
  786. ####################################
  787.  
  788. # sgml::parseDTD --
  789. #
  790. #    Entry point to the SGML DTD parser.
  791. #
  792. # Arguments:
  793. #    dtd    data defining the DTD to be parsed
  794. #    args    configuration options
  795. #
  796. # Results:
  797. #    Returns a three element list, first element is the content model
  798. #    for each element, second element are the attribute lists of the
  799. #    elements and the third element is the entity map.
  800.  
  801. proc sgml::parseDTD {dtd args} {
  802.     variable Wsp
  803.     variable ParseDTDnum
  804.  
  805.     array set opts [list \
  806.     -errorcommand        [namespace current]::noop \
  807.     state            [namespace current]::parseDTD[incr ParseDTDnum]
  808.     ]
  809.     array set opts $args
  810.  
  811.     set exp <!([cl ^$Wsp>]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^>]*)>
  812.     set sub {{\1} {\2} {\3} }
  813.     regsub -all $exp $dtd $sub dtd
  814.  
  815.     foreach {decl id value} $dtd {
  816.     catch {DTD:[string toupper $decl] $id $value} err
  817.     }
  818.  
  819.     return [list [array get contentmodel] [array get attributes] [array get entities]]
  820. }
  821.  
  822. # Procedures for handling the various declarative elements in a DTD.
  823. # New elements may be added by creating a procedure of the form
  824. # parse:DTD:_element_
  825.  
  826. # For each of these procedures, the various regular expressions they use
  827. # are created outside of the proc to avoid overhead at runtime
  828.  
  829. # sgml::DTD:ELEMENT --
  830. #
  831. #    <!ELEMENT ...> defines an element.
  832. #
  833. #    The content model for the element is stored in the contentmodel array,
  834. #    indexed by the element name.  The content model is parsed into the
  835. #    following list form:
  836. #
  837. #        {}    Content model is EMPTY.
  838. #            Indicated by an empty list.
  839. #        *    Content model is ANY.
  840. #            Indicated by an asterix.
  841. #        {ELEMENT ...}
  842. #            Content model is element-only.
  843. #        {MIXED {element1 element2 ...}}
  844. #            Content model is mixed (PCDATA and elements).
  845. #            The second element of the list contains the 
  846. #            elements that may occur.  #PCDATA is assumed 
  847. #            (ie. the list is normalised).
  848. #
  849. # Arguments:
  850. #    id    identifier for the element.
  851. #    value    other information in the PI
  852.  
  853. proc sgml::DTD:ELEMENT {id value} {
  854.     dbgputs DTD_parse [list DTD:ELEMENT $id $value]
  855.     variable Wsp
  856.     upvar opts state
  857.     upvar contentmodel cm
  858.  
  859.     if {[info exists cm($id)]} {
  860.     eval $state(-errorcommand) element [list "element \"$id\" already declared"]
  861.     } else {
  862.     switch -- $value {
  863.         EMPTY {
  864.             set cm($id) {}
  865.         }
  866.         ANY {
  867.             set cm($id) *
  868.         }
  869.         default {
  870.         if {[regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
  871.             set cm($id) [list MIXED [split $mtoks |]]
  872.         } else {
  873.             if {[catch {CModelParse $state(state) $value} result]} {
  874.             eval $state(-errorcommand) element [list $result]
  875.             } else {
  876.             set cm($id) [list ELEMENT $result]
  877.             }
  878.         }
  879.         }
  880.     }
  881.     }
  882. }
  883.  
  884. # sgml::CModelParse --
  885. #
  886. #    Parse an element content model (non-mixed).
  887. #    A syntax tree is constructed.
  888. #    A transition table is built next.
  889. #
  890. #    This is going to need alot of work!
  891. #
  892. # Arguments:
  893. #    state    state array variable
  894. #    value    the content model data
  895. #
  896. # Results:
  897. #    A Tcl list representing the content model.
  898.  
  899. proc sgml::CModelParse {state value} {
  900.     upvar #0 $state var
  901.  
  902.     # First build syntax tree
  903.     set syntaxTree [CModelMakeSyntaxTree $state $value]
  904.  
  905.     # Build transition table
  906.     set transitionTable [CModelMakeTransitionTable $state $syntaxTree]
  907.  
  908.     return [list $syntaxTree $transitionTable]
  909. }
  910.  
  911. # sgml::CModelMakeSyntaxTree --
  912. #
  913. #    Construct a syntax tree for the regular expression.
  914. #
  915. #    Syntax tree is represented as a Tcl list:
  916. #    rep {:choice|:seq {{rep list1} {rep list2} ...}}
  917. #    where:    rep is repetition character, *, + or ?. {} for no repetition
  918. #        listN is nested expression or Name
  919. #
  920. # Arguments:
  921. #    spec    Element specification
  922. #
  923. # Results:
  924. #    Syntax tree for element spec as nested Tcl list.
  925. #
  926. #    Examples:
  927. #    (memo)
  928. #        {} {:seq {{} memo}}
  929. #    (front, body, back?)
  930. #        {} {:seq {{} front} {{} body} {? back}}
  931. #    (head, (p | list | note)*, div2*)
  932. #        {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
  933. #    (p | a | ul)+
  934. #        + {:choice {{} p} {{} a} {{} ul}}
  935.  
  936. proc sgml::CModelMakeSyntaxTree {state spec} {
  937.     upvar #0 $state var
  938.     variable Wsp
  939.     variable name
  940.  
  941.     # Translate the spec into a Tcl list.
  942.  
  943.     # None of the Tcl special characters are allowed in a content model spec.
  944.     if {[regexp {\$|\[|\]|\{|\}} $spec]} {
  945.     return -code error "illegal characters in specification"
  946.     }
  947.  
  948.     regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
  949.     regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
  950.     regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec
  951.  
  952.     array set var {stack {} state start}
  953.     eval $spec
  954.  
  955.     # Peel off the outer seq, its redundant
  956.     return [lindex [lindex $var(stack) 1] 0]
  957. }
  958.  
  959. # sgml::CModelSTname --
  960. #
  961. #    Processes a name in a content model spec.
  962. #
  963. # Arguments:
  964. #    state    state array variable
  965. #    name    name specified
  966. #    rep    repetition operator
  967. #    cs    choice or sequence delimiter
  968. #
  969. # Results:
  970. #    See CModelSTcp.
  971.  
  972. proc sgml::CModelSTname {state name rep cs args} {
  973.     if {[llength $args]} {
  974.     return -code error "syntax error in specification: \"$args\""
  975.     }
  976.  
  977.     CModelSTcp $state $name $rep $cs
  978. }
  979.  
  980. # sgml::CModelSTcp --
  981. #
  982. #    Process a content particle.
  983. #
  984. # Arguments:
  985. #    state    state array variable
  986. #    name    name specified
  987. #    rep    repetition operator
  988. #    cs    choice or sequence delimiter
  989. #
  990. # Results:
  991. #    The content particle is added to the current group.
  992.  
  993. proc sgml::CModelSTcp {state cp rep cs} {
  994.     upvar #0 $state var
  995.  
  996.     switch -glob -- [lindex $var(state) end]=$cs {
  997.     start= {
  998.         set var(state) [lreplace $var(state) end end end]
  999.         # Add (dummy) grouping, either choice or sequence will do
  1000.         CModelSTcsSet $state ,
  1001.         CModelSTcpAdd $state $cp $rep
  1002.     }
  1003.     :choice= -
  1004.     :seq= {
  1005.         set var(state) [lreplace $var(state) end end end]
  1006.         CModelSTcpAdd $state $cp $rep
  1007.     }
  1008.     start=| -
  1009.     start=, {
  1010.         set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
  1011.         CModelSTcsSet $state $cs
  1012.         CModelSTcpAdd $state $cp $rep
  1013.     }
  1014.     :choice=| -
  1015.     :seq=, {
  1016.         CModelSTcpAdd $state $cp $rep
  1017.     }
  1018.     :choice=, -
  1019.     :seq=| {
  1020.         return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
  1021.     }
  1022.     end=* {
  1023.         return -code error "syntax error in specification: no delimiter before \"$cp\""
  1024.     }
  1025.     default {
  1026.         return -code error "syntax error"
  1027.     }
  1028.     }
  1029.     
  1030. }
  1031.  
  1032. # sgml::CModelSTcsSet --
  1033. #
  1034. #    Start a choice or sequence on the stack.
  1035. #
  1036. # Arguments:
  1037. #    state    state array
  1038. #    cs    choice oir sequence
  1039. #
  1040. # Results:
  1041. #    state is modified: end element of state is appended.
  1042.  
  1043. proc sgml::CModelSTcsSet {state cs} {
  1044.     upvar #0 $state var
  1045.  
  1046.     set cs [expr {$cs == "," ? ":seq" : ":choice"}]
  1047.  
  1048.     if {[llength $var(stack)]} {
  1049.     set var(stack) [lreplace $var(stack) end end $cs]
  1050.     } else {
  1051.     set var(stack) [list $cs {}]
  1052.     }
  1053. }
  1054.  
  1055. # sgml::CModelSTcpAdd --
  1056. #
  1057. #    Append a content particle to the top of the stack.
  1058. #
  1059. # Arguments:
  1060. #    state    state array
  1061. #    cp    content particle
  1062. #    rep    repetition
  1063. #
  1064. # Results:
  1065. #    state is modified: end element of state is appended.
  1066.  
  1067. proc sgml::CModelSTcpAdd {state cp rep} {
  1068.     upvar #0 $state var
  1069.  
  1070.     if {[llength $var(stack)]} {
  1071.     set top [lindex $var(stack) end]
  1072.         lappend top [list $rep $cp]
  1073.     set var(stack) [lreplace $var(stack) end end $top]
  1074.     } else {
  1075.     set var(stack) [list $rep $cp]
  1076.     }
  1077. }
  1078.  
  1079. # sgml::CModelSTopenParen --
  1080. #
  1081. #    Processes a '(' in a content model spec.
  1082. #
  1083. # Arguments:
  1084. #    state    state array
  1085. #
  1086. # Results:
  1087. #    Pushes stack in state array.
  1088.  
  1089. proc sgml::CModelSTopenParen {state args} {
  1090.     upvar #0 $state var
  1091.  
  1092.     if {[llength $args]} {
  1093.     return -code error "syntax error in specification: \"$args\""
  1094.     }
  1095.  
  1096.     lappend var(state) start
  1097.     lappend var(stack) [list {} {}]
  1098. }
  1099.  
  1100. # sgml::CModelSTcloseParen --
  1101. #
  1102. #    Processes a ')' in a content model spec.
  1103. #
  1104. # Arguments:
  1105. #    state    state array
  1106. #    rep    repetition
  1107. #    cs    choice or sequence delimiter
  1108. #
  1109. # Results:
  1110. #    Stack is popped, and former top of stack is appended to previous element.
  1111.  
  1112. proc sgml::CModelSTcloseParen {state rep cs args} {
  1113.     upvar #0 $state var
  1114.  
  1115.     if {[llength $args]} {
  1116.     return -code error "syntax error in specification: \"$args\""
  1117.     }
  1118.  
  1119.     set cp [lindex $var(stack) end]
  1120.     set var(stack) [lreplace $var(stack) end end]
  1121.     set var(state) [lreplace $var(state) end end]
  1122.     CModelSTcp $state $cp $rep $cs
  1123. }
  1124.  
  1125. # sgml::CModelMakeTransitionTable --
  1126. #
  1127. #    Given a content model's syntax tree, constructs
  1128. #    the transition table for the regular expression.
  1129. #
  1130. #    See "Compilers, Principles, Techniques, and Tools",
  1131. #    Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
  1132. #
  1133. # Arguments:
  1134. #    state    state array variable
  1135. #    st    syntax tree
  1136. #
  1137. # Results:
  1138. #    The transition table is returned, as a key/value Tcl list.
  1139.  
  1140. proc sgml::CModelMakeTransitionTable {state st} {
  1141.     upvar #0 $state var
  1142.  
  1143.     # Construct nullable, firstpos and lastpos functions
  1144.     array set var {number 0}
  1145.     foreach {nullable firstpos lastpos} [    \
  1146.     TraverseDepth1st $state $st {
  1147.         # Evaluated for leaf nodes
  1148.         # Compute nullable(n)
  1149.         # Compute firstpos(n)
  1150.         # Compute lastpos(n)
  1151.         set nullable [nullable leaf $rep $name]
  1152.         set firstpos [list {} $var(number)]
  1153.         set lastpos [list {} $var(number)]
  1154.         set var(pos:$var(number)) $name
  1155.     } {
  1156.         # Evaluated for nonterminal nodes
  1157.         # Compute nullable, firstpos, lastpos
  1158.         set firstpos [firstpos $cs $firstpos $nullable]
  1159.         set lastpos  [lastpos  $cs $lastpos  $nullable]
  1160.         set nullable [nullable nonterm $rep $cs $nullable]
  1161.     }    \
  1162.     ] break
  1163.  
  1164.     set accepting [incr var(number)]
  1165.     set var(pos:$accepting) #
  1166.  
  1167.     # var(pos:N) maps from position to symbol.
  1168.     # Construct reverse map for convenience.
  1169.     # NB. A symbol may appear in more than one position.
  1170.     # var is about to be reset, so use different arrays.
  1171.  
  1172.     foreach {pos symbol} [array get var pos:*] {
  1173.     set pos [lindex [split $pos :] 1]
  1174.     set pos2symbol($pos) $symbol
  1175.     lappend sym2pos($symbol) $pos
  1176.     }
  1177.  
  1178.     # Construct the followpos functions
  1179.     catch {unset var}
  1180.     followpos $state $st $firstpos $lastpos
  1181.  
  1182.     # Construct transition table
  1183.     # Dstates is [union $marked $unmarked]
  1184.     set unmarked [list [lindex $firstpos 1]]
  1185.     while {[llength $unmarked]} {
  1186.     set T [lindex $unmarked 0]
  1187.     lappend marked $T
  1188.     set unmarked [lrange $unmarked 1 end]
  1189.  
  1190.     # Find which input symbols occur in T
  1191.     set symbols {}
  1192.     foreach pos $T {
  1193.         if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
  1194.         lappend symbols $pos2symbol($pos)
  1195.         }
  1196.     }
  1197.     foreach a $symbols {
  1198.         set U {}
  1199.         foreach pos $sym2pos($a) {
  1200.         if {[lsearch $T $pos] >= 0} {
  1201.             # add followpos($pos)
  1202.                 if {$var($pos) == {}} {
  1203.                     lappend U $accepting
  1204.                 } else {
  1205.                     eval lappend U $var($pos)
  1206.                 }
  1207.         }
  1208.         }
  1209.         set U [makeSet $U]
  1210.         if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
  1211.         lappend unmarked $U
  1212.         }
  1213.         set Dtran($T,$a) $U
  1214.     }
  1215.     
  1216.     }
  1217.  
  1218.     return [list [array get Dtran] [array get sym2pos] $accepting]
  1219. }
  1220.  
  1221. # sgml::followpos --
  1222. #
  1223. #    Compute the followpos function, using the already computed
  1224. #    firstpos and lastpos.
  1225. #
  1226. # Arguments:
  1227. #    state        array variable to store followpos functions
  1228. #    st        syntax tree
  1229. #    firstpos    firstpos functions for the syntax tree
  1230. #    lastpos        lastpos functions
  1231. #
  1232. # Results:
  1233. #    followpos functions for each leaf node, in name/value format
  1234.  
  1235. proc sgml::followpos {state st firstpos lastpos} {
  1236.     upvar #0 $state var
  1237.  
  1238.     switch -- [lindex [lindex $st 1] 0] {
  1239.     :seq {
  1240.         for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
  1241.             followpos $state [lindex [lindex $st 1] $i]            \
  1242.             [lindex [lindex $firstpos 0] [expr $i - 1]]    \
  1243.             [lindex [lindex $lastpos 0] [expr $i - 1]]
  1244.             foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
  1245.             eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
  1246.             set var($pos) [makeSet $var($pos)]
  1247.             }
  1248.         }
  1249.     }
  1250.     :choice {
  1251.         for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
  1252.         followpos $state [lindex [lindex $st 1] $i]            \
  1253.             [lindex [lindex $firstpos 0] [expr $i - 1]]    \
  1254.             [lindex [lindex $lastpos 0] [expr $i - 1]]
  1255.         }
  1256.     }
  1257.     default {
  1258.         # No action at leaf nodes
  1259.     }
  1260.     }
  1261.  
  1262.     switch -- [lindex $st 0] {
  1263.     ? {
  1264.         # We having nothing to do here ! Doing the same as
  1265.         # for * effectively converts this qualifier into the other.
  1266.     }
  1267.     * {
  1268.         foreach pos [lindex $lastpos 1] {
  1269.         eval lappend var($pos) [lindex $firstpos 1]
  1270.         set var($pos) [makeSet $var($pos)]
  1271.         }
  1272.     }
  1273.     }
  1274.  
  1275. }
  1276.  
  1277. # sgml::TraverseDepth1st --
  1278. #
  1279. #    Perform depth-first traversal of a tree.
  1280. #    A new tree is constructed, with each node computed by f.
  1281. #
  1282. # Arguments:
  1283. #    state    state array variable
  1284. #    t    The tree to traverse, a Tcl list
  1285. #    leaf    Evaluated at a leaf node
  1286. #    nonTerm    Evaluated at a nonterminal node
  1287. #
  1288. # Results:
  1289. #    A new tree is returned.
  1290.  
  1291. proc sgml::TraverseDepth1st {state t leaf nonTerm} {
  1292.     upvar #0 $state var
  1293.  
  1294.     set nullable {}
  1295.     set firstpos {}
  1296.     set lastpos {}
  1297.  
  1298.     switch -- [lindex [lindex $t 1] 0] {
  1299.     :seq -
  1300.     :choice {
  1301.         set rep [lindex $t 0]
  1302.         set cs [lindex [lindex $t 1] 0]
  1303.  
  1304.         foreach child [lrange [lindex $t 1] 1 end] {
  1305.         foreach {childNullable childFirstpos childLastpos} \
  1306.             [TraverseDepth1st $state $child $leaf $nonTerm] break
  1307.         lappend nullable $childNullable
  1308.         lappend firstpos $childFirstpos
  1309.         lappend lastpos  $childLastpos
  1310.         }
  1311.  
  1312.         eval $nonTerm
  1313.     }
  1314.     default {
  1315.         incr var(number)
  1316.         set rep [lindex [lindex $t 0] 0]
  1317.         set name [lindex [lindex $t 1] 0]
  1318.         eval $leaf
  1319.     }
  1320.     }
  1321.  
  1322.     return [list $nullable $firstpos $lastpos]
  1323. }
  1324.  
  1325. # sgml::firstpos --
  1326. #
  1327. #    Computes the firstpos function for a nonterminal node.
  1328. #
  1329. # Arguments:
  1330. #    cs        node type, choice or sequence
  1331. #    firstpos    firstpos functions for the subtree
  1332. #    nullable    nullable functions for the subtree
  1333. #
  1334. # Results:
  1335. #    firstpos function for this node is returned.
  1336.  
  1337. proc sgml::firstpos {cs firstpos nullable} {
  1338.     switch -- $cs {
  1339.     :seq {
  1340.         set result [lindex [lindex $firstpos 0] 1]
  1341.         for {set i 0} {$i < [llength $nullable]} {incr i} {
  1342.             if {[lindex [lindex $nullable $i] 1]} {
  1343.                 eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
  1344.         } else {
  1345.             break
  1346.         }
  1347.         }
  1348.     }
  1349.     :choice {
  1350.         foreach child $firstpos {
  1351.         eval lappend result $child
  1352.         }
  1353.     }
  1354.     }
  1355.  
  1356.     return [list $firstpos [makeSet $result]]
  1357. }
  1358.  
  1359. # sgml::lastpos --
  1360. #
  1361. #    Computes the lastpos function for a nonterminal node.
  1362. #    Same as firstpos, only logic is reversed
  1363. #
  1364. # Arguments:
  1365. #    cs        node type, choice or sequence
  1366. #    lastpos        lastpos functions for the subtree
  1367. #    nullable    nullable functions forthe subtree
  1368. #
  1369. # Results:
  1370. #    lastpos function for this node is returned.
  1371.  
  1372. proc sgml::lastpos {cs lastpos nullable} {
  1373.     switch -- $cs {
  1374.     :seq {
  1375.         set result [lindex [lindex $lastpos end] 1]
  1376.         for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
  1377.         if {[lindex [lindex $nullable $i] 1]} {
  1378.             eval lappend result [lindex [lindex $lastpos $i] 1]
  1379.         } else {
  1380.             break
  1381.         }
  1382.         }
  1383.     }
  1384.     :choice {
  1385.         foreach child $lastpos {
  1386.         eval lappend result $child
  1387.         }
  1388.     }
  1389.     }
  1390.  
  1391.     return [list $lastpos [makeSet $result]]
  1392. }
  1393.  
  1394. # sgml::makeSet --
  1395. #
  1396. #    Turn a list into a set, ie. remove duplicates.
  1397. #
  1398. # Arguments:
  1399. #    s    a list
  1400. #
  1401. # Results:
  1402. #    A set is returned, which is a list with duplicates removed.
  1403.  
  1404. proc sgml::makeSet s {
  1405.     foreach r $s {
  1406.     if {[llength $r]} {
  1407.         set unique($r) {}
  1408.     }
  1409.     }
  1410.     return [array names unique]
  1411. }
  1412.  
  1413. # sgml::nullable --
  1414. #
  1415. #    Compute the nullable function for a node.
  1416. #
  1417. # Arguments:
  1418. #    nodeType    leaf or nonterminal
  1419. #    rep        repetition applying to this node
  1420. #    name        leaf node: symbol for this node, nonterm node: choice or seq node
  1421. #    subtree        nonterm node: nullable functions for the subtree
  1422. #
  1423. # Results:
  1424. #    Returns nullable function for this branch of the tree.
  1425.  
  1426. proc sgml::nullable {nodeType rep name {subtree {}}} {
  1427.     switch -glob -- $rep:$nodeType {
  1428.     :leaf -
  1429.     +:leaf {
  1430.         return [list {} 0]
  1431.     }
  1432.     \\*:leaf -
  1433.     \\?:leaf {
  1434.         return [list {} 1]
  1435.     }
  1436.     \\*:nonterm -
  1437.     \\?:nonterm {
  1438.         return [list $subtree 1]
  1439.     }
  1440.     :nonterm -
  1441.     +:nonterm {
  1442.         switch -- $name {
  1443.         :choice {
  1444.             set result 0
  1445.             foreach child $subtree {
  1446.             set result [expr $result || [lindex $child 1]]
  1447.             }
  1448.         }
  1449.         :seq {
  1450.             set result 1
  1451.             foreach child $subtree {
  1452.             set result [expr $result && [lindex $child 1]]
  1453.             }
  1454.         }
  1455.         }
  1456.         return [list $subtree $result]
  1457.     }
  1458.     }
  1459. }
  1460.  
  1461. # These regular expressions are defined here once for better performance
  1462.  
  1463. namespace eval sgml {
  1464.     variable Wsp
  1465.  
  1466.     # Watch out for case-sensitivity
  1467.  
  1468.     set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
  1469.     set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")])")? ;# "
  1470.     set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)
  1471.  
  1472.     set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"
  1473.  
  1474.     set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)
  1475.  
  1476. }
  1477.  
  1478. # sgml::DTD:ATTLIST --
  1479. #
  1480. #    <!ATTLIST ...> defines an attribute list.
  1481. #
  1482. # Arguments:
  1483. #    id    Element an attribute list is being defined for.
  1484. #    value    data from the PI.
  1485. #
  1486. # Results:
  1487. #    Attribute list variables are modified.
  1488.  
  1489. proc sgml::DTD:ATTLIST {id value} {
  1490.     variable attlist_exp
  1491.     variable attlist_enum_exp
  1492.     variable attlist_fixed_exp
  1493.     dbgputs DTD_parse [list DTD:ATTLIST $id $value]
  1494.     upvar opts state
  1495.     upvar attributes am
  1496.  
  1497.     if {[info exists am($id)]} {
  1498.     eval $state(-errorcommand) attlist [list "attribute list for element \"$id\" already declared"]
  1499.     } else {
  1500.     # Parse the attribute list.  If it were regular, could just use foreach,
  1501.     # but some attributes may have values.
  1502.     regsub -all {([][$\\])} $value {\\\1} value
  1503.     regsub -all $attlist_exp $value {[DTDAttribute {\1} {\2} {\3}]} value
  1504.     regsub -all $attlist_enum_exp $value {[DTDAttribute {\1} {\2} {\3}]} value
  1505.     regsub -all $attlist_fixed_exp $value {[DTDAttribute {\1} {\2} {\3} {\4}]} value
  1506.     subst $value
  1507.     set am($id) [array get attlist]
  1508.     }
  1509. }
  1510.  
  1511. # sgml::DTDAttribute --
  1512. #
  1513. #    Parse definition of a single attribute.
  1514. #
  1515. # Arguments:
  1516. #    name    attribute name
  1517. #    type    type of this attribute
  1518. #    default    default value of the attribute
  1519. #    value    other information
  1520.  
  1521. proc sgml::DTDAttribute {name type default {value {}}} {
  1522.     upvar attlist al
  1523.     # This needs further work
  1524.     set al($name) [list $default $value]
  1525. }
  1526.  
  1527. # sgml::DTD:ENTITY --
  1528. #
  1529. #    <!ENTITY ...> PI
  1530. #
  1531. # Arguments:
  1532. #    id    identifier for the entity
  1533. #    value    data
  1534. #
  1535. # Results:
  1536. #    Modifies the caller's entities array variable
  1537.  
  1538. proc sgml::DTD:ENTITY {id value} {
  1539.     variable param_entity_exp
  1540.     dbgputs DTD_parse [list DTD:ENTITY $id $value]
  1541.     upvar opts state
  1542.     upvar entities ents
  1543.  
  1544.     if {[string compare % $id]} {
  1545.     # Entity declaration
  1546.     if {[info exists ents($id)]} {
  1547.         eval $state(-errorcommand) entity [list "entity \"$id\" already declared"]
  1548.     } else {
  1549.         if {![regexp {"([^"]*)"} $value x entvalue] && ![regexp {'([^']*)'} $value x entvalue]} {
  1550.         eval $state(-errorcommand) entityvalue [list "entity value \"$value\" not correctly specified"]
  1551.         } ;# "
  1552.         set ents($id) $entvalue
  1553.     }
  1554.     } else {
  1555.     # Parameter entity declaration
  1556.     switch -glob [regexp $param_entity_exp $value x name scheme data],[string compare {} $scheme] {
  1557.         0,* {
  1558.         eval $state(-errorcommand) entityvalue [list "parameter entity \"$value\" not correctly specified"]
  1559.         }
  1560.         *,0 {
  1561.             # SYSTEM or PUBLIC declaration
  1562.         }
  1563.         default {
  1564.             set ents($id) $data
  1565.         }
  1566.     }
  1567.     }
  1568. }
  1569.  
  1570. # sgml::DTD:NOTATION --
  1571.  
  1572. proc sgml::DTD:NOTATION {id value} {
  1573.     variable notation_exp
  1574.     upvar opts state
  1575.  
  1576.     if {[regexp $notation_exp $value x scheme data] == 2} {
  1577.     } else {
  1578.     eval $state(-errorcommand) notationvalue [list "notation value \"$value\" incorrectly specified"]
  1579.     }
  1580. }
  1581.  
  1582. ### Utility procedures
  1583.  
  1584. # sgml::noop --
  1585. #
  1586. #    A do-nothing proc
  1587. #
  1588. # Arguments:
  1589. #    args    arguments
  1590. #
  1591. # Results:
  1592. #    Nothing.
  1593.  
  1594. proc sgml::noop args {
  1595.     return 0
  1596. }
  1597.  
  1598. # sgml::identity --
  1599. #
  1600. #    Identity function.
  1601. #
  1602. # Arguments:
  1603. #    a    arbitrary argument
  1604. #
  1605. # Results:
  1606. #    $a
  1607.  
  1608. proc sgml::identity a {
  1609.     return $a
  1610. }
  1611.  
  1612. # sgml::Error --
  1613. #
  1614. #    Throw an error
  1615. #
  1616. # Arguments:
  1617. #    args    arguments
  1618. #
  1619. # Results:
  1620. #    Error return condition.
  1621.  
  1622. proc sgml::Error args {
  1623.     uplevel return -code error [list $args]
  1624. }
  1625.  
  1626. ### Following procedures are based on html_library
  1627.  
  1628. # sgml::zapWhite --
  1629. #
  1630. #    Convert multiple white space into a single space.
  1631. #
  1632. # Arguments:
  1633. #    data    plain text
  1634. #
  1635. # Results:
  1636. #    As above
  1637.  
  1638. proc sgml::zapWhite data {
  1639.     regsub -all "\[ \t\r\n\]+" $data { } data
  1640.     return $data
  1641. }
  1642.  
  1643. proc sgml::Boolean value {
  1644.     regsub {1|true|yes|on} $value 1 value
  1645.     regsub {0|false|no|off} $value 0 value
  1646.     return $value
  1647. }
  1648.  
  1649. proc sgml::dbgputs {where text} {
  1650.     variable dbg
  1651.  
  1652.     catch {if {$dbg} {puts stdout "DBG: $where ($text)"}}
  1653. }
  1654.