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-to ( seq -- string )
  62     '[ get-char _ member? ] take-until ;
  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 ( string -- )
  79     dup [ get-char next ] replicate 2dup =
  80     [ 2drop ] [ expected ] if ;
  81
  82 ! Suddenly XML-specific
  83
  84 : parse-named-entity ( string -- )
  85     dup entities at [ , ] [
  86         dup extra-entities get at
  87         [ % ] [ no-entity ] ?if
  88     ] ?if ;
  89
  90 : take-; ( -- string )
  91     next ";" take-to next ;
  92
  93 : parse-entity ( -- )
  94     take-; "#" ?head [
  95         "x" ?head 16 10 ? base> ,
  96     ] [ parse-named-entity ] if ;
  97
  98 : parse-pe ( -- )
  99     take-; dup pe-table get at
 100     [ % ] [ no-entity ] ?if ;
 101
 102 :: (parse-char) ( quot: ( ch -- ? ) -- )
 103     get-char :> char
 104     {
 105         { [ char not ] [ ] }
 106         { [ char quot call ] [ next ] }
 107         { [ char CHAR: & = ] [ parse-entity quot (parse-char) ] }
 108         { [ in-dtd? get char CHAR: % = and ] [ parse-pe quot (parse-char) ] }
 109         [ char , next quot (parse-char) ]
 110     } cond ; inline recursive
 111
 112 : parse-char ( quot: ( ch -- ? ) -- seq )
 113     [ (parse-char) ] "" make ; inline
 114
 115 : assure-no-]]> ( circular -- )
 116     "]]>" sequence= [ text-w/]]> ] when ;
 117
 118 :: parse-text ( -- string )
 119     3 f <array> <circular> :> circ
 120     depth get zero? :> no-text [| char |
 121         char circ push-circular
 122         circ assure-no-]]>
 123         no-text [ char blank? char CHAR: < = or [
 124             char 1string t pre/post-content
 125         ] unless ] when
 126         char CHAR: < =
 127     ] parse-char ;
 128
 129 : close ( -- )
 130     pass-blank ">" expect ;
 131
 132 : normalize-quote ( str -- str )
 133     [ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map ;
 134
 135 : (parse-quote) ( <-disallowed? ch -- string )
 136     swap '[
 137         dup _ = [ drop t ]
 138         [ CHAR: < = _ and [ attr-w/< ] [ f ] if ] if
 139     ] parse-char normalize-quote get-char
 140     [ unclosed-quote ] unless ; inline
 141
 142 : parse-quote* ( <-disallowed? -- seq )
 143     pass-blank get-char dup "'\"" member?
 144     [ next (parse-quote) ] [ quoteless-attr ] if ; inline
 145
 146 : parse-quote ( -- seq )
 147    f parse-quote* ;
 148