Rebol [
    Title: "AltXML"
    File: %altxml.r
    Purpose: "XML Parser and Document API for Rebol"
    Author: "Christopher Ross-Gill"
    Home: http://www.ross-gill.com/page/XML_and_REBOL
    Date: 7-Jul-2014
    Version: 0.4.3
    Type: 'module
    Exports: [decode-xml load-xml]
]

decode-xml: use [nm hx ns mk rf word to-utf-char entity][
    nm: #[bitset! 64#{AAAAAAAA/wMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
    hx: #[bitset! 64#{AAAAAAAA/wN+AAAAfgAAAAAAAAAAAAAAAAAAAAAAAAA=}]
    ns: ["lt" 60 "gt" 62 "amp" 38 "quot" 34 "apos" 39 "nbsp" 160]

    word: use [w1 w+][
        w1: #[bitset! 64#{AAAAAAAAAAD+//+H/v//B/////////////////////8=}]
        w+: #[bitset! 64#{AAAAAABg/wP+//+H/v//B/////////////////////8=}]
        [w1 any w+]
    ]
    
    to-utf-char: use [os fc en][
        os: [0 192 224 240 248 252]
        fc: [1 64 4096 262144 16777216 1073741824]
        en: [127 2047 65535 2097151 67108863 2147483647]

        func [int [integer!] /local char][
            repeat ln 6 [
                if int <= en/:ln [
                    char: reduce [os/:ln + to integer! (int / fc/:ln)]
                    repeat ps ln - 1 [
                        insert next char (to integer! int / fc/:ps) // 64 + 128
                    ]
                    break
                ]
            ]

            to-string to-binary char
        ]
    ]

    entity: [
        mk: #"&" [
              copy rf word ";" (rf: any [select ns rf 63])
            | #"#" [
                  #"x" copy rf 2 4 hx ";" (rf: to-integer to-issue rf)
                | copy rf 2 5 nm ";" (rf: to-integer rf)
            ]
        ] ex: (mk: change/part mk to-utf-char rf ex) :mk
    ]

    func [text [string! none!]][
        either text [
            all [parse/all text [any [to "&" [entity | skip]] to end] text]
        ][copy ""]
    ]
]

load-xml: use [
    xml! doc make-node
    space word entity text name attribute element header content
][
    xml!: context [
        name: space: value: tree: branch: position: none

        flatten: use [xml path emit encode form-name element attribute tag attr text][
            path: copy []
            emit: func [data][repend xml data]

            encode: use [ch tx][
                ch: #[bitset! 64#{/////7v//+////////////////////////////////8=}]
                ; complement charset {<"&}
                tx: [
                    some ch | text: skip (
                        text: change/part text switch text/1 [
                            #"<" ["&lt;"] #"^"" ["&quot;"] #"&" ["&amp;"]
                        ] 1
                    )
                ]
                func [text][parse/all text: copy text [some tx] head text]
            ]

            form-name: func [name [tag! issue!]][
                join "" [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][form-name attr]
                    emit [" " attr {="} encode form text {"}]
                )
            ]

            element: [
                set tag tag! (
                    insert path tag: either head? tag [to-string tag][form-name tag]
                    emit ["<" either head? tag [tag][]]
                ) [
                      none! (emit " />" remove path)
                    | set text string! (emit [">" encode text "</" tag ">"] remove path)
                    | into [
                        any attribute [
                              end (emit " />" remove path)
                            | (emit ">") some element end (emit ["</" take path ">"])
                        ]
                    ]
                ]
                | %.txt set text string! (emit encode text)
                | attribute
            ]

            does [
                xml: copy ""
                if parse tree element [xml]
            ]
        ]

        find-element: func [element [tag! issue!]][
            find value element
        ]

        get-by-tag: func [tag /local rule hit][
            collect [
                parse tree rule: [
                    some [
                        opt [hit: tag skip (keep make-node hit) :hit]
                        skip [into rule | skip]
                    ]
                ]
            ]
        ]

        get-by-id: func [id /local rule hit here][
            parse tree rule: [
                some [
                      here: tag! into [thru #id id to end] (hit: any [hit make-node here])
                    | skip [into rule | skip]
                ]
            ]
            hit
        ]

        text: has [rule text part][
            case/all [
                string? value [text: value]
                block? value [
                    parse value rule: [
                        any [
                            [%.txt | tag!] set part string!
                            (append text: any [text make string! 0] part)
                            | skip into rule
                            | 2 skip
                        ]
                    ]
                ]
                string? text [trim/auto text]
            ]

            text
        ]

        get: func [name [issue! tag!] /node /text /local hit here][
            if all [
                parse tree [
                    tag! into [
                        any [
                              here: name skip (hit: make-node here) to end
                            | [issue! | tag! | file!] skip
                        ]
                    ]
                ]
                object? hit
            ][
                any [
                    case [
                        node [hit]
                        text [trim trim/auto hit/text]
                        string? hit/value [hit/text]
                    ]
                    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 [here][
            collect [
                parse case [
                    block? value [value] string? value [reduce [%.txt value]] none? value [[]]
                ][
                    any [issue! skip]
                    any [here: [tag! | file!] skip (keep make-node here)]
                ]
            ]
        ]

        attributes: has [here][
            collect [
                parse either block? value [value][[]] [
                    any [here: issue! skip (keep make-node here)] to end
                ]
            ]
        ]

        path: func [[catch] path [block! path!]][
            unless parse path [some ['* [tag! | issue!] | tag! | issue! | integer!] opt ['? | 'text]][
                make error! "Invalid Path Spec"
            ]

            use [result selector kids][
                result: :self

                unless parse path [
                    opt [tag! (unless result/name = path/1 [result: none])]

                    some [
                        selector:
                        ['* [tag! | issue!]]
                        (
                            result: collect [
                                foreach kid compose [(any [result []])] [
                                    keep kid/get-by-tag selector/2
                                ]
                            ]
                        )
                        |
                        [tag! | issue!] (
                            remove-each kid result: collect [
                                foreach kid compose [(any [result []])][
                                    keep kid/attributes
                                    keep kid/children
                                ]
                            ][
                                not selector/1 = kid/name
                            ]
                        )
                        |
                        integer! (
                            result: pick compose [(any [result []])] selector/1
                        )
                    ]
                    opt [
                        '? (
                            case [
                                block? result [
                                    result: collect [
                                        foreach kid result [keep kid/value]
                                    ]
                                ]
                                object? result [
                                    result: result/value
                                ]
                            ]
                        )
                        |
                        'text (
                            case [
                                block? result [
                                    result: collect [
                                        foreach kid result [keep kid/text]
                                    ]
                                ]
                                object? result [
                                    result: result/text
                                ]
                            ]
                        )
                    ]
                ][
                    make error! rejoin ["Error at: " mold selector]
                ]

                result
            ]
        ]

        clone: does [make-node tree]

        append-child: func [name data /local here][
            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] here:]
            ][here: tail position/2]

            insert here reduce [name data]
            new-line here 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]
    ]

    word: use [w1 w+][
        w1: #[bitset! 64#{AAAAAAAAAAD+//+H/v//B/////////////////////8=}]
        w+: #[bitset! 64#{AAAAAABg/wP+//+H/v//B/////////////////////8=}]
        [w1 any w+]
    ]

    entity: use [nm hx][
        nm: #[bitset! 64#{AAAAAAAA/wMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=}]
        hx: #[bitset! 64#{AAAAAAAA/wN+AAAAfgAAAAAAAAAAAAAAAAAAAAAAAAA=}]
        [#"&" [word | #"#" [1 5 nm | #"x" 1 4 hx]] ";" | #"&"]
    ]

    text: use [char value][
        ; intersect charset ["^-^/^M" #" " - #"^(FF)"] complement charset [#"^(00)" - #"^(20)" "&<"]
        char: #[bitset! 64#{AAAAAL7//+////////////////////////////////8=}]
        [
            copy value [
                opt space [char | entity]
                any [char | entity | space]
            ] (doc/append-text decode-xml value)
        ]
    ]

    name: [word opt [":" word]]

    attribute: use [q1 q2 attr value][
        ; intersect charset ["^-^/^M" #" " - #"^(FF)"] complement charset {"&<}
        q1: #[bitset! 64#{ACYAALv//+////////////////////////////////8=}]
        ; intersect charset ["^-^/^M" #" " - #"^(FF)"] complement charset {&'<}
        q2: #[bitset! 64#{ACYAAD///+////////////////////////////////8=}]
        [   opt space copy attr name opt space "=" opt space [
                ; lone ampersand is 'loose' not 'strict'
                  {"} copy value any [q1 | entity | "&"] {"}
                | {'} copy value any [q2 | entity | "&"] {'}
            ] (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 /comment value)
                    | "[CDATA[" copy value to "]]>" 3 skip (doc/append-text value)
                ]
            ]
        ]
    ]

    header: [
        opt [#{efbbbf}] any [
              space 
            | "<" ["?xml" thru "?>" | "!" ["--" thru "-->" | thru ">"] | "?" thru "?>"]
        ]
    ]

    content: [some [text | element | space] | (doc/append-text make string! 0)]

    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
    ][
        if any [file? document url? document][document: read 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]
    ]
]