1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays io io.encodings.binary io.files
4 io.streams.string kernel namespaces sequences strings io.encodings.utf8
5 xml.data xml.errors xml.elements ascii xml.entities
6 xml.writer xml.state xml.autoencoding assocs xml.tokenize
7 combinators.short-circuit xml.name splitting io.streams.byte-array
13 : add-child ( object -- )
14 xml-stack get peek second push ;
16 : push-xml ( object -- )
17 V{ } clone 2array xml-stack get push ;
19 : pop-xml ( -- object )
22 GENERIC: process ( object -- )
24 M: object process add-child ;
28 { V{ { f V{ "" } } } V{ { f V{ } } } } member?
29 [ bad-prolog ] unless add-child ;
31 : before-main? ( -- ? )
34 [ first second [ tag? ] any? not ]
38 before-main? [ misplaced-directive ] unless add-child ;
41 [ name>> ] [ attrs>> ] bi
42 <contained-tag> add-child ;
44 M: opener process push-xml ;
46 : check-closer ( name opener -- name opener )
47 dup [ unopened ] unless
49 [ name>> swap mismatched ] unless ;
53 [ check-closer attrs>> ] dip
56 : init-xml-stack ( -- )
57 V{ } clone xml-stack set
60 : default-prolog ( -- prolog )
61 "1.0" "UTF-8" f <prolog> ;
65 extra-entities [ H{ } assoc-like ] change ;
67 : assert-blanks ( seq pre? -- )
68 swap [ string? ] filter
71 [ drop ] [ swap pre/post-content ] if
74 : no-pre/post ( pre post -- pre post/* )
75 ! this does *not* affect the contents of the stack
76 [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
78 : no-post-tags ( post -- post/* )
79 ! this does *not* affect the contents of the stack
80 dup [ tag? ] any? [ multitags ] when ;
82 : assure-tags ( seq -- seq )
83 ! this does *not* affect the contents of the stack
86 : ?first ( seq -- elt/f ) 0 swap ?nth ;
88 : get-prolog ( seq -- prolog )
91 [ drop default-prolog ] unless ;
93 : cut-prolog ( seq -- newseq )
94 [ [ prolog? not ] [ "" = not ] bi and ] filter ;
96 : make-xml-doc ( seq -- xml-doc )
100 [ cut-prolog ] [ rest ] bi*
101 no-pre/post no-post-tags
110 TUPLE: pull-xml scope ;
111 : <pull-xml> ( -- pull-xml )
113 input-stream [ ] change ! bring var in this scope
114 init-xml text-now? on
117 ! pull-xml needs to call start-document somewhere
119 : pull-event ( pull -- xml-event/f )
121 text-now? get [ parse-text f ] [
122 get-char [ make-tag t ] [ f f ] if
129 xml-stack get length 1 = ;
131 : (pull-elem) ( pull -- xml-elem/f )
132 dup pull-event dup closer? done? and [ nip ] [
134 [ drop xml-stack get first second ]
140 : pull-elem ( pull -- xml-elem/f )
141 [ init-xml-stack (pull-elem) ] with-scope ;
145 : call-under ( quot object -- quot )
146 swap [ call ] keep ; inline
148 : xml-loop ( quot: ( xml-elem -- ) -- )
149 parse-text call-under
150 get-char [ make-tag call-under xml-loop ]
151 [ drop ] if ; inline recursive
153 : read-seq ( stream quot n -- seq )
156 init-xml init-xml-stack
159 done? [ unclosed ] unless
160 xml-stack get first second
161 ] with-state ; inline
163 : make-xml ( stream quot -- xml )
164 0 read-seq make-xml-doc ; inline
168 : each-element ( stream quot: ( xml-elem -- ) -- )
171 start-document [ call-under ] when*
173 ] with-state ; inline
175 : read-xml ( stream -- xml )
176 dup stream-element-type {
177 { +character+ [ [ check ] make-xml ] }
178 { +byte+ [ [ start-document [ process ] when* ] make-xml ] }
181 : read-xml-chunk ( stream -- seq )
182 [ check ] 1 read-seq <xml-chunk> ;
184 : string>xml ( string -- xml )
185 <string-reader> read-xml ;
187 : string>xml-chunk ( string -- xml )
188 <string-reader> read-xml-chunk ;
190 : file>xml ( filename -- xml )
191 binary <file-reader> read-xml ;
193 : bytes>xml ( byte-array -- xml )
194 binary <byte-reader> read-xml ;
196 : read-dtd ( stream -- dtd )
198 H{ } clone extra-entities set
202 : file>dtd ( filename -- dtd )
203 utf8 <file-reader> read-dtd ;
205 : string>dtd ( string -- dtd )
206 <string-reader> read-dtd ;