src/lib/xml.slate

   1 "This is a port of the Smalltalk YAXO XML parser. It was originally written
   2 by Michael Reuger."
   3
   4 prototypes ensureNamespace: #XML.
   5
   6 XML define: #Node &parents: {Cloneable}.
   7
   8 n@(XML Node traits) contentsDo: block
   9 [n].
  10
  11 n@(XML Node traits) elementsDo: block
  12 [n].
  13
  14 n@(XML Node traits) firstTagNamed: name
  15 "Return the first encountered node with the specified tag.
  16 Pass the message on."
  17 [| answer |
  18   n elementsDo: [| :each | (answer := each firstTagNamed: name)
  19     ifNotNil: [^ answer]].
  20   Nil
  21 ].
  22
  23 n@(XML Node traits) firstTagNamed: name with: testBlock
  24 "Return the first encountered node with the specified tag for which the block
  25 returns True. Pass the message on."
  26 [| answer |
  27   n elementsDo: [| :each | (answer := each firstTagNamed: name with: testBlock)
  28     ifNotNil: [^ answer]].
  29   Nil
  30 ].
  31
  32 n@(XML Node traits) tagsNamed: name childrenDo: block
  33 "Evaluate the block on all children that match."
  34 [
  35   n elementsDo: [| :each | each tagsNamed: name ifReceiverDo: block]
  36 ].
  37
  38 n@(XML Node traits) tagsNamed: name childrenDoAndRecurse: block
  39 "Evaluate the block on all children that match and recurse."
  40 [
  41   n elementsDo: [| :each | each tagsNamed: name ifReceiverDoAndRecurse: block]
  42 ].
  43
  44 n@(XML Node traits) tagsNamed: name contentsDo: block
  45 "Evaluate the block on all contents that match."
  46 [
  47   n elementsDo: [| :each | each tagsNamed: name contentsDo: block]
  48 ].
  49
  50 n@(XML Node traits) tagsNamed: name do: block
  51 "Evaluate the block on all tags that match."
  52 [
  53   n elementsDo: [| :each | each tagsNamed: name do: block]
  54 ].
  55
  56 n@(XML Node traits) tagsNamed: name ifReceiverDo: block
  57 "Default handler; only XML TagNode should handle this."
  58 [n].
  59
  60 n@(XML Node traits) tagsNamed: name ifReceiverDoAndRecurse: block
  61 "Recurse all children."
  62 [
  63   n elementsDo: [| :each | each tagsNamed: name ifReceiverDoAndRecurse: block]
  64 ].
  65
  66 n@(XML Node traits) tagsNamed: name ifReceiverOrChildDo: block
  67 "Recurse all children."
  68 [
  69   n elementsDo: [| :each | each tagsNamed: name ifReceiverDo: block]
  70 ].
  71
  72 n@(XML Node traits) printOn: stream
  73 "This is for normal printing compatibility."
  74 [
  75   n printXMLOn: (XML PrintStream newOn: stream)
  76 ].
  77
  78 n@(XML Node traits) printXMLOn: _
  79 "Override this."
  80 [n].
  81
  82 XML define: #NodeWithElements &parents: {XML Node}
  83  &slots: {#elements -> ExtensibleArray new}.
  84
  85 n@(XML NodeWithElements traits) copy
  86 [n clone `setting: #{#elements} to: {n elements copy}].
  87
  88 n@(XML NodeWithElements traits) printXMLOn: writer
  89 [
  90   n elements do: [| :each | each printXMLOn: writer]
  91 ].
  92
  93 XML define: #Document &parents: {XML NodeWithElements} &slots:
  94  {#dtd -> ''.
  95   #version -> ''.
  96   #encoding -> ''.
  97   #requiredMarkup -> ''}.
  98
  99 d@(XML Document traits) printXMLOn: writer
 100 [
 101   n version ifNotNil: [writer xmlDeclaration: n version].
 102   resend
 103 ].
 104
 105 d@(XML Document traits) printCanonicalOn: stream
 106 [| writer |
 107   writer := XML PrintStream on: stream.
 108   writer canonical := True.
 109   d printXMLOn: writer
 110 ].
 111
 112 XML define: #Element &parents: {XML NodeWithElements} &slots:
 113   {#name -> #''.
 114    #contents -> ExtensibleArray new.
 115    #attributes -> ExtensibleArray new}.
 116
 117 e@(XML Element traits) firstTagNamed: name
 118 "Return the first node with the tag, or pass it on."
 119 [
 120   e name == name
 121     ifTrue: [n]
 122     ifFalse: [resend]
 123 ].
 124
 125 e@(XML Element traits) firstTagNamed: name with: testBlock
 126 "Return the first node with the tag and that passes the test, or pass it on."
 127 [
 128   e name == name /\ [testBlock applyWith: e]
 129     ifTrue: [n]
 130     ifFalse: [resend]
 131 ].
 132
 133 e@(XML Element traits) tagsNamed: name contentsDo: block
 134 "Call the block on all contents if the element's tag matches the given name,
 135 then pass it on."
 136 [
 137   e name == name ifTrue: [e contentsDo: block].
 138   resend
 139 ].
 140
 141 e@(XML Element traits) tagsNamed: name do: block
 142 "Call the block on the element if its tag matches the given name,
 143 then pass it on."
 144 [
 145   e name == name ifTrue: [block applyWith: e].
 146   resend
 147 ].
 148
 149 e@(XML Element traits) tagsNamed: name ifReceiverDo: block
 150 "Call the block on the element if the name matches."
 151 [
 152   e name == name ifTrue: [block applyWith: e]
 153 ].
 154
 155 e@(XML Element traits) tagsNamed: name ifReceiverDoAndRecurse: block
 156 "Call the block on the element if the name matches. Then recurse through the
 157 children."
 158 [
 159   e name == name ifTrue: [block applyWith: e].
 160   resend
 161 ].
 162
 163 e@(XML Element traits) tagsNamed: name ifReceiverOrChildDo: block
 164 "Call the block on the element if the name matches, and do the same for the
 165 direct children only."
 166 [
 167   e name == name ifTrue: [block applyWith: e].
 168   resend
 169 ].
 170
 171 e@(XML Element traits) contentsDo: block
 172 [
 173   e contents do: block
 174 ].
 175
 176 e@(XML Element traits) contentsString
 177 [
 178   e contents size == 1 /\ [e contents first is: XML StringNode]
 179     ifTrue: [e contents first string]
 180     ifFalse: ['']
 181 ].
 182
 183 e@(XML Element traits) contentsStringAt: name
 184 [
 185   (e elements at: name ifAbsent: [^ '']) string
 186 ].
 187
 188 e@(XML Element traits) printXMLOn: writer
 189 [
 190   writer startElement: e name attributeList: e attributes.
 191   writer canonical not /\ [e isEmpty] /\ [e attributes isEmpty not]
 192     ifTrue: [writer endEmptyTag: e name]
 193     ifFalse: [
 194       writer endTag.
 195       e contentsDo: [| :content | content printXMLOn: writer].
 196       resend.
 197       writer endTag: e name]
 198 ].
 199
 200 e@(XML Element traits) isEmpty
 201 "Treat the element as the joining of its elements and contents."
 202 [
 203   e elements isEmpty /\ [e contents isEmpty]
 204 ].
 205
 206 XML define: #ProcessingInstruction &parents: {XML Node} &slots:
 207  {#target -> ''. #data -> ''}.
 208
 209 pi@(XML ProcessingInstruction traits) newForTarget: name data: string
 210 [pi clone `setting: #{#target. #data} to: {name. string}].
 211
 212 "printXMLOn: defined after XML PrintStream is defined."
 213
 214 XML define: #StringNode &parents: {XML Node} &slots: {#string -> ''}.
 215
 216 sn@(XML StringNode traits) copy
 217 [sn clone `setting: #{#string} to: {sn string copy}].
 218
 219 sn@(XML StringNode traits) newFor: string
 220 [sn clone `setting: #{#string} to: {string}].
 221
 222 sn@(XML StringNode traits) printXMLOn: writer
 223 [
 224   writer pcData: sn string
 225 ].
 226
 227 (XML Translation ::= Dictionary new &capacity: 30) addAll: {
 228   $\r -> '&#13;'.
 229   $\n -> '&#10;'.
 230   $\t -> '&#9;'.
 231   $& -> '&amp;'.
 232   $< -> '&lt;'.
 233   $> -> '&gt;'.
 234   $\' -> '&apos;'.
 235   $\" -> '&quot;'
 236 }.
 237
 238 XML define: #PrintStream &parents: {Cloneable} &slots: {
 239   #stack -> Stack new.
 240   #stream.
 241   #scanner.
 242   #canonical -> False
 243 }.
 244
 245 w@(XML PrintStream traits) newOn: stream
 246 [w clone `setting: #{#stack. #stream} to: {w stack new. stream}].
 247
 248 w@(XML PrintStream traits) attribute: name value: value
 249 [
 250   w stream ; ' ' ; name printString ; '="'.
 251   w pcData: value.
 252   w stream nextPut: $\".
 253   w
 254 ].
 255
 256 w@(XML PrintStream traits) cdata: string
 257 [
 258   w stream ; '<![CDATA[' ; string ; ']]>'
 259 ].
 260
 261 w@(XML PrintStream traits) pcData: c
 262 [
 263   w stream ; (XML Translation at: c ifAbsent: [c as: String])
 264 ].
 265
 266 w@(XML PrintStream traits) comment: string
 267 [
 268   w stream ; '<!-- ' ; string ; ' -->'
 269 ].
 270
 271 pi@(XML ProcessingInstruction traits) printXMLOn: w@(XML PrintStream traits)
 272 [
 273   w stream ; '<?' ; pi target ; ' ' ; pi data ; '?>'
 274 ].
 275
 276 w@(XML PrintStream traits) pushTag: name
 277 [
 278   w stack push: name
 279 ].
 280
 281 w@(XML PrintStream traits) popTag: name
 282 [| top |
 283   top := w stack isEmpty
 284     ifTrue: ['<empty>']
 285     ifFalse: [w stack last].
 286   top = name
 287     ifTrue: [w stack pop]
 288     ifFalse: [w error: 'Closing tag ' ; name ; ' doesn\'t match ' ; top]
 289 ].
 290
 291 w@(XML PrintStream traits) startTag: name
 292 [
 293   w stream ; '<' ; name.
 294   "w canonical ifTrue: [w stream ; ' ']."
 295   w pushTag: name
 296 ].
 297
 298 w@(XML PrintStream traits) endTag
 299 [
 300   w stream nextPut: $>.
 301   w
 302 ].
 303
 304 w@(XML PrintStream traits) endTag: name
 305 [
 306   w popTag: name.
 307   w stream ; '</' ; name.
 308   w stream nextPut: $>.
 309   w
 310 ].
 311
 312 w@(XML PrintStream traits) endEmptyTag: name
 313 [
 314   w popTag: name.
 315   w stream ; '/>'.
 316   w canonical ifFalse: [w stream nextPut: $\s].
 317   w
 318 ].
 319
 320 w@(XML PrintStream traits) startElement: name attributes: attribs
 321 [
 322   w canonical ifFalse: [w stream nextPut: $\r].
 323   w startTag: name.
 324   (attribs keySet as: SortedArray) do: [| :key |
 325     w attribute: key value: (attribs at: key)].
 326   w
 327 ].
 328
 329 w@(XML PrintStream traits) xmlDeclaration: versionString
 330 [
 331   w canonical ifFalse: [
 332     w stream ; '<?XML '.
 333     w attribute: 'version' value: versionString.
 334     w stream ; '?>'].
 335   w
 336 ].