1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces xml.tokenize xml.state xml.name
4 xml.data accessors arrays make xml.char-classes fry assocs sequences
5 math xml.errors sets combinators io.encodings io.encodings.iana
6 unicode.case xml.dtd strings xml.entities unicode.categories ;
9 : take-interpolated ( quot -- interpolated )
11 drop get-char CHAR: > =
13 [ "->" take-string [ blank? ] trim ]
15 ] [ call ] if ; inline
17 : interpolate-quote ( -- interpolated )
18 [ quoteless-attr ] take-interpolated ;
21 parse-name pass-blank "=" expect pass-blank
23 [ "<-" expect interpolate-quote ]
24 [ t parse-quote* ] if 2array , ;
26 : start-tag ( -- name ? )
27 #! Outputs the name and whether this is a closing tag
28 get-char CHAR: / = dup [ next ] when
32 pass-blank version=1.0? get-char name-start?
33 [ parse-attr (middle-tag) ] when ;
35 : assure-no-duplicates ( attrs-alist -- attrs-alist )
36 H{ } clone 2dup '[ swap _ push-at ] assoc-each
37 [ nip length 2 >= ] assoc-filter >alist
38 [ first first2 duplicate-attr ] unless-empty ;
40 : middle-tag ( -- attrs-alist )
41 ! f make will make a vector if it has any elements
42 [ (middle-tag) ] f make pass-blank
43 assure-no-duplicates ;
45 : end-tag ( name attrs-alist -- tag )
46 tag-ns pass-blank get-char CHAR: / =
47 [ pop-ns <contained> next ">" expect ]
48 [ depth inc <opener> close ] if ;
50 : take-comment ( -- comment )
56 : assure-no-extra ( seq -- )
58 T{ name f "" "version" f }
59 T{ name f "" "encoding" f }
60 T{ name f "" "standalone" f }
62 [ extra-attrs ] unless-empty ;
64 : good-version ( version -- version )
65 dup { "1.0" "1.1" } member? [ bad-version ] unless ;
67 : prolog-version ( alist -- version )
68 T{ name { space "" } { main "version" } } swap at
69 [ good-version ] [ versionless-prolog ] if* ;
71 : prolog-encoding ( alist -- encoding )
72 T{ name { space "" } { main "encoding" } } swap at
75 : yes/no>bool ( string -- t/f )
82 : prolog-standalone ( alist -- version )
83 T{ name { space "" } { main "standalone" } } swap at
84 [ yes/no>bool ] [ f ] if* ;
86 : prolog-attrs ( alist -- prolog )
93 : decode-input-if ( encoding -- )
94 string-input? get [ drop ] [ decode-input ] if ;
96 : parse-prolog ( -- prolog )
97 pass-blank middle-tag "?>" expect
98 dup assure-no-extra prolog-attrs
99 dup encoding>> dup "UTF-16" =
100 [ drop ] [ name>encoding [ decode-input-if ] when* ] if
101 dup prolog-data set ;
103 : instruct ( -- instruction )
105 { [ dup "xml" = ] [ drop parse-prolog ] }
106 { [ dup >lower "xml" = ] [ capitalized-prolog ] }
107 { [ dup valid-name? not ] [ bad-name ] }
108 [ "?>" take-string append <instruction> ]
111 : take-cdata ( -- string )
112 depth get zero? [ bad-cdata ] when
113 "[CDATA[" expect "]]>" take-string ;
115 DEFER: make-tag ! Is this unavoidable?
117 : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
120 pass-blank get-char {
122 { CHAR: % [ expand-pe ] }
124 next make-tag dup dtd-acceptable?
125 [ bad-doctype ] unless , dtd-loop
128 [ 1string bad-doctype ]
131 : take-internal-subset ( -- dtd )
133 H{ } clone pe-table set
137 ] { } make swap extra-entities get swap <dtd> ;
139 : take-optional-id ( -- id/f )
140 get-char "SP" member?
141 [ take-external-id ] [ f ] if ;
143 : take-internal ( -- dtd/f )
145 [ next take-internal-subset ] [ f ] if ;
147 : take-doctype-decl ( -- doctype-decl )
149 pass-blank take-optional-id
150 pass-blank take-internal
151 <doctype-decl> close ;
153 : take-directive ( -- doctype )
154 take-name dup "DOCTYPE" =
155 [ drop take-doctype-decl ] [
157 [ take-inner-directive ]
158 [ misplaced-directive ] if
161 : direct ( -- object )
163 { CHAR: - [ take-comment ] }
164 { CHAR: [ [ take-cdata ] }
165 [ drop take-directive ]
168 : normal-tag ( -- tag )
170 [ dup add-ns pop-ns <closer> depth dec close ]
171 [ middle-tag end-tag ] if ;
173 : interpolate-tag ( -- interpolated )
174 [ "-" bad-name ] take-interpolated ;
176 : make-tag ( -- tag )
178 { [ get-char dup CHAR: ! = ] [ drop next direct ] }
179 { [ dup CHAR: ? = ] [ drop next instruct ] }
180 { [ dup CHAR: - = ] [ drop next interpolate-tag ] }