1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: xml.errors xml.data xml.utilities xml.char-classes sets
4 xml.entities kernel state-parser kernel namespaces make strings
5 math math.parser sequences assocs arrays splitting combinators
6 unicode.case accessors fry ascii ;
9 ! XML namespace processing: ns = namespace
11 ! A stack of hashtables
14 : attrs>ns ( attrs-alist -- hash )
15 ! this should check to make sure URIs are valid
18 swap dup space>> "xmlns" =
21 T{ name f "" "xmlns" f } names-match?
22 [ "" set ] [ drop ] if
25 ] { } make-assoc f like ;
28 dup space>> dup ns-stack get assoc-stack
29 [ nip ] [ nonexist-ns ] if* >>url drop ;
37 : init-ns-stack ( -- )
39 { "xml" "http://www.w3.org/XML/1998/namespace" }
40 { "xmlns" "http://www.w3.org/2000/xmlns" }
45 : tag-ns ( name attrs-alist -- name attrs )
47 [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
51 : version=1.0? ( -- ? )
52 prolog-data get version>> "1.0" = ;
54 ! version=1.0? is calculated once and passed around for efficiency
56 : (parse-name) ( -- str )
58 get-char name-start? [
59 [ dup get-char name-char? not ] take-until nip
61 "Malformed name" xml-string-error
64 : parse-name ( -- name )
65 (parse-name) get-char CHAR: : =
66 [ next (parse-name) ] [ "" swap ] if f <name> ;
70 : (parse-entity) ( string -- )
71 dup entities at [ , ] [
72 prolog-data get standalone>>
74 dup extra-entities get at
75 [ , ] [ no-entity ] ?if
80 next CHAR: ; take-char next
82 "x" ?head 16 10 ? base> ,
83 ] [ (parse-entity) ] if ;
85 : (parse-char) ( ch -- )
87 { [ dup not ] [ 2drop ] }
88 { [ 2dup = ] [ 2drop next ] }
89 { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
90 [ , next (parse-char) ]
93 : parse-char ( ch -- string )
94 [ (parse-char) ] "" make ;
96 : parse-quot ( ch -- string )
98 [ "XML file ends in a quote" xml-string-error ] unless ;
100 : parse-text ( -- string )
105 : start-tag ( -- name ? )
106 #! Outputs the name and whether this is a closing tag
107 get-char CHAR: / = dup [ next ] when
110 : parse-attr-value ( -- seq )
111 get-char dup "'\"" member? [
114 "Attribute lacks quote" xml-string-error
118 [ parse-name ] with-scope
119 pass-blank CHAR: = expect pass-blank
120 [ parse-attr-value ] with-scope
123 : (middle-tag) ( -- )
124 pass-blank version=1.0? get-char name-start?
125 [ parse-attr (middle-tag) ] when ;
127 : middle-tag ( -- attrs-alist )
128 ! f make will make a vector if it has any elements
129 [ (middle-tag) ] f make pass-blank ;
131 : end-tag ( name attrs-alist -- tag )
132 tag-ns pass-blank get-char CHAR: / =
133 [ pop-ns <contained> next ] [ <opener> ] if ;
135 : take-comment ( -- comment )
141 : take-cdata ( -- string )
142 "[CDATA[" expect-string "]]>" take-string ;
144 : take-element-decl ( -- element-decl )
145 pass-blank " " take-string pass-blank ">" take-string <element-decl> ;
147 : take-attlist-decl ( -- doctype-decl )
148 pass-blank " " take-string pass-blank ">" take-string <attlist-decl> ;
150 : take-until-one-of ( seps -- str sep )
151 '[ get-char _ member? ] take-until get-char ;
153 : only-blanks ( str -- )
154 [ blank? ] all? [ bad-doctype-decl ] unless ;
156 : take-system-literal ( -- str )
157 pass-blank get-char next {
158 { CHAR: ' [ "'" take-string ] }
159 { CHAR: " [ "\"" take-string ] }
162 : take-system-id ( -- system-id )
163 take-system-literal <system-id>
164 ">" take-string only-blanks ;
166 : take-public-id ( -- public-id )
168 take-system-literal <public-id>
169 ">" take-string only-blanks ;
173 : (take-internal-subset) ( -- )
174 pass-blank get-char {
176 [ drop "<!" expect-string direct , (take-internal-subset) ]
179 : take-internal-subset ( -- seq )
180 [ (take-internal-subset) ] { } make ;
182 : (take-external-id) ( token -- external-id )
184 { "SYSTEM" [ take-system-id ] }
185 { "PUBLIC" [ take-public-id ] }
189 : take-external-id ( -- external-id )
190 " " take-string (take-external-id) ;
192 : take-doctype-decl ( -- doctype-decl )
193 pass-blank " >" take-until-one-of {
195 pass-blank get-char CHAR: [ = [
196 next take-internal-subset f swap
197 ">" take-string only-blanks
199 " >" take-until-one-of {
200 { CHAR: \s [ (take-external-id) ] }
201 { CHAR: > [ only-blanks f ] }
206 } case <doctype-decl> ;
208 : take-entity-def ( -- entity-name entity-def )
209 " " take-string pass-blank get-char {
210 { CHAR: ' [ take-system-literal ] }
211 { CHAR: " [ take-system-literal ] }
212 [ drop take-external-id ]
215 : take-entity-decl ( -- entity-decl )
216 pass-blank get-char {
217 { CHAR: % [ next pass-blank take-entity-def ] }
218 [ drop take-entity-def ]
220 ">" take-string only-blanks <entity-decl> ;
222 : take-directive ( -- directive )
224 { "ELEMENT" [ take-element-decl ] }
225 { "ATTLIST" [ take-attlist-decl ] }
226 { "DOCTYPE" [ take-doctype-decl ] }
227 { "ENTITY" [ take-entity-decl ] }
231 : direct ( -- object )
233 { CHAR: - [ take-comment ] }
234 { CHAR: [ [ take-cdata ] }
235 [ drop take-directive ]
238 : yes/no>bool ( string -- t/f )
245 : assure-no-extra ( seq -- )
247 T{ name f "" "version" f }
248 T{ name f "" "encoding" f }
249 T{ name f "" "standalone" f }
251 [ extra-attrs ] unless-empty ;
253 : good-version ( version -- version )
254 dup { "1.0" "1.1" } member? [ bad-version ] unless ;
256 : prolog-attrs ( alist -- prolog )
257 [ T{ name f "" "version" f } swap at
258 [ good-version ] [ versionless-prolog ] if* ] keep
259 [ T{ name f "" "encoding" f } swap at
261 T{ name f "" "standalone" f } swap at
262 [ yes/no>bool ] [ f ] if*
265 : parse-prolog ( -- prolog )
266 pass-blank middle-tag "?>" expect-string
267 dup assure-no-extra prolog-attrs
268 dup prolog-data set ;
270 : instruct ( -- instruction )
271 (parse-name) dup "xml" =
272 [ drop parse-prolog ] [
274 [ capitalized-prolog ]
275 [ "?>" take-string append <instruction> ] if
278 : make-tag ( -- tag )
280 { [ get-char dup CHAR: ! = ] [ drop next direct ] }
281 { [ CHAR: ? = ] [ next instruct ] }
283 start-tag [ dup add-ns pop-ns <closer> ]
284 [ middle-tag end-tag ] if