basis/xml/tokenize/tokenize.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces xml.state kernel sequences accessors
   4 xml.char-classes xml.errors math io sbufs fry strings ascii
   5 circular xml.entities assocs make splitting math.parser
   6 locals combinators arrays ;
   7 IN: xml.tokenize
   8
   9 : version=1.0? ( -- ? )
  10     prolog-data get [ version>> "1.0" = ] [ t ] if* ;
  11
  12 : assure-good-char ( ch -- ch )
  13     [
  14         version=1.0? over text? not get-check and
  15         [ disallowed-char ] when
  16     ] [ f ] if* ;
  17
  18 ! * Basic utility words
  19
  20 : record ( char -- )
  21     CHAR: \n =
  22     [ 0 get-line 1+ set-line ] [ get-column 1+ ] if
  23     set-column ;
  24
  25 ! (next) normalizes \r\n and \r
  26 : (next) ( -- char )
  27     get-next read1
  28     2dup swap CHAR: \r = [
  29         CHAR: \n =
  30         [ nip read1 ] [ nip CHAR: \n swap ] if
  31     ] [ drop ] if
  32     set-next dup set-char assure-good-char ;
  33
  34 : next ( -- )
  35     #! Increment spot.
  36     get-char [ unexpected-end ] unless (next) record ;
  37
  38 : init-parser ( -- )
  39     0 1 0 f f <spot> spot set
  40     read1 set-next next ;
  41
  42 : with-state ( stream quot -- )
  43     ! with-input-stream implicitly creates a new scope which we use
  44     swap [ init-parser call ] with-input-stream ; inline
  45
  46 : skip-until ( quot: ( -- ? ) -- )
  47     get-char [
  48         [ call ] keep swap [ drop ] [
  49             next skip-until
  50         ] if
  51     ] [ drop ] if ; inline recursive
  52
  53 : take-until ( quot -- string )
  54     #! Take the substring of a string starting at spot
  55     #! from code until the quotation given is true and
  56     #! advance spot to after the substring.
  57     10 <sbuf> [
  58         '[ @ [ t ] [ get-char _ push f ] if ] skip-until
  59     ] keep >string ; inline
  60
  61 : take-char ( ch -- string )
  62     [ dup get-char = ] take-until nip ;
  63
  64 : pass-blank ( -- )
  65     #! Advance code past any whitespace, including newlines
  66     [ get-char blank? not ] skip-until ;
  67
  68 : string-matches? ( string circular -- ? )
  69     get-char over push-circular
  70     sequence= ;
  71
  72 : take-string ( match -- string )
  73     dup length <circular-string>
  74     [ 2dup string-matches? ] take-until nip
  75     dup length rot length 1- - head
  76     get-char [ missing-close ] unless next ;
  77
  78 : expect ( ch -- )
  79     get-char 2dup = [ 2drop ] [
  80         [ 1string ] bi@ expected
  81     ] if next ;
  82
  83 : expect-string ( string -- )
  84     dup [ get-char next ] replicate 2dup =
  85     [ 2drop ] [ expected ] if ;
  86
  87 : parse-named-entity ( string -- )
  88     dup entities at [ , ] [
  89         dup extra-entities get at
  90         [ % ] [ no-entity ] ?if
  91     ] ?if ;
  92
  93 : parse-entity ( -- )
  94     next CHAR: ; take-char next
  95     "#" ?head [
  96         "x" ?head 16 10 ? base> ,
  97     ] [ parse-named-entity ] if ;
  98
  99 SYMBOL: pe-table
 100 SYMBOL: in-dtd?
 101
 102 : parse-pe ( -- )
 103     next CHAR: ; take-char dup next
 104     pe-table get at [ % ] [ no-entity ] ?if ;
 105
 106 :: (parse-char) ( quot: ( ch -- ? ) -- )
 107     get-char :> char
 108     {
 109         { [ char not ] [ ] }
 110         { [ char quot call ] [ next ] }
 111         { [ char CHAR: & = ] [ parse-entity quot (parse-char) ] }
 112         { [ in-dtd? get char CHAR: % = and ] [ parse-pe quot (parse-char) ] }
 113         [ char , next quot (parse-char) ]
 114     } cond ; inline recursive
 115
 116 : parse-char ( quot: ( ch -- ? ) -- seq )
 117     [ (parse-char) ] "" make ; inline
 118
 119 : assure-no-]]> ( circular -- )
 120     "]]>" sequence= [ text-w/]]> ] when ;
 121
 122 :: parse-text ( -- string )
 123     3 f <array> <circular> :> circ
 124     depth get zero? :> no-text [| char |
 125         char circ push-circular
 126         circ assure-no-]]>
 127         no-text [ char blank? char CHAR: < = or [
 128             char 1string t pre/post-content
 129         ] unless ] when
 130         char CHAR: < =
 131     ] parse-char ;
 132
 133 : close ( -- )
 134     pass-blank CHAR: > expect ;
 135
 136 : normalize-quote ( str -- str )
 137     [ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map ;
 138
 139 : (parse-quote) ( <-disallowed? ch -- string )
 140     swap '[
 141         dup _ = [ drop t ]
 142         [ CHAR: < = _ and [ attr-w/< ] [ f ] if ] if
 143     ] parse-char normalize-quote get-char
 144     [ unclosed-quote ] unless ; inline
 145
 146 : parse-quote* ( <-disallowed? -- seq )
 147     pass-blank get-char dup "'\"" member?
 148     [ next (parse-quote) ] [ quoteless-attr ] if ; inline
 149
 150 : parse-quote ( -- seq )
 151    f parse-quote* ;
 152