REBOL [
title: "XML for REBOL 3"
file: %r3xml.r
name: altxml
author: "Christopher Ross-Gill"
date: 22-Oct-2009
version: 0.2.0
type: 'module
exports: [load-xml decode-xml]
]
word: use [w1 w+][
w1: charset [
"ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
w+: charset [
"-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
[w1 any w+]
]
decode-xml: use [nm hx ns entity char][
nm: charset "0123456789"
hx: charset "0123456789abcdefABCDEF"
ns: make map! ["lt" 60 "gt" 62 "amp" 38 "quot" 34 "apos" 39]
entity: [
"&" [ ; should be #"&"
#"#" [
#"x" copy char 2 4 hx ";" (char: to-integer to-issue char)
| copy char 2 5 nm ";" (char: to-integer char)
]
| copy char word ";" (char: any [ns/:char 63])
] (char: to-char char)
]
func [text [string! none!]][
either text [
if parse/all text [any [remove entity insert char | skip]][text]
][copy ""]
]
]
load-xml: use [
xml! doc make-node
space entity text name attribute element header content
][
xml!: context [
name: space: value: tree: branch: position: none
flatten: use [xml path emit encode de-ns element attribute tag attr text][
path: copy []
emit: func [data][repend xml data]
encode: func [text][
parse/all text: copy text [
some [
change #"<" "<"
| change #"^"" """
| change #"&" "&"
| skip
]
]
head text
]
de-ns: func [name [tag! issue!]][
rejoin [to-string copy/part head name name ":" to-string name]
]
attribute: [
set attr issue! set text [any-string! | number! | logic!] (
attr: either head? attr [to-string attr][de-ns attr]
emit [" " attr {="} encode form text {"}]
)
]
element: [
set tag tag! (
insert path tag: either head? tag [to-string tag][de-ns tag]
emit ["<" either head? tag [tag][]]
) [
none! (emit " />" remove path)
| set text string! (emit [">" encode form text "</" tag ">"] remove path)
| and block! into [
any attribute [
end (emit " />" remove path)
| (emit ">") some element end (emit ["</" take path ">"])
]
]
]
| %.txt set text string! (emit encode form text)
| attribute
]
does [
xml: copy ""
if parse tree element [xml]
]
]
get-by-tag: func [tag /local rule hits hit][
hits: copy []
parse tree rule: [
some [
opt [hit: tag skip (append hits make-node hit) :hit]
skip [and block! into rule | skip]
]
] hits
]
get-by-id: func [id /local rule at hit][
parse tree rule: [
some [
hit: tag! and block! into [thru #id id to end] return (hit: make-node hit)
| skip [and block! into rule | skip]
]
] hit
]
text: has [rule text part][
case/all [
string? value [text: copy value]
block? value [
parse value rule: [
any [
[%.txt | tag!] set part string! (append any [text text: copy ""] part)
| skip and block! into rule | 2 skip
]
]
]
string? text [trim/auto text]
]
]
get: func [name [issue! tag!] /local hit at][
if parse tree [
tag! and block! into [
any [
at: name [block! (hit: make-node at) | set hit skip] to end
| [issue! | tag! | file!] skip
]
]
][hit]
]
sibling: func [/before /after][
case [
all [after find [tag! file!] type?/word position/3] [
make-node skip position 2
]
all [before find [tag! file!] type?/word position/-2] [
make-node skip position -2
]
]
]
parent: has [branch]["Need Branch" none]
children: has [hits hit][
hits: copy []
parse case [
block? value [value] string? value [reduce [%.txt value]] none? value [[]]
][
any [issue! skip]
any [hit: [tag! | file!] skip (append hits make-node hit)]
]
hits
]
attributes: has [hits hit][
hits: copy []
parse either block? value [value][[]] [
any [hit: issue! skip (append hits make-node hit)] to end
]
hits
]
clone: does [make-node tree]
append-child: func [name data /local at][
case [
none? position/2 [value: tree/2: position/2: copy []]
string? position/2 [
new-line value: tree/2: position/2: compose [%.txt (position/2)] true
]
]
either issue? name [
parse position/2 [any [issue! skip] at:]
][at: tail position/2]
insert at reduce [name data]
new-line at true
]
append-text: func [text][
case [
none? position/2 [value: tree/2: position/2: text]
string? position/2 [append position/2 text]
%.txt = pick tail position/2 -2 [append last position/2 text]
block? position/2 [append-child %.txt text]
]
]
append-attr: func [name value][
name: any [remove find name: to-issue name ":" name]
append-child name value
]
]
doc: make xml! [
branch: make block! 10
document: true
new: does [clear branch tree: position: reduce ['document none]]
open-tag: func [tag][
insert/only branch position
tag: any [remove find tag: to-tag tag ":" tag]
tree: position: append-child tag none
]
close-tag: func [tag][
tag: any [remove find tag: to-tag tag ":" tag]
while [tag <> position/1][
probe reform ["No End Tag:" position/1]
if empty? branch [make error! "End tag error!"]
take branch
]
tree: position: take branch
]
]
make-node: func [here /base][
make either base [doc][xml!][
position: here
name: here/1
space: all [any-string? name not head? name copy/part head name name]
value: here/2
tree: reduce [name value]
]
]
space: use [space][
space: charset "^-^/^M "
[some space]
]
name: [word opt [":" word]]
entity: use [nm hx][
nm: charset "0123456789"
hx: charset "0123456789abcdefABCDEF"
[#"&" [word | #"#" [1 5 nm | #"x" 1 4 hx]] ";" | #"&"]
]
text: use [mk char value][
; intersect charset ["^-^/^M" #" " - #"^(FF)"] complement charset [#"^(00)" - #"^(20)" "&<"]
char: charset ["^-^/^M" #"^(20)" - #"^(25)" #"^(27)" - #"^(3B)" #"^(3D)" - #"^(FFFF)"] ; "
[ copy value [
opt space [char | entity]
any [char | entity | space]
] (doc/append-text decode-xml value)
]
]
attribute: use [attr value][
[ opt space copy attr name opt space "=" opt space [
{"} copy value to {"}
| {'} copy value to {'}
] skip (doc/append-attr attr decode-xml value)
]
]
element: use [tag value][
[ #"<" [
copy tag name (doc/open-tag tag) any attribute opt space [
"/>" (doc/close-tag tag)
| #">" content "</" copy tag name (doc/close-tag tag) opt space #">"
]
| #"!" [
"--" copy value to "-->" 3 skip ; (doc/append-child %.cmt value)
| "[CDATA[" copy value to "]]>" 3 skip (doc/append-text value) ; (doc/append-child %.bin value)
]
]
]
]
header: [
any [
space
| "<" ["?xml" thru "?>" | "!" ["--" thru "-->" | thru ">"] | "?" thru "?>"]
]
]
content: [any [text | element | space]]
load-xml: func [
"Transform an XML document to a REBOL block"
document [any-string!] "An XML string/location to transform"
/dom "Returns an object with DOM-like methods to traverse the XML tree"
/local root
][
case/all [
any [file? document url? document][document: read/string document]
binary? document [document: to-string document]
]
root: doc/new
parse/all/case document [header element to end]
doc/tree: any [root/document []]
doc/value: doc/tree/2
either dom [make-node/base doc/tree][doc/tree]
]
]