! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces xml.tokenize xml.state xml.name
-xml.data accessors arrays make xml.char-classes fry assocs sequences
-math xml.errors sets combinators io.encodings io.encodings.iana
-unicode.case xml.dtd strings xml.entities unicode.categories ;
+USING: arrays assocs combinators kernel make math namespaces
+sequences sets strings unicode xml.char-classes xml.data xml.dtd
+xml.errors xml.name xml.state xml.tokenize ;
IN: xml.elements
: take-interpolated ( quot -- interpolated )
interpolating? get [
- drop get-char CHAR: > =
+ drop get-char CHAR: > eq?
[ next f ]
[ "->" take-string [ blank? ] trim ]
if <interpolated>
: interpolate-quote ( -- interpolated )
[ quoteless-attr ] take-interpolated ;
-: parse-attr ( -- )
- parse-name pass-blank "=" expect pass-blank
- get-char CHAR: < =
- [ "<-" expect interpolate-quote ]
- [ t parse-quote* ] if 2array , ;
-
: start-tag ( -- name ? )
- #! Outputs the name and whether this is a closing tag
- get-char CHAR: / = dup [ next ] when
+ ! Outputs the name and whether this is a closing tag
+ get-char CHAR: / eq? dup [ next ] when
parse-name swap ;
-: (middle-tag) ( -- )
- pass-blank version-1.0? get-char name-start?
- [ parse-attr (middle-tag) ] when ;
-
: assure-no-duplicates ( attrs-alist -- attrs-alist )
H{ } clone 2dup '[ swap _ push-at ] assoc-each
- [ nip length 2 >= ] assoc-filter >alist
+ [ nip length 2 >= ] { } assoc-filter-as
[ first first2 duplicate-attr ] unless-empty ;
+: parse-attr ( -- array )
+ parse-name pass-blank "=" expect pass-blank
+ get-char CHAR: < eq?
+ [ "<-" expect interpolate-quote ]
+ [ t parse-quote* ] if 2array ;
+
: middle-tag ( -- attrs-alist )
- ! f make will make a vector if it has any elements
- [ (middle-tag) ] f make pass-blank
- assure-no-duplicates ;
+ ! f produce-as will make a vector if it has any elements
+ [ pass-blank version-1.0? get-char name-start? ]
+ [ parse-attr ] f produce-as pass-blank
+ dup length 1 > [ assure-no-duplicates ] when ;
: end-tag ( name attrs-alist -- tag )
- tag-ns pass-blank get-char CHAR: / =
+ tag-ns pass-blank get-char CHAR: / eq?
[ pop-ns <contained> next ">" expect ]
[ depth inc <opener> close ] if ;
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
- [ extra-attrs ] unless-empty ;
+ [ extra-attrs ] unless-empty ;
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
- T{ name { space "" } { main "version" } } swap at
+ T{ name { space "" } { main "version" } } of
[ good-version ] [ versionless-prolog ] if*
dup set-version ;
: prolog-encoding ( alist -- encoding )
- T{ name { space "" } { main "encoding" } } swap at
+ T{ name { space "" } { main "encoding" } } of
"UTF-8" or ;
: yes/no>bool ( string -- t/f )
} case ;
: prolog-standalone ( alist -- version )
- T{ name { space "" } { main "standalone" } } swap at
+ T{ name { space "" } { main "standalone" } } of
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
: take-internal-subset ( -- dtd )
[
- H{ } clone pe-table set
- t in-dtd? set
+ H{ } clone pe-table namespaces:set
+ t in-dtd? namespaces:set
dtd-loop
pe-table get
] { } make swap extra-entities get swap <dtd> ;
[ take-external-id ] [ f ] if ;
: take-internal ( -- dtd/f )
- get-char CHAR: [ =
+ get-char CHAR: [ eq?
[ next take-internal-subset ] [ f ] if ;
: take-doctype-decl ( -- doctype-decl )
[ "-" bad-name ] take-interpolated ;
: make-tag ( -- tag )
- {
- { [ get-char dup CHAR: ! = ] [ drop next direct ] }
- { [ dup CHAR: ? = ] [ drop next instruct ] }
- { [ dup CHAR: - = ] [ drop next interpolate-tag ] }
+ get-char {
+ { CHAR: ! [ next direct ] }
+ { CHAR: ? [ next instruct ] }
+ { CHAR: - [ next interpolate-tag ] }
[ drop normal-tag ]
- } cond ;
+ } case ;