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
4 xml.entities kernel state-parser kernel namespaces strings math
5 math.parser sequences assocs arrays splitting combinators ;
8 ! XML namespace processing: ns = namespace
10 ! A stack of hashtables
13 : attrs>ns ( attrs-alist -- hash )
14 ! this should check to make sure URIs are valid
17 swap dup name-space "xmlns" =
20 T{ name f "" "xmlns" f } names-match?
21 [ "" set ] [ drop ] if
24 ] { } make-assoc f like ;
27 dup name-space dup ns-stack get assoc-stack
28 [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
36 : init-ns-stack ( -- )
38 { "xml" "http://www.w3.org/XML/1998/namespace" }
39 { "xmlns" "http://www.w3.org/2000/xmlns" }
44 : tag-ns ( name attrs-alist -- name attrs )
46 >r dup add-ns r> dup [ drop add-ns ] assoc-each <attrs> ;
50 : version=1.0? ( -- ? )
51 prolog-data get prolog-version "1.0" = ;
53 ! version=1.0? is calculated once and passed around for efficiency
55 : (parse-name) ( -- str )
57 get-char name-start? [
58 [ dup get-char name-char? not ] take-until nip
60 "Malformed name" <xml-string-error> throw
63 : parse-name ( -- name )
64 (parse-name) get-char CHAR: : =
65 [ next (parse-name) ] [ "" swap ] if f <name> ;
69 : (parse-entity) ( string -- )
70 dup entities at [ , ] [
71 prolog-data get prolog-standalone
72 [ <no-entity> throw ] [
73 dup extra-entities get at
74 [ , ] [ <no-entity> throw ] ?if
79 next CHAR: ; take-char next
81 "x" ?head 16 10 ? base> ,
82 ] [ (parse-entity) ] if ;
84 : (parse-char) ( ch -- )
86 { [ dup not ] [ 2drop ] }
87 { [ 2dup = ] [ 2drop next ] }
88 { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
89 { [ t ] [ , next (parse-char) ] }
92 : parse-char ( ch -- string )
93 [ (parse-char) ] "" make ;
95 : parse-quot ( ch -- string )
97 [ "XML file ends in a quote" <xml-string-error> throw ] unless ;
99 : parse-text ( -- string )
104 : start-tag ( -- name ? )
105 #! Outputs the name and whether this is a closing tag
106 get-char CHAR: / = dup [ next ] when
109 : parse-attr-value ( -- seq )
110 get-char dup "'\"" member? [
113 "Attribute lacks quote" <xml-string-error> throw
117 [ parse-name ] with-scope
118 pass-blank CHAR: = expect pass-blank
119 [ parse-attr-value ] with-scope
122 : (middle-tag) ( -- )
123 pass-blank version=1.0? get-char name-start?
124 [ parse-attr (middle-tag) ] when ;
126 : middle-tag ( -- attrs-alist )
127 [ (middle-tag) ] V{ } make pass-blank ;
129 : end-tag ( name attrs-alist -- tag )
130 tag-ns pass-blank get-char CHAR: / =
131 [ pop-ns <contained> next ] [ <opener> ] if ;
133 : take-comment ( -- comment )
139 : take-cdata ( -- string )
140 "[CDATA[" expect-string "]]>" take-string next ;
142 : take-directive ( -- directive )
143 CHAR: > take-char <directive> next ;
145 : direct ( -- object )
147 { CHAR: - [ take-comment ] }
148 { CHAR: [ [ take-cdata ] }
149 [ drop take-directive ]
152 : yes/no>bool ( string -- t/f )
156 [ <not-yes/no> throw ]
159 : assure-no-extra ( seq -- )
161 T{ name f "" "version" f }
162 T{ name f "" "encoding" f }
163 T{ name f "" "standalone" f }
165 dup empty? [ drop ] [ <extra-attrs> throw ] if ;
167 : good-version ( version -- version )
168 dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
170 : prolog-attrs ( alist -- prolog )
171 [ T{ name f "" "version" f } swap at
172 [ good-version ] [ <versionless-prolog> throw ] if* ] keep
173 [ T{ name f "" "encoding" f } swap at
174 "iso-8859-1" or ] keep
175 T{ name f "" "standalone" f } swap at
176 [ yes/no>bool ] [ f ] if*
179 : parse-prolog ( -- prolog )
180 pass-blank middle-tag "?>" expect-string
181 dup assure-no-extra prolog-attrs
182 dup prolog-data set ;
184 : instruct ( -- instruction )
185 (parse-name) dup "xml" =
186 [ drop parse-prolog ] [
188 [ <capitalized-prolog> throw ]
189 [ "?>" take-string append <instruction> ] if
192 : make-tag ( -- tag )
194 { [ get-char dup CHAR: ! = ] [ drop next direct ] }
195 { [ CHAR: ? = ] [ next instruct ] }
197 start-tag [ dup add-ns pop-ns <closer> ]
198 [ middle-tag end-tag ] if