requires: {#String. #Stream}.
provides: {#XML}.

"This is a port of the Smalltalk YAXO XML parser. It was originally written
by Michael Reuger."

prototypes addSlot: #XML valued: Namespace clone.

XML addSlot: #Node valued: Cloneable derive.

n@(XML Node traits) contentsDo: block
[n].

n@(XML Node traits) elementsDo: block
[n].

n@(XML Node traits) firstTagNamed: name
"Return the first encountered node with the specified tag.
Pass the message on."
[| answer |
  n elementsDo: [| :each | (answer: (each firstTagNamed: name))
    ifNotNil: [^ answer]].
  Nil
].

n@(XML Node traits) firstTagNamed: name with: testBlock
"Return the first encountered node with the specified tag for which the block
returns True. Pass the message on."
[| answer |
  n elementsDo: [| :each | (answer: (each firstTagNamed: name with: testBlock))
    ifNotNil: [^ answer]].
  Nil
].

n@(XML Node traits) tagsNamed: name childrenDo: block
"Evaluate the block on all children that match."
[
  n elementsDo: [| :each | each tagsNamed: name ifReceiverDo: block]
].

n@(XML Node traits) tagsNamed: name childrenDoAndRecurse: block
"Evaluate the block on all children that match and recurse."
[
  n elementsDo: [| :each | each tagsNamed: name ifReceiverDoAndRecurse: block]
].

n@(XML Node traits) tagsNamed: name contentsDo: block
"Evaluate the block on all contents that match."
[
  n elementsDo: [| :each | each tagsNamed: name contentsDo: block]
].

n@(XML Node traits) tagsNamed: name do: block
"Evaluate the block on all tags that match."
[
  n elementsDo: [| :each | each tagsNamed: name do: block]
].

n@(XML Node traits) tagsNamed: name ifReceiverDo: block
"Default handler; only XML TagNode should handle this."
[n].

n@(XML Node traits) tagsNamed: name ifReceiverDoAndRecurse: block
"Recurse all children."
[
  n elementsDo: [| :each | each tagsNamed: name ifReceiverDoAndRecurse: block]
].

n@(XML Node traits) tagsNamed: name ifReceiverOrChildDo: block
"Recurse all children."
[
  n elementsDo: [| :each | each tagsNamed: name ifReceiverDo: block]
].

n@(XML Node traits) printOn: stream
"This is for normal printing compatibility."
[
  n printXMLOn: (XMLWriter newOn: stream)
].

n@(XML Node traits) printXMLOn: _
"Override this."
[n].

XML addSlot: #NodeWithElements valued: XML Node derive.
XML NodeWithElements addSlot: #elements valued: ExtensibleSequence newEmpty.

n@(XML NodeWithElements traits) copy
[| newN |
  newN: n clone.
  newN elements: n elements copy.
  newN
].

n@(XML NodeWithElements traits) printXMLOn: writer
[
  n elements do: [| :each | each printXMLOn: writer]
].

XML addSlot: #Document valued: XML NodeWithElements derive.
XML Document addSlot: #dtd valued: ''.
XML Document addSlot: #version valued: ''.
XML Document addSlot: #encoding valued: ''.
XML Document addSlot: #requiredMarkup valued: ''.

d@(XML Document traits) printXMLOn: writer
[
  n version ifNotNil: [writer XMLdeclaration: n version].
  resend
].

d@(XML Document traits) printCanonicalOn: stream
[| writer |
  writer: (XML Writer on: stream).
  writer canonical: True.
  d printXMLOn: writer
].

XML addSlot: #Element valued: XML NodeWithElements derive.
XML Element addSlot: #name valued: #''.
XML Element addSlot: #contents valued: ExtensibleSequence newEmpty.
XML Element addSlot: #attributes valued: ExtensibleSequence newEmpty.

e@(XML Element traits) firstTagNamed: name
"Return the first node with the tag, or pass it on."
[
  e name == name
    ifTrue: [n]
    ifFalse: [resend]
].

e@(XML Element traits) firstTagNamed: name with: testBlock
"Return the first node with the tag and that passes the test, or pass it on."
[
  (e name == name and: [testBlock value: e])
    ifTrue: [n]
    ifFalse: [resend]
].

e@(XML Element traits) tagsNamed: name contentsDo: block
"Call the block on all contents if the element's tag matches the given name,
then pass it on."
[
  e name == name ifTrue: [e contentsDo: block].
  resend
].

e@(XML Element traits) tagsNamed: name do: block
"Call the block on the element if its tag matches the given name,
then pass it on."
[
  e name == name ifTrue: [block value: e].
  resend
].

e@(XML Element traits) tagsNamed: name ifReceiverDo: block
"Call the block on the element if the name matches."
[
  e name == name ifTrue: [block value: e]
].

e@(XML Element traits) tagsNamed: name ifReceiverDoAndRecurse: block
"Call the block on the element if the name matches. Then recurse through the
children."
[
  e name == name ifTrue: [block value: e].
  resend
].

e@(XML Element traits) tagsNamed: name ifReceiverOrChildDo: block
"Call the block on the element if the name matches, and do the same for the
direct children only."
[
  e name == name ifTrue: [block value: e].
  resend
].

e@(XML Element traits) contentsDo: block
[
  e contents do: block
].

e@(XML Element traits) contentsString
[
  (e contents size == 1 and: [e contents first is: XML StringNode])
    ifTrue: [e contents first string]
    ifFalse: ['']
].

e@(XML Element traits) contentsStringAt: name
[
  (e elements at: name ifAbsent: [^ '']) string
].

e@(XML Element traits) printXMLOn: writer
[
  writer startElement: e name attributeList: e attributes.
  (writer canonical not and: [e isEmpty and: [e attributes isEmpty not]])
    ifTrue: [writer endEmptyTag: e name]
    ifFalse: [
      writer endTag.
      e contentsDo: [| :content | content printXMLOn: writer].
      resend.
      writer endTag: e name]
].

e@(XML Element traits) isEmpty
"Treat the element as the joining of its elements and contents."
[
  e elements isEmpty and: [e contents isEmpty]
].

XML addSlot: #ProcessingInstruction valued: XML Node derive.
XML ProcessingInstruction addSlot: #target valued: ''.
XML ProcessingInstruction addSlot: #data valued: ''.

pi@(XML ProcessingInstruction traits) newForTarget: name data: string
[| newPI |
  newPI: pi clone.
  newPI target: name.
  newPI data: string.
  newPI
].

"printXMLOn: defined after XML Writer is defined."

XML addSlot: #StringNode valued: XML Node derive.
XML StringNode addSlot: #string valued: ''.

sn@(XML StringNode traits) copy
[| newSN |
  newSN: sn clone.
  newSN string: sn string copy.
  newSN
].

sn@(XML StringNode traits) newFor: string
[| newSN |
  newSN: sn clone.
  newSN string: string.
  newSN
].

sn@(XML StringNode traits) printXMLOn: writer
[
  writer pcData: sn string
].

XML addSlot: #Translation valued: (Dictionary newSize: 30).

XML Translation at: $\r put: '
'.
XML Translation at: $\n put: '
'.
XML Translation at: $\t put: '	'.
XML Translation at: $& put: '&'.
XML Translation at: $< put: '&lt;'.
XML Translation at: $> put: '&gt;'.
XML Translation at: $' put: '&apos;'.
XML Translation at: $" put: '&quot;'.

XML addSlot: #Writer valued: Cloneable derive.
XML Writer addSlot: #stack valued: Stack newEmpty.
XML Writer addSlot: #stream.
XML Writer addSlot: #scanner.
XML Writer addSlot: #canonical valued: False.

w@(XML Writer traits) newOn: stream
[| newW |
  newW: w clone.
  newW stack: w stack newEmpty.
  newW stream: stream.
  newW
].

w@(XML Writer traits) attribute: name value: value
[| s |
  s: w stream.
  s nextPut: $\s.
  s ; name print ; '="'.
  w pcData: value.
  s nextPut: $".
  w
].

w@(XML Writer traits) cdata: string
[| s |
  s: w stream.
  s ; '<![CDATA['.
  s ; string.
  s ; ']]>'.
  w
].

w@(XML Writer traits) pcData: c
[
  w stream ; (XML Translation at: c ifAbsent: [c as: String]).
  w
].

w@(XML Writer traits) comment: string
[| s |
  s: w stream.
  s ; '<-- '.
  s ; string.
  s ; ' -->'.
  w
].

pi@(XML ProcessingInstruction traits) printXMLOn: w@(XML Writer traits)
[| s |
  s: writer stream.
  s ; '<?' ; pi target ; ' '.
  s ; pi data.
  s ; '?>'.
  w
].

w@(XML Writer traits) pushTag: name
[
  w stack push: name
].

w@(XML Writer traits) popTag: name
[| top |
  top: (w stack isEmpty
    ifTrue: ['<empty>']
    ifFalse: [w stack last]).
  top = name
    ifTrue: [w stack pop]
    ifFalse: [w error: 'Closing tag ' ; name ; ' doesnt match ' ; top]
].

w@(XML Writer traits) startTag: name
[| s |
  s: w stream.
  s nextPut: $<.
  s ; name.
  "w canonical ifTrue: [s ; ' ']."
  w pushTag: name
].

w@(XML Writer traits) endTag
[
  w stream nextPut: $>.
  w
].

w@(XML Writer traits) endTag: name
[
  w popTag: name.
  w stream ; '</' ; name.
  w stream nextPut: $>.
  w
].

w@(XML Writer traits) endEmptyTag: name
[
  w popTag: name.
  w stream ; '/>'.
  w canonical ifFalse: [w stream nextPut: $\s].
  w
].

w@(XML Writer traits) startElement: name attributes: attribs
[
  w canonical ifFalse: [w stream nextPut: $\r].
  w startTag: name.
  (attribs keys as: SortedSequence) do: [| :key |
    w attribute: key value: (attribs at: key)].
  w
].

w@(XML Writer traits) xmlDeclaration: versionString
[
  w canonical ifFalse: [
    w stream ; '<?XML '.
    w attribute: 'version' value: versionString.
    w stream ; '?>'].
  w
].