-! Copyright (C) 2005, 2006 Daniel Ehrenberg
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.errors xml.data xml.utilities xml.char-classes sets
-xml.entities kernel state-parser kernel namespaces make strings
-math math.parser sequences assocs arrays splitting combinators
-unicode.case accessors ;
+USING: namespaces xml.state kernel sequences accessors
+xml.char-classes xml.errors math io sbufs fry strings ascii
+circular xml.entities assocs splitting math.parser
+locals combinators arrays hints ;
IN: xml.tokenize
-! XML namespace processing: ns = namespace
+! * Basic utility words
-! A stack of hashtables
-SYMBOL: ns-stack
-
-: attrs>ns ( attrs-alist -- hash )
- ! this should check to make sure URIs are valid
+: assure-good-char ( spot ch -- )
[
- [
- swap dup space>> "xmlns" =
- [ main>> set ]
- [
- T{ name f "" "xmlns" f } names-match?
- [ "" set ] [ drop ] if
- ] if
- ] assoc-each
- ] { } make-assoc f like ;
-
-: add-ns ( name -- )
- dup space>> dup ns-stack get assoc-stack
- [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
-
-: push-ns ( hash -- )
- ns-stack get push ;
-
-: pop-ns ( -- )
- ns-stack get pop* ;
-
-: init-ns-stack ( -- )
- V{ H{
- { "xml" "http://www.w3.org/XML/1998/namespace" }
- { "xmlns" "http://www.w3.org/2000/xmlns" }
- { "" "" }
- } } clone
- ns-stack set ;
-
-: tag-ns ( name attrs-alist -- name attrs )
- dup attrs>ns push-ns
- >r dup add-ns r> dup [ drop add-ns ] assoc-each <attrs> ;
-
-! Parsing names
-
-: version=1.0? ( -- ? )
- prolog-data get version>> "1.0" = ;
-
-! version=1.0? is calculated once and passed around for efficiency
-
-: (parse-name) ( -- str )
- version=1.0? dup
- get-char name-start? [
- [ dup get-char name-char? not ] take-until nip
- ] [
- "Malformed name" <xml-string-error> throw
- ] if ;
-
-: parse-name ( -- name )
- (parse-name) get-char CHAR: : =
- [ next (parse-name) ] [ "" swap ] if f <name> ;
-
-! -- Parsing strings
-
-: (parse-entity) ( string -- )
- dup entities at [ , ] [
- prolog-data get standalone>>
- [ <no-entity> throw ] [
- dup extra-entities get at
- [ , ] [ <no-entity> throw ] ?if
- ] if
+ swap
+ [ version-1.0?>> over text? not ]
+ [ check>> ] bi and [
+ spot get [ 1 + ] change-column drop
+ disallowed-char
+ ] [ drop ] if
+ ] [ drop ] if* ;
+
+HINTS: assure-good-char { spot fixnum } ;
+
+: record ( spot char -- spot )
+ over char>> [
+ CHAR: \n =
+ [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if
+ >>column
+ ] [ drop ] if ;
+
+HINTS: record { spot fixnum } ;
+
+:: (next) ( spot -- spot char )
+ spot next>> :> old-next
+ spot stream>> stream-read1 :> new-next
+ old-next CHAR: \r = [
+ spot CHAR: \n >>char
+ new-next CHAR: \n =
+ [ spot stream>> stream-read1 >>next ]
+ [ new-next >>next ] if
+ ] [ spot old-next >>char new-next >>next ] if
+ spot next>> ; inline
+
+: next* ( spot -- )
+ dup char>> [ unexpected-end ] unless
+ (next) [ record ] keep assure-good-char ;
+
+HINTS: next* { spot } ;
+
+: next ( -- )
+ spot get next* ;
+
+: init-parser ( -- )
+ 0 1 0 0 f t f <spot>
+ input-stream get >>stream
+ spot set
+ read1 set-next next ;
+
+: with-state ( stream quot -- )
+ ! with-input-stream implicitly creates a new scope which we use
+ swap [ init-parser call ] with-input-stream ; inline
+
+:: (skip-until) ( quot: ( -- ? ) spot -- )
+ spot char>> [
+ quot call [
+ spot next* quot spot (skip-until)
+ ] unless
+ ] when ; inline recursive
+
+: skip-until ( quot: ( -- ? ) -- )
+ spot get (skip-until) ; inline
+
+: take-until ( quot -- string )
+ #! Take the substring of a string starting at spot
+ #! from code until the quotation given is true and
+ #! advance spot to after the substring.
+ 10 <sbuf> [
+ spot get swap
+ '[ @ [ t ] [ _ char>> _ push f ] if ] skip-until
+ ] keep >string ; inline
+
+: take-to ( seq -- string )
+ spot get swap '[ _ char>> _ member? ] take-until ;
+
+: pass-blank ( -- )
+ #! Advance code past any whitespace, including newlines
+ spot get '[ _ char>> blank? not ] skip-until ;
+
+: string-matches? ( string circular spot -- ? )
+ char>> over push-circular sequence= ;
+
+: take-string ( match -- string )
+ dup length <circular-string>
+ spot get '[ 2dup _ string-matches? ] take-until nip
+ dup length rot length 1 - - head
+ get-char [ missing-close ] unless next ;
+
+: expect ( string -- )
+ dup spot get '[ _ [ char>> ] keep next* ] replicate
+ 2dup = [ 2drop ] [ expected ] if ;
+
+! Suddenly XML-specific
+
+: parse-named-entity ( accum string -- )
+ dup entities at [ swap push ] [
+ dup extra-entities get at
+ [ swap push-all ] [ no-entity ] ?if
] ?if ;
-: parse-entity ( -- )
- next CHAR: ; take-char next
- "#" ?head [
- "x" ?head 16 10 ? base> ,
- ] [ (parse-entity) ] if ;
-
-: (parse-char) ( ch -- )
- get-char {
- { [ dup not ] [ 2drop ] }
- { [ 2dup = ] [ 2drop next ] }
- { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
- [ , next (parse-char) ]
- } cond ;
-
-: parse-char ( ch -- string )
- [ (parse-char) ] "" make ;
-
-: parse-quot ( ch -- string )
- parse-char get-char
- [ "XML file ends in a quote" <xml-string-error> throw ] unless ;
-
-: parse-text ( -- string )
- CHAR: < parse-char ;
-
-! Parsing tags
-
-: start-tag ( -- name ? )
- #! Outputs the name and whether this is a closing tag
- get-char CHAR: / = dup [ next ] when
- parse-name swap ;
-
-: parse-attr-value ( -- seq )
- get-char dup "'\"" member? [
- next parse-quot
- ] [
- "Attribute lacks quote" <xml-string-error> throw
- ] if ;
-
-: parse-attr ( -- )
- [ parse-name ] with-scope
- pass-blank CHAR: = expect pass-blank
- [ parse-attr-value ] with-scope
- 2array , ;
-
-: (middle-tag) ( -- )
- pass-blank version=1.0? get-char name-start?
- [ parse-attr (middle-tag) ] when ;
-
-: middle-tag ( -- attrs-alist )
- ! f make will make a vector if it has any elements
- [ (middle-tag) ] f make pass-blank ;
-
-: end-tag ( name attrs-alist -- tag )
- tag-ns pass-blank get-char CHAR: / =
- [ pop-ns <contained> next ] [ <opener> ] if ;
-
-: take-comment ( -- comment )
- "--" expect-string
- "--" take-string
- <comment>
- CHAR: > expect ;
-
-: take-cdata ( -- string )
- "[CDATA[" expect-string "]]>" take-string ;
-
-: take-directive ( -- directive )
- CHAR: > take-char <directive> next ;
-
-: direct ( -- object )
- get-char {
- { CHAR: - [ take-comment ] }
- { CHAR: [ [ take-cdata ] }
- [ drop take-directive ]
- } case ;
-
-: yes/no>bool ( string -- t/f )
- {
- { "yes" [ t ] }
- { "no" [ f ] }
- [ <not-yes/no> throw ]
- } case ;
-
-: assure-no-extra ( seq -- )
- [ first ] map {
- T{ name f "" "version" f }
- T{ name f "" "encoding" f }
- T{ name f "" "standalone" f }
- } diff
- [ <extra-attrs> throw ] unless-empty ;
-
-: good-version ( version -- version )
- dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
-
-: prolog-attrs ( alist -- prolog )
- [ T{ name f "" "version" f } swap at
- [ good-version ] [ <versionless-prolog> throw ] if* ] keep
- [ T{ name f "" "encoding" f } swap at
- "UTF-8" or ] keep
- T{ name f "" "standalone" f } swap at
- [ yes/no>bool ] [ f ] if*
- <prolog> ;
-
-: parse-prolog ( -- prolog )
- pass-blank middle-tag "?>" expect-string
- dup assure-no-extra prolog-attrs
- dup prolog-data set ;
-
-: instruct ( -- instruction )
- (parse-name) dup "xml" =
- [ drop parse-prolog ] [
- dup >lower "xml" =
- [ <capitalized-prolog> throw ]
- [ "?>" take-string append <instruction> ] if
- ] if ;
-
-: make-tag ( -- tag )
+: take-; ( -- string )
+ next ";" take-to next ;
+
+: parse-entity ( accum -- )
+ take-; "#" ?head [
+ "x" ?head 16 10 ? base> swap push
+ ] [ parse-named-entity ] if ;
+
+: parse-pe ( accum -- )
+ take-; dup pe-table get at
+ [ swap push-all ] [ no-entity ] ?if ;
+
+:: (parse-char) ( quot: ( ch -- ? ) accum spot -- )
+ spot char>> :> char
{
- { [ get-char dup CHAR: ! = ] [ drop next direct ] }
- { [ CHAR: ? = ] [ next instruct ] }
+ { [ char not ] [ ] }
+ { [ char quot call ] [ spot next* ] }
+ { [ char CHAR: & = ] [
+ accum parse-entity
+ quot accum spot (parse-char)
+ ] }
+ { [ in-dtd? get char CHAR: % = and ] [
+ accum parse-pe
+ quot accum spot (parse-char)
+ ] }
[
- start-tag [ dup add-ns pop-ns <closer> ]
- [ middle-tag end-tag ] if
- CHAR: > expect
+ char accum push
+ spot next*
+ quot accum spot (parse-char)
]
- } cond ;
+ } cond ; inline recursive
+
+: parse-char ( quot: ( ch -- ? ) -- seq )
+ 1024 <sbuf> [ spot get (parse-char) ] keep >string ; inline
+
+: assure-no-]]> ( circular -- )
+ "]]>" sequence= [ text-w/]]> ] when ;
+
+:: parse-text ( -- string )
+ 3 f <array> <circular> :> circ
+ depth get zero? :> no-text [| char |
+ char circ push-circular
+ circ assure-no-]]>
+ no-text [ char blank? char CHAR: < = or [
+ char 1string t pre/post-content
+ ] unless ] when
+ char CHAR: < =
+ ] parse-char ;
+
+: close ( -- )
+ pass-blank ">" expect ;
+
+: normalize-quote ( str -- str )
+ [ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map ;
+
+: (parse-quote) ( <-disallowed? ch -- string )
+ swap '[
+ dup _ = [ drop t ]
+ [ CHAR: < = _ and [ attr-w/< ] [ f ] if ] if
+ ] parse-char normalize-quote get-char
+ [ unclosed-quote ] unless ; inline
+
+: parse-quote* ( <-disallowed? -- seq )
+ pass-blank get-char dup "'\"" member?
+ [ next (parse-quote) ] [ quoteless-attr ] if ; inline
+
+: parse-quote ( -- seq )
+ f parse-quote* ;
+
projects / factor.git / blobdiff