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 ;
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> throw ] 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 >r dup add-ns r> 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> throw
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>>
73 [ <no-entity> throw ] [
74 dup extra-entities get at
75 [ , ] [ <no-entity> throw ] ?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> throw ] 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> throw
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-directive ( -- directive )
145 CHAR: > take-char <directive> next ;
147 : direct ( -- object )
149 { CHAR: - [ take-comment ] }
150 { CHAR: [ [ take-cdata ] }
151 [ drop take-directive ]
154 : yes/no>bool ( string -- t/f )
158 [ <not-yes/no> throw ]
161 : assure-no-extra ( seq -- )
163 T{ name f "" "version" f }
164 T{ name f "" "encoding" f }
165 T{ name f "" "standalone" f }
167 [ <extra-attrs> throw ] unless-empty ;
169 : good-version ( version -- version )
170 dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
172 : prolog-attrs ( alist -- prolog )
173 [ T{ name f "" "version" f } swap at
174 [ good-version ] [ <versionless-prolog> throw ] if* ] keep
175 [ T{ name f "" "encoding" f } swap at
177 T{ name f "" "standalone" f } swap at
178 [ yes/no>bool ] [ f ] if*
181 : parse-prolog ( -- prolog )
182 pass-blank middle-tag "?>" expect-string
183 dup assure-no-extra prolog-attrs
184 dup prolog-data set ;
186 : instruct ( -- instruction )
187 (parse-name) dup "xml" =
188 [ drop parse-prolog ] [
190 [ <capitalized-prolog> throw ]
191 [ "?>" take-string append <instruction> ] if
194 : make-tag ( -- tag )
196 { [ get-char dup CHAR: ! = ] [ drop next direct ] }
197 { [ CHAR: ? = ] [ next instruct ] }
199 start-tag [ dup add-ns pop-ns <closer> ]
200 [ middle-tag end-tag ] if