basis/xml/tokenize/tokenize.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml.errors xml.data xml.utilities xml.char-classes sets
   4 xml.entities kernel state-parser kernel namespaces strings math
   5 math.parser sequences assocs arrays splitting combinators unicode.case ;
   6 IN: xml.tokenize
   7
   8 ! XML namespace processing: ns = namespace
   9
  10 ! A stack of hashtables
  11 SYMBOL: ns-stack
  12
  13 : attrs>ns ( attrs-alist -- hash )
  14     ! this should check to make sure URIs are valid
  15     [
  16         [
  17             swap dup name-space "xmlns" =
  18             [ name-tag set ]
  19             [
  20                 T{ name f "" "xmlns" f } names-match?
  21                 [ "" set ] [ drop ] if
  22             ] if
  23         ] assoc-each
  24     ] { } make-assoc f like ;
  25
  26 : add-ns ( name -- )
  27     dup name-space dup ns-stack get assoc-stack
  28     [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
  29
  30 : push-ns ( hash -- )
  31     ns-stack get push ;
  32
  33 : pop-ns ( -- )
  34     ns-stack get pop* ;
  35
  36 : init-ns-stack ( -- )
  37     V{ H{
  38         { "xml" "http://www.w3.org/XML/1998/namespace" }
  39         { "xmlns" "http://www.w3.org/2000/xmlns" }
  40         { "" "" }
  41     } } clone
  42     ns-stack set ;
  43
  44 : tag-ns ( name attrs-alist -- name attrs )
  45     dup attrs>ns push-ns
  46     >r dup add-ns r> dup [ drop add-ns ] assoc-each <attrs> ;
  47
  48 ! Parsing names
  49
  50 : version=1.0? ( -- ? )
  51     prolog-data get prolog-version "1.0" = ;
  52
  53 ! version=1.0? is calculated once and passed around for efficiency
  54
  55 : (parse-name) ( -- str )
  56     version=1.0? dup
  57     get-char name-start? [
  58         [ dup get-char name-char? not ] take-until nip
  59     ] [
  60         "Malformed name" <xml-string-error> throw
  61     ] if ;
  62
  63 : parse-name ( -- name )
  64     (parse-name) get-char CHAR: : =
  65     [ next (parse-name) ] [ "" swap ] if f <name> ;
  66
  67 !   -- Parsing strings
  68
  69 : (parse-entity) ( string -- )
  70     dup entities at [ , ] [
  71         prolog-data get prolog-standalone
  72         [ <no-entity> throw ] [
  73             dup extra-entities get at
  74             [ , ] [ <no-entity> throw ] ?if
  75         ] if
  76     ] ?if ;
  77
  78 : parse-entity ( -- )
  79     next CHAR: ; take-char next
  80     "#" ?head [
  81         "x" ?head 16 10 ? base> ,
  82     ] [ (parse-entity) ] if ;
  83
  84 : (parse-char) ( ch -- )
  85     get-char {
  86         { [ dup not ] [ 2drop ] }
  87         { [ 2dup = ] [ 2drop next ] }
  88         { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
  89         [ , next (parse-char) ]
  90     } cond ;
  91
  92 : parse-char ( ch -- string )
  93     [ (parse-char) ] "" make ;
  94
  95 : parse-quot ( ch -- string )
  96     parse-char get-char
  97     [ "XML file ends in a quote" <xml-string-error> throw ] unless ;
  98
  99 : parse-text ( -- string )
 100     CHAR: < parse-char ;
 101
 102 ! Parsing tags
 103
 104 : start-tag ( -- name ? )
 105     #! Outputs the name and whether this is a closing tag
 106     get-char CHAR: / = dup [ next ] when
 107     parse-name swap ;
 108
 109 : parse-attr-value ( -- seq )
 110     get-char dup "'\"" member? [
 111         next parse-quot
 112     ] [
 113         "Attribute lacks quote" <xml-string-error> throw
 114     ] if ;
 115
 116 : parse-attr ( -- )
 117     [ parse-name ] with-scope
 118     pass-blank CHAR: = expect pass-blank
 119     [ parse-attr-value ] with-scope
 120     2array , ;
 121
 122 : (middle-tag) ( -- )
 123     pass-blank version=1.0? get-char name-start?
 124     [ parse-attr (middle-tag) ] when ;
 125
 126 : middle-tag ( -- attrs-alist )
 127     ! f make will make a vector if it has any elements
 128     [ (middle-tag) ] f make pass-blank ;
 129
 130 : end-tag ( name attrs-alist -- tag )
 131     tag-ns pass-blank get-char CHAR: / =
 132     [ pop-ns <contained> next ] [ <opener> ] if ;
 133
 134 : take-comment ( -- comment )
 135     "--" expect-string
 136     "--" take-string
 137     <comment>
 138     CHAR: > expect ;
 139
 140 : take-cdata ( -- string )
 141     "[CDATA[" expect-string "]]>" take-string ;
 142
 143 : take-directive ( -- directive )
 144     CHAR: > take-char <directive> next ;
 145
 146 : direct ( -- object )
 147     get-char {
 148         { CHAR: - [ take-comment ] }
 149         { CHAR: [ [ take-cdata ] }
 150         [ drop take-directive ]
 151     } case ;
 152
 153 : yes/no>bool ( string -- t/f )
 154     {
 155         { "yes" [ t ] }
 156         { "no" [ f ] }
 157         [ <not-yes/no> throw ]
 158     } case ;
 159
 160 : assure-no-extra ( seq -- )
 161     [ first ] map {
 162         T{ name f "" "version" f }
 163         T{ name f "" "encoding" f }
 164         T{ name f "" "standalone" f }
 165     } diff
 166     dup empty? [ drop ] [ <extra-attrs> throw ] if ;
 167
 168 : good-version ( version -- version )
 169     dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
 170
 171 : prolog-attrs ( alist -- prolog )
 172     [ T{ name f "" "version" f } swap at
 173       [ good-version ] [ <versionless-prolog> throw ] if* ] keep
 174     [ T{ name f "" "encoding" f } swap at
 175       "UTF-8" or ] keep
 176     T{ name f "" "standalone" f } swap at
 177     [ yes/no>bool ] [ f ] if*
 178     <prolog> ;
 179
 180 : parse-prolog ( -- prolog )
 181     pass-blank middle-tag "?>" expect-string
 182     dup assure-no-extra prolog-attrs
 183     dup prolog-data set ;
 184
 185 : instruct ( -- instruction )
 186     (parse-name) dup "xml" =
 187     [ drop parse-prolog ] [
 188         dup >lower "xml" =
 189         [ <capitalized-prolog> throw ]
 190         [ "?>" take-string append <instruction> ] if
 191     ] if ;
 192
 193 : make-tag ( -- tag )
 194     {
 195         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
 196         { [ CHAR: ? = ] [ next instruct ] }
 197         [
 198             start-tag [ dup add-ns pop-ns <closer> ]
 199             [ middle-tag end-tag ] if
 200             CHAR: > expect
 201         ]
 202     } cond ;