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