Posted to tcl by GPS at Wed Oct 10 18:33:01 GMT 2007view raw

  1. #By George Peter Staplin
  2.  
  3. set yaxmlp_count 0
  4. proc yaxmlp {} {
  5. global yaxmlp_count
  6. while 1 {
  7. incr yaxmlp_count
  8. set token yaxmlp$yaxmlp_count
  9. if {[info commands $token] eq ""} {
  10. break
  11. }
  12. }
  13.  
  14. proc $token args "[list yaxmlp-instance $token] \$args"
  15. return $token
  16. }
  17.  
  18. proc yaxmlp-instance {token arglist} {
  19. global $token
  20. switch -- [lindex $arglist 0] {
  21. handler {
  22. if {3 != [llength $arglist]} {
  23. return -code error "invalid # args: should be: $token handler tag handler-callback"
  24. }
  25. set [set token](handler,[lindex $arglist 1]) [lindex $arglist 2]
  26. }
  27. parse {
  28. yaxmlp-parse $token [lindex $arglist 1]
  29. }
  30. }
  31. }
  32.  
  33. proc yaxmlp-dispatch {token tagname props body} {
  34. global $token
  35. set cmd [set [set token](handler,$tagname)]
  36. set cmd [linsert $cmd end $token $tagname $props $body]
  37. uplevel #0 $cmd
  38. }
  39.  
  40. proc yaxmlp-parse-prop-area {token script ivar endvar} {
  41. upvar $ivar i
  42. upvar $endvar end
  43.  
  44. set GATHERPROP 1
  45. set GATHERPROPNAME 2
  46. set GATHERPROPVALUE 3
  47. set GATHERPROPQUOTE 4
  48. set state $GATHERPROP
  49. set props [list]
  50.  
  51. for {} {$i < [string length $script]} {incr i} {
  52. set c [string index $script $i]
  53. #puts "PROPAREA:$c STATE:$state"
  54.  
  55. if {$GATHERPROPVALUE == $state} {
  56. if {"\"" eq $c} {
  57. lappend props $propname $propvalue
  58. set state $GATHERPROP
  59. } else {
  60. append propvalue $c
  61. }
  62. } elseif {$GATHERPROPQUOTE == $state} {
  63. if {[string is space $c]} continue
  64. if {"\"" eq $c} {
  65. set state $GATHERPROPVALUE
  66. }
  67. } elseif {$GATHERPROPNAME == $state} {
  68. if {[string is space $c]} {
  69. continue
  70. } elseif {">" eq $c} {
  71. return $props
  72. } elseif {"=" eq $c} {
  73. set state $GATHERPROPQUOTE
  74. } else {
  75. append propname $c
  76. }
  77. } elseif {$GATHERPROP ==$state} {
  78. if {[string is space $c]} {
  79. set state $GATHERPROPNAME
  80. set propname ""
  81. set propvalue ""
  82. } elseif {"/" eq $c && ">" eq [string index $script [expr {$i + 1}]]} {
  83. set end 1
  84. return $props
  85. } elseif {">" eq $c} {
  86. return $props
  87. }
  88. }
  89. }
  90. return -code error "property area without completing > or />"
  91. }
  92.  
  93. #Return [list tagname props]
  94. proc yaxmlp-parse-tag-area {token script ivar} {
  95. upvar $ivar i
  96. set GATHERTAG 1
  97. set state $GATHERTAG
  98. set tagname ""
  99. set props ""
  100. set end 0
  101.  
  102. for {} {$i < [string length $script]} {incr i} {
  103. set c [string index $script $i]
  104. #puts C:$c
  105. if {$GATHERTAG == $state} {
  106. if {">" eq $c} {
  107. return [list $tagname $props $end]
  108. } elseif {[string is space $c]} {
  109. set props [yaxmlp-parse-prop-area $token $script i end]
  110. return [list $tagname $props $end]
  111. } elseif {"/" eq $c && ">" eq [string index $script [expr {$i + 1}]]} {
  112. set end 1
  113. incr i 2
  114. if {[string length $tagname]} {
  115. return [list $tagname $props $end]
  116. }
  117. } else {
  118. append tagname $c
  119. }
  120. }
  121. }
  122. return -code error "tag without closing: > or />"
  123. }
  124.  
  125. proc yaxmlp-future-match {script i string} {
  126. set subscript [string range $script $i [expr {$i + [string length $string] - 1}]]
  127. return [expr {$subscript eq $string}]
  128. }
  129.  
  130. proc yaxmlp-parse {token script} {
  131. global $token
  132. #puts "PARSE:$token"
  133.  
  134. set GATHERTAG 1
  135. set GATHERBODY 2
  136. set state $GATHERTAG
  137. set tagname ""
  138. set line 1
  139. set scriptlen [string length $script]
  140. for {set i 0} {$i < $scriptlen} {incr i} {
  141. set c [string index $script $i]
  142. #puts PARSEC:$c
  143. if {"\n" eq $c} {
  144. incr line
  145. }
  146.  
  147. if {$GATHERBODY == $state} {
  148. if {"<" eq $c} {
  149. if {[yaxmlp-future-match $script [expr {$i + 1}] /$tagname>]} {
  150. yaxmlp-dispatch $token $tagname $props $body
  151. set tagname ""
  152. set props ""
  153. incr i [string length /$tagname]
  154. set state $GATHERTAG
  155. }
  156. }
  157.  
  158. if {[string is space -strict [string index $body end]] && [string is space $c]} {
  159. continue
  160. } else {
  161. append body $c
  162. }
  163. } elseif {$GATHERTAG == $state} {
  164. if {"<" eq $c} {
  165. incr i
  166. lassign [yaxmlp-parse-tag-area $token $script i] tagname props end
  167. if {$end} {
  168. #The tag was something like <foo bar="something"/>
  169. yaxmlp-dispatch $token $tagname $props ""
  170. set tagname ""
  171. set props ""
  172. set state $GATHERTAG
  173. } else {
  174. set body ""
  175. set state $GATHERBODY
  176. }
  177. }
  178. }
  179. }
  180. }
  181.  
  182.  
  183.  
  184. #----
  185. #Test code
  186. set input {
  187. <meta author="Anne Onymous"/>
  188. <meta>
  189. Composed in haste for purposes of demonstration.
  190. </meta>
  191. <para indent="3">
  192. This is an indented paragraph. Only the first line
  193. is indented, which you can tell if the paragraph goes
  194. on long enough. <![CDATA[<exampletag "Hi!">]]>
  195. <![CDATA[\example\path]]>
  196. </para>
  197. <para>
  198. This is an ordinary paragraph. No line is indented. Not
  199. one. None at all, which you can tell if the paragraph
  200. goes on long enough.
  201. </para>
  202. }
  203.  
  204. proc meta-handler {token tagname props body} {
  205. #puts "$tagname $props $body"
  206. puts "META:$tagname PROPS:$props BODY:$body ENDBODY"
  207. }
  208.  
  209. proc para-handler {token tagname props body} {
  210. array set par $props
  211.  
  212. puts PARA
  213.  
  214. if {[info exists par(indent)]} {
  215. foreach line [split [string trim $body] \n] {
  216. puts [string repeat " " $par(indent)]$line
  217. }
  218. } else {
  219. puts BODY:$body
  220. }
  221. }
  222.  
  223. set h [yaxmlp]
  224. $h handler meta meta-handler
  225. $h handler para para-handler
  226. $h parse $input
  227.