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 strings math
5 math.parser sequences assocs arrays splitting combinators unicode.case ;
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 [ , 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 ! f make will make a vector if it has any elements
128 [ (middle-tag) ] f make pass-blank ;
130 : end-tag ( name attrs-alist -- tag )
131 tag-ns pass-blank get-char CHAR: / =
132 [ pop-ns <contained> next ] [ <opener> ] if ;
134 : take-comment ( -- comment )
140 : take-cdata ( -- string )
141 "[CDATA[" expect-string "]]>" take-string ;
143 : take-directive ( -- directive )
144 CHAR: > take-char <directive> next ;
146 : direct ( -- object )
148 { CHAR: - [ take-comment ] }
149 { CHAR: [ [ take-cdata ] }
150 [ drop take-directive ]
153 : yes/no>bool ( string -- t/f )
157 [ <not-yes/no> throw ]
160 : assure-no-extra ( seq -- )
162 T{ name f "" "version" f }
163 T{ name f "" "encoding" f }
164 T{ name f "" "standalone" f }
166 dup empty? [ drop ] [ <extra-attrs> throw ] if ;
168 : good-version ( version -- version )
169 dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
171 : prolog-attrs ( alist -- prolog )
172 [ T{ name f "" "version" f } swap at
173 [ good-version ] [ <versionless-prolog> throw ] if* ] keep
174 [ T{ name f "" "encoding" f } swap at
176 T{ name f "" "standalone" f } swap at
177 [ yes/no>bool ] [ f ] if*
180 : parse-prolog ( -- prolog )
181 pass-blank middle-tag "?>" expect-string
182 dup assure-no-extra prolog-attrs
183 dup prolog-data set ;
185 : instruct ( -- instruction )
186 (parse-name) dup "xml" =
187 [ drop parse-prolog ] [
189 [ <capitalized-prolog> throw ]
190 [ "?>" take-string append <instruction> ] if
193 : make-tag ( -- tag )
195 { [ get-char dup CHAR: ! = ] [ drop next direct ] }
196 { [ CHAR: ? = ] [ next instruct ] }
198 start-tag [ dup add-ns pop-ns <closer> ]
199 [ middle-tag end-tag ] if