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 define: #Translation &builder: [Dictionary new &capacity: 30])
 228  addAll:
 229  {$\r -> '&#13;'.
 230   $\n -> '&#10;'.
 231   $\t -> '&#9;'.
 232   $& -> '&amp;'.
 233   $< -> '&lt;'.
 234   $> -> '&gt;'.
 235   $\' -> '&apos;'.
 236   $\" -> '&quot;'}.
 237
 238 XML define: #PrintStream &parents: {Cloneable}
 239   &slots: {#stack -> Stack new. #stream. #scanner. #canonical -> False}.
 240
 241 w@(XML PrintStream traits) newOn: stream
 242 [w clone `setting: #{#stack. #stream} to: {w stack new. stream}].
 243
 244 w@(XML PrintStream traits) attribute: name value: value
 245 [
 246   w stream ; ' ' ; name printString ; '="'.
 247   w pcData: value.
 248   w stream nextPut: $\".
 249   w
 250 ].
 251
 252 w@(XML PrintStream traits) cdata: string
 253 [
 254   w stream ; '<![CDATA[' ; string ; ']]>'
 255 ].
 256
 257 w@(XML PrintStream traits) pcData: c
 258 [
 259   w stream ; (XML Translation at: c ifAbsent: [c as: String])
 260 ].
 261
 262 w@(XML PrintStream traits) comment: string
 263 [
 264   w stream ; '<!-- ' ; string ; ' -->'
 265 ].
 266
 267 pi@(XML ProcessingInstruction traits) printXMLOn: w@(XML PrintStream traits)
 268 [
 269   w stream ; '<?' ; pi target ; ' ' ; pi data ; '?>'
 270 ].
 271
 272 w@(XML PrintStream traits) pushTag: name
 273 [
 274   w stack push: name
 275 ].
 276
 277 w@(XML PrintStream traits) popTag: name
 278 [| top |
 279   top := w stack isEmpty
 280     ifTrue: ['<empty>']
 281     ifFalse: [w stack last].
 282   top = name
 283     ifTrue: [w stack pop]
 284     ifFalse: [w error: 'Closing tag ' ; name ; ' doesn\'t match ' ; top]
 285 ].
 286
 287 w@(XML PrintStream traits) startTag: name
 288 [
 289   w stream ; '<' ; name.
 290   "w canonical ifTrue: [w stream ; ' ']."
 291   w pushTag: name
 292 ].
 293
 294 w@(XML PrintStream traits) endTag
 295 [
 296   w stream nextPut: $>.
 297   w
 298 ].
 299
 300 w@(XML PrintStream traits) endTag: name
 301 [
 302   w popTag: name.
 303   w stream ; '</' ; name.
 304   w stream nextPut: $>.
 305   w
 306 ].
 307
 308 w@(XML PrintStream traits) endEmptyTag: name
 309 [
 310   w popTag: name.
 311   w stream ; '/>'.
 312   w canonical ifFalse: [w stream nextPut: $\s].
 313   w
 314 ].
 315
 316 w@(XML PrintStream traits) startElement: name attributes: attribs
 317 [
 318   w canonical ifFalse: [w stream nextPut: $\r].
 319   w startTag: name.
 320   (attribs keySet as: SortedArray) do: [| :key |
 321     w attribute: key value: (attribs at: key)].
 322   w
 323 ].
 324
 325 w@(XML PrintStream traits) xmlDeclaration: versionString
 326 [
 327   w canonical ifFalse: [
 328     w stream ; '<?XML '.
 329     w attribute: 'version' value: versionString.
 330     w stream ; '?>'].
 331   w
 332 ].