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