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 ;
7 FROM: namespaces => set ;
10 : take-interpolated ( quot -- interpolated )
12 drop get-char CHAR: > eq?
14 [ "->" take-string [ blank? ] trim ]
16 ] [ call ] if ; inline
18 : interpolate-quote ( -- interpolated )
19 [ quoteless-attr ] take-interpolated ;
21 : start-tag ( -- name ? )
22 #! Outputs the name and whether this is a closing tag
23 get-char CHAR: / eq? dup [ next ] when
26 : assure-no-duplicates ( attrs-alist -- attrs-alist )
27 H{ } clone 2dup '[ swap _ push-at ] assoc-each
28 [ nip length 2 >= ] { } assoc-filter-as
29 [ first first2 duplicate-attr ] unless-empty ;
31 : parse-attr ( -- array )
32 parse-name pass-blank "=" expect pass-blank
34 [ "<-" expect interpolate-quote ]
35 [ t parse-quote* ] if 2array ;
37 : middle-tag ( -- attrs-alist )
38 ! f produce-as will make a vector if it has any elements
39 [ pass-blank version-1.0? get-char name-start? ]
40 [ parse-attr ] f produce-as pass-blank
41 dup length 1 > [ assure-no-duplicates ] when ;
43 : end-tag ( name attrs-alist -- tag )
44 tag-ns pass-blank get-char CHAR: / eq?
45 [ pop-ns <contained> next ">" expect ]
46 [ depth inc <opener> close ] if ;
48 : take-comment ( -- comment )
54 : assure-no-extra ( seq -- )
56 T{ name f "" "version" f }
57 T{ name f "" "encoding" f }
58 T{ name f "" "standalone" f }
60 [ extra-attrs ] unless-empty ;
62 : good-version ( version -- version )
63 dup { "1.0" "1.1" } member? [ bad-version ] unless ;
65 : prolog-version ( alist -- version )
66 T{ name { space "" } { main "version" } } of
67 [ good-version ] [ versionless-prolog ] if*
70 : prolog-encoding ( alist -- encoding )
71 T{ name { space "" } { main "encoding" } } of
74 : yes/no>bool ( string -- t/f )
81 : prolog-standalone ( alist -- version )
82 T{ name { space "" } { main "standalone" } } of
83 [ yes/no>bool ] [ f ] if* ;
85 : prolog-attrs ( alist -- prolog )
91 : parse-prolog ( -- prolog )
92 pass-blank middle-tag "?>" expect
93 dup assure-no-extra prolog-attrs ;
95 : instruct ( -- instruction )
97 { [ dup "xml" = ] [ drop parse-prolog ] }
98 { [ dup >lower "xml" = ] [ capitalized-prolog ] }
99 { [ dup valid-name? not ] [ bad-name ] }
100 [ "?>" take-string append <instruction> ]
103 : take-cdata ( -- string )
104 depth get zero? [ bad-cdata ] when
105 "[CDATA[" expect "]]>" take-string ;
107 DEFER: make-tag ! Is this unavoidable?
109 : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
112 pass-blank get-char {
114 { CHAR: % [ expand-pe ] }
116 next make-tag dup dtd-acceptable?
117 [ bad-doctype ] unless , dtd-loop
120 [ 1string bad-doctype ]
123 : take-internal-subset ( -- dtd )
125 H{ } clone pe-table set
129 ] { } make swap extra-entities get swap <dtd> ;
131 : take-optional-id ( -- id/f )
132 get-char "SP" member?
133 [ take-external-id ] [ f ] if ;
135 : take-internal ( -- dtd/f )
137 [ next take-internal-subset ] [ f ] if ;
139 : take-doctype-decl ( -- doctype-decl )
141 pass-blank take-optional-id
142 pass-blank take-internal
143 <doctype-decl> close ;
145 : take-directive ( -- doctype )
146 take-name dup "DOCTYPE" =
147 [ drop take-doctype-decl ] [
149 [ take-inner-directive ]
150 [ misplaced-directive ] if
153 : direct ( -- object )
155 { CHAR: - [ take-comment ] }
156 { CHAR: [ [ take-cdata ] }
157 [ drop take-directive ]
160 : normal-tag ( -- tag )
162 [ dup add-ns pop-ns <closer> depth dec close ]
163 [ middle-tag end-tag ] if ;
165 : interpolate-tag ( -- interpolated )
166 [ "-" bad-name ] take-interpolated ;
168 : make-tag ( -- tag )
170 { CHAR: ! [ next direct ] }
171 { CHAR: ? [ next instruct ] }
172 { CHAR: - [ next interpolate-tag ] }