basis/xml/tokenize/tokenize.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ascii assocs combinators
   4 combinators.short-circuit fry io.encodings io.encodings.iana
   5 io.encodings.string io.encodings.utf16 io.encodings.utf8 kernel make
   6 math math.parser namespaces sequences sets splitting state-parser
   7 strings xml.char-classes xml.data xml.entities xml.errors hashtables ;
   8 IN: xml.tokenize
   9
  10 ! XML namespace processing: ns = namespace
  11
  12 ! A stack of hashtables
  13 SYMBOL: ns-stack
  14
  15 : attrs>ns ( attrs-alist -- hash )
  16     ! this should check to make sure URIs are valid
  17     [
  18         [
  19             swap dup space>> "xmlns" =
  20             [ main>> set ]
  21             [
  22                 T{ name f "" "xmlns" f } names-match?
  23                 [ "" set ] [ drop ] if
  24             ] if
  25         ] assoc-each
  26     ] { } make-assoc f like ;
  27
  28 : add-ns ( name -- )
  29     dup space>> dup ns-stack get assoc-stack
  30     [ nip ] [ nonexist-ns ] if* >>url drop ;
  31
  32 : push-ns ( hash -- )
  33     ns-stack get push ;
  34
  35 : pop-ns ( -- )
  36     ns-stack get pop* ;
  37
  38 : init-ns-stack ( -- )
  39     V{ H{
  40         { "xml" "http://www.w3.org/XML/1998/namespace" }
  41         { "xmlns" "http://www.w3.org/2000/xmlns" }
  42         { "" "" }
  43     } } clone
  44     ns-stack set ;
  45
  46 : tag-ns ( name attrs-alist -- name attrs )
  47     dup attrs>ns push-ns
  48     [ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
  49
  50 ! Parsing names
  51
  52 : version=1.0? ( -- ? )
  53     prolog-data get version>> "1.0" = ;
  54
  55 ! version=1.0? is calculated once and passed around for efficiency
  56
  57 : assure-name ( str version=1.0? -- str )
  58     over {
  59         [ first name-start? ]
  60         [ rest-slice [ name-char? ] with all? ]
  61     } 2&& [ bad-name ] unless ;
  62
  63 : (parse-name) ( start -- str )
  64     version=1.0?
  65     [ [ get-char name-char? not ] curry take-until append ]
  66     [ assure-name ] bi ;
  67
  68 : parse-name-starting ( start -- name )
  69     (parse-name) get-char CHAR: : =
  70     [ next "" (parse-name) ] [ "" swap ] if f <name> ;
  71
  72 : parse-name ( -- name )
  73     "" parse-name-starting ;
  74
  75 !   -- Parsing strings
  76
  77 : parse-named-entity ( string -- )
  78     dup entities at [ , ] [
  79         dup extra-entities get at
  80         [ dup number? [ , ] [ % ] if ] [ no-entity ] ?if ! Make less hackish
  81     ] ?if ;
  82
  83 : parse-entity ( -- )
  84     next CHAR: ; take-char next
  85     "#" ?head [
  86         "x" ?head 16 10 ? base> ,
  87     ] [ parse-named-entity ] if ;
  88
  89 : (parse-char) ( ch -- )
  90     get-char {
  91         { [ dup not ] [ 2drop ] }
  92         { [ 2dup = ] [ 2drop next ] }
  93         { [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
  94         [ , next (parse-char) ]
  95     } cond ;
  96
  97 : parse-char ( ch -- string )
  98     [ (parse-char) ] "" make ;
  99
 100 : parse-text ( -- string )
 101     CHAR: < parse-char ;
 102
 103 ! Parsing tags
 104
 105 : start-tag ( -- name ? )
 106     #! Outputs the name and whether this is a closing tag
 107     get-char CHAR: / = dup [ next ] when
 108     parse-name swap ;
 109
 110 : (parse-quote) ( ch -- string )
 111     parse-char get-char
 112     [ unclosed-quote ] unless ;
 113
 114 : parse-quote ( -- seq )
 115     pass-blank get-char dup "'\"" member?
 116     [ next (parse-quote) ] [ quoteless-attr ] if ;
 117
 118 : parse-attr ( -- )
 119     parse-name
 120     pass-blank CHAR: = expect
 121     parse-quote
 122     2array , ;
 123
 124 : (middle-tag) ( -- )
 125     pass-blank version=1.0? get-char name-start?
 126     [ parse-attr (middle-tag) ] when ;
 127
 128 : middle-tag ( -- attrs-alist )
 129     ! f make will make a vector if it has any elements
 130     [ (middle-tag) ] f make pass-blank ;
 131
 132 : end-tag ( name attrs-alist -- tag )
 133     tag-ns pass-blank get-char CHAR: / =
 134     [ pop-ns <contained> next ] [ <opener> ] if ;
 135
 136 : take-comment ( -- comment )
 137     "--" expect-string
 138     "--" take-string
 139     <comment>
 140     CHAR: > expect ;
 141
 142 : take-cdata ( -- string )
 143     "[CDATA[" expect-string "]]>" take-string ;
 144
 145 : take-element-decl ( -- element-decl )
 146     pass-blank " " take-string pass-blank ">" take-string <element-decl> ;
 147
 148 : take-attlist-decl ( -- doctype-decl )
 149     pass-blank " " take-string pass-blank ">" take-string <attlist-decl> ;
 150
 151 : take-until-one-of ( seps -- str sep )
 152     '[ get-char _ member? ] take-until get-char ;
 153
 154 : only-blanks ( str -- )
 155     [ blank? ] all? [ bad-doctype-decl ] unless ;
 156
 157 : take-system-literal ( -- str ) ! replace with parse-quote?
 158     pass-blank get-char next {
 159         { CHAR: ' [ "'" take-string ] }
 160         { CHAR: " [ "\"" take-string ] }
 161     } case ;
 162
 163 : take-system-id ( -- system-id )
 164     take-system-literal <system-id>
 165     ">" take-string only-blanks ;
 166
 167 : take-public-id ( -- public-id )
 168     take-system-literal
 169     take-system-literal <public-id>
 170     ">" take-string only-blanks ;
 171
 172 DEFER: direct
 173
 174 : (take-internal-subset) ( -- )
 175     pass-blank get-char {
 176         { CHAR: ] [ next ] }
 177         [ drop "<!" expect-string direct , (take-internal-subset) ]
 178     } case ;
 179
 180 : take-internal-subset ( -- seq )
 181     [ (take-internal-subset) ] { } make ;
 182
 183 : (take-external-id) ( token -- external-id )
 184     pass-blank {
 185         { "SYSTEM" [ take-system-id ] }
 186         { "PUBLIC" [ take-public-id ] }
 187         [ bad-external-id ]
 188     } case ;
 189
 190 : take-external-id ( -- external-id )
 191     " " take-string (take-external-id) ;
 192
 193 : take-doctype-decl ( -- doctype-decl )
 194     pass-blank " >" take-until-one-of {
 195         { CHAR: \s [
 196             pass-blank get-char CHAR: [ = [
 197                 next take-internal-subset f swap
 198                 ">" take-string only-blanks
 199             ] [
 200                 " >" take-until-one-of {
 201                     { CHAR: \s [ (take-external-id) ] }
 202                     { CHAR: > [ only-blanks f ] }
 203                 } case f
 204             ] if
 205         ] }
 206         { CHAR: > [ f f ] }
 207     } case <doctype-decl> ;
 208
 209 : take-entity-def ( -- entity-name entity-def )
 210     " " take-string pass-blank get-char {
 211         { CHAR: ' [ parse-quote ] }
 212         { CHAR: " [ parse-quote ] }
 213         [ drop take-external-id ]
 214     } case ;
 215
 216 : associate-entity ( entity-name entity-def -- )
 217     swap extra-entities [ ?set-at ] change ;
 218
 219 : take-entity-decl ( -- entity-decl )
 220     pass-blank get-char {
 221         { CHAR: % [ next pass-blank take-entity-def ] }
 222         [ drop take-entity-def 2dup associate-entity ]
 223     } case
 224     ">" take-string only-blanks <entity-decl> ;
 225
 226 : take-directive ( -- directive )
 227     " " take-string {
 228         { "ELEMENT" [ take-element-decl ] }
 229         { "ATTLIST" [ take-attlist-decl ] }
 230         { "DOCTYPE" [ take-doctype-decl ] }
 231         { "ENTITY" [ take-entity-decl ] }
 232         [ bad-directive ]
 233     } case ;
 234
 235 : direct ( -- object )
 236     get-char {
 237         { CHAR: - [ take-comment ] }
 238         { CHAR: [ [ take-cdata ] }
 239         [ drop take-directive ]
 240     } case ;
 241
 242 : yes/no>bool ( string -- t/f )
 243     {
 244         { "yes" [ t ] }
 245         { "no" [ f ] }
 246         [ not-yes/no ]
 247     } case ;
 248
 249 : assure-no-extra ( seq -- )
 250     [ first ] map {
 251         T{ name f "" "version" f }
 252         T{ name f "" "encoding" f }
 253         T{ name f "" "standalone" f }
 254     } diff
 255     [ extra-attrs ] unless-empty ;
 256
 257 : good-version ( version -- version )
 258     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
 259
 260 : prolog-version ( alist -- version )
 261     T{ name f "" "version" f } swap at
 262     [ good-version ] [ versionless-prolog ] if* ;
 263
 264 : prolog-encoding ( alist -- encoding )
 265     T{ name f "" "encoding" f } swap at "UTF-8" or ;
 266
 267 : prolog-standalone ( alist -- version )
 268     T{ name f "" "standalone" f } swap at
 269     [ yes/no>bool ] [ f ] if* ;
 270
 271 : prolog-attrs ( alist -- prolog )
 272     [ prolog-version ]
 273     [ prolog-encoding ]
 274     [ prolog-standalone ]
 275     tri <prolog> ;
 276
 277 SYMBOL: string-input?
 278 : decode-input-if ( encoding -- )
 279     string-input? get [ drop ] [ decode-input ] if ;
 280
 281 : parse-prolog ( -- prolog )
 282     pass-blank middle-tag "?>" expect-string
 283     dup assure-no-extra prolog-attrs
 284     dup encoding>> dup "UTF-16" =
 285     [ drop ] [ name>encoding [ decode-input-if ] when* ] if
 286     dup prolog-data set ;
 287
 288 : instruct ( -- instruction )
 289     "" (parse-name) dup "xml" =
 290     [ drop parse-prolog ] [
 291         dup >lower "xml" =
 292         [ capitalized-prolog ]
 293         [ "?>" take-string append <instruction> ] if
 294     ] if ;
 295
 296 : make-tag ( -- tag )
 297     {
 298         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
 299         { [ CHAR: ? = ] [ next instruct ] }
 300         [
 301             start-tag [ dup add-ns pop-ns <closer> ]
 302             [ middle-tag end-tag ] if
 303             CHAR: > expect
 304         ]
 305     } cond ;
 306
 307 ! Autodetecting encodings
 308
 309 : continue-make-tag ( str -- tag )
 310     parse-name-starting middle-tag end-tag CHAR: > expect ;
 311
 312 : start-utf16le ( -- tag )
 313     utf16le decode-input-if
 314     CHAR: ? expect
 315     0 expect instruct ;
 316
 317 : 10xxxxxx? ( ch -- ? )
 318     -6 shift 3 bitand 2 = ;
 319
 320 : start<name ( ch -- tag )
 321     ascii?
 322     [ utf8 decode-input-if next make-tag ] [
 323         next
 324         [ get-next 10xxxxxx? not ] take-until
 325         get-char suffix utf8 decode
 326         utf8 decode-input-if next
 327         continue-make-tag
 328     ] if ;
 329
 330 : start< ( -- tag )
 331     get-next {
 332         { 0 [ next next start-utf16le ] }
 333         { CHAR: ? [ next next instruct ] } ! XML prolog parsing sets the encoding
 334         { CHAR: ! [ utf8 decode-input next next direct ] }
 335         [ start<name ]
 336     } case ;
 337
 338 : skip-utf8-bom ( -- tag )
 339     "\u0000bb\u0000bf" expect utf8 decode-input
 340     CHAR: < expect make-tag ;
 341
 342 : decode-expecting ( encoding string -- tag )
 343     [ decode-input-if next ] [ expect-string ] bi* make-tag ;
 344
 345 : start-utf16be ( -- tag )
 346     utf16be "<" decode-expecting ;
 347
 348 : skip-utf16le-bom ( -- tag )
 349     utf16le "\u0000fe<" decode-expecting ;
 350
 351 : skip-utf16be-bom ( -- tag )
 352     utf16be "\u0000ff<" decode-expecting ;
 353
 354 : start-document ( -- tag )
 355     get-char {
 356         { CHAR: < [ start< ] }
 357         { 0 [ start-utf16be ] }
 358         { HEX: EF [ skip-utf8-bom ] }
 359         { HEX: FF [ skip-utf16le-bom ] }
 360         { HEX: FE [ skip-utf16be-bom ] }
 361         { f [ "" ] }
 362         [ drop utf8 decode-input-if f ]
 363         ! Same problem as with <e`>, in the case of XML chunks?
 364     } case ;