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