rebol [ title: "RebelXML" date: 25-apr-06 file: %rebelxml.r author: "Christophe 'REBOLtof' Coussement" email: "reboltof-at-yahoo-dot-com" purpose: {RebelXML provides a set of functions which allows to easily create/modify/delete XML data} usage: { -- you will be parsed, any resistance if futile! -- Use the following functions: 'clear-xml-data 'get-xml-data 'set-xml-data 'show-xml-data 'set-xml-quote 'load-xml-data More explanations are available into the published documentation at: http://www.rebol.org/cgi-bin/cgiwrap/rebol/documentation.r?script=rebelxml.r } history: [ 1.0.0 [25-apr-05 "History begins" "COU"] ] uses: 'face library: [ level: 'advanced platform: all type: [tool] domain: 'xml tested-under: [View 1.3.2.3.1 on "Windows XP"] support: "Contact the author" license: 'lgpl ] ] if any [ system/version/1 < 1 system/version/2 < 3 ] [ alert "This tool requests at least REBOL/View 1.3 to run." quit ] rebelxml: context [ ;--- container for the XML data string xml-data: copy "" ;--- container for the parsing rules -- debugging purpose parse-rules: none ;--- container for the choosen xml quote - simple by default quote: "'" ;--- clear the data container clear-data: func [ "clears existing data into internal cache" ] [clear xml-data] ;--- returns xml-data content show-data: func [ "returns data from internal cache" ] [xml-data] ;--- load xml data load-data: func [ "load xml data into xml-data word" data [string!] "XML data to load" ] [ xml-data: copy data ] ;--- set user quote preference set-quote: func [ "set user quote preference (default is simple)" user-quote [word!] "May be 'simple or 'double" ] [ quote: switch user-quote [simple ["'"] double [{"}]] ] ;--- data access functions get-data: func [ "extract requested data from xml" path [path! word!] "the path pointing to the data" /content "if content value is requested" /attribute "if attribute value is requested" att-name [word!] "name of the attribute" /with-attribute "qualify a content" w-att-name [word!] "name of the attribute" w-att-data [string!] "value of the attribute" /local rules result txt last-path ] [ ;--- check right use of the rafinements if all [content attribute] [return false] if all [attribute with-attribute] [return false] ;--- convert access path if needed if word? path [path: to-path path] ;--- set access to content as default if not any [content attribute][content: true] ;--- set containers rules: copy/deep [any [] to end] result: none txt: copy "" ;--- get trace of last path element last-path: last path ;--- create initial path while [not empty? form path] [ append rules/any compose/deep [thru (rejoin ["<" (first path)])] path: next path ] if content [ if with-attribute [ append rules/any compose [ thru (rejoin [form w-att-name "='" w-att-data "'"]) | thru (rejoin [form w-att-name {="} w-att-data {"}]) ] ] append rules/any compose/deep [ [thru ">" copy txt to (form to-end-tag last-path) | thru "/>"] ] ] if attribute [ append rules/any compose/deep [ [thru (join form att-name "='") | thru (join form att-name {="})] copy txt [to "' " | to "'>" | to {" } | to {">} | to "'/>" | to {"/>"}] ] ] append rules/any [( if none? result [result: copy []] append result txt if none? result/1 [result: []] )] parse-rules: copy rules ;--- return 'result (all ok) 'false (parsing error) or 'none (path not found) either parse xml-data rules [result][false] ] set-data: func [ "set path, content and/or attribute into xml-data" path [word! path!] "access path" /content "set a content" data [string!] "content data" /attribute "set an attribute" att-name [word!] "attribute name" att-value [string!] "attribute data" /with-attribute "specify a tag with a given attribute" w-att-name [word!] "name of the attribute" w-att-data [string!] "value of the attribute" /local rules mark sub-rule ] [ ;--- refinements compatibility checks if all [content attribute] [return false] if all [attribute with-attribute] [return false] if not any [content attribute] [content: true data: copy ""] ;--- some init rules: copy/deep [[] to end] mark: none ;--- dynamically compose parsing rules foreach tag path [ sub-rule: copy [] append sub-rule reduce [ 'thru to-open-tag tag ;to-paren [?? "in"] ] if all [attribute tag = last path][ append sub-rule [mark:] append sub-rule reduce [ to-paren compose/deep [insert mark (rejoin [" " form att-name "=" quote att-value quote])] ] append sub-rule [:mark] ] if all [with-attribute tag = last path][ append sub-rule reduce [ 'thru rejoin [" " w-att-name "=" quote w-att-data quote] ] ] append sub-rule [to ">"] append sub-rule [mark: :mark | mark:] case [ all [attribute tag = last path] [ append/only sub-rule reduce [ to-paren compose/deep [ until [mark: next mark any [ #"<" = mark/1 empty? mark]] insert mark [( rejoin [form to-open-tag tag " " form att-name "=" quote att-value quote ">" form to-end-tag tag])] mark: next mark ] ] ] all [not attribute not with-attribute] [ append/only sub-rule reduce [ to-paren compose/deep [ until [mark: next mark any [ #"<" = mark/1 empty? mark]] insert mark [( rejoin [form to-tag tag form to-end-tag tag])] mark: next mark ] ] ] ] append sub-rule [:mark] append/only rules/1 sub-rule ] if content [ append/only rules/1 reduce [ 'thru #">" to-set-word 'begin 'to #"<" to-set-word 'ending ] append/only rules/1 to-paren compose/deep [ change/part begin (data) ending ] ] ;--- uncomment following line to see composed rules ;? rules ask "Press to go" ;<<< DEBUG! >>> parse/all xml-data rules xml-data: head xml-data ] ;--- helpers to-end-tag: func [ data [string! word!] ] [ to-tag join "/" data ] to-open-tag: func [ data [string! word!] ] [ head insert form data "<" ] ;--- set public functions accessible from outside context set 'clear-xml-data :clear-data set 'get-xml-data :get-data set 'set-xml-data :set-data set 'show-xml-data :show-data set 'set-xml-quote :set-quote set 'load-xml-data :load-data ]